1: !
  2: !     Demonstrates use of MatDuplicate() for a shell matrix with a context
  3: !
  4: MODULE solver_context_ex20f
  5: #include "petsc/finclude/petscmat.h"
  6:   USE petscmat
  7:   IMPLICIT NONE
  8:   TYPE :: MatCtx
  9:     PetscReal :: lambda
 10:   END TYPE MatCtx
 11: END MODULE solver_context_ex20f

 13: MODULE solver_context_interfaces_ex20f
 14:   USE solver_context_ex20f
 15:   IMPLICIT NONE

 17:   INTERFACE MatCreateShell
 18:     SUBROUTINE MatCreateShell(comm, mloc, nloc, m, n, ctx, mat, ierr)
 19:       USE solver_context_ex20f
 20:       MPI_Comm :: comm
 21:       PetscInt :: mloc, nloc, m, n
 22:       TYPE(MatCtx) :: ctx
 23:       Mat :: mat
 24:       PetscErrorCode :: ierr
 25:     END SUBROUTINE MatCreateShell
 26:   END INTERFACE MatCreateShell

 28:   INTERFACE MatShellSetContext
 29:     SUBROUTINE MatShellSetContext(mat, ctx, ierr)
 30:       USE solver_context_ex20f
 31:       Mat :: mat
 32:       TYPE(MatCtx) :: ctx
 33:       PetscErrorCode :: ierr
 34:     END SUBROUTINE MatShellSetContext
 35:   END INTERFACE MatShellSetContext

 37:   INTERFACE MatShellGetContext
 38:     SUBROUTINE MatShellGetContext(mat, ctx, ierr)
 39:       USE solver_context_ex20f
 40:       Mat :: mat
 41:       TYPE(MatCtx), POINTER :: ctx
 42:       PetscErrorCode :: ierr
 43:     END SUBROUTINE MatShellGetContext
 44:   END INTERFACE MatShellGetContext

 46: END MODULE solver_context_interfaces_ex20f

 48: ! ----------------------------------------------------
 49: !                    main program
 50: ! ----------------------------------------------------
 51: PROGRAM main
 52: #include "petsc/finclude/petscmat.h"
 53:   USE solver_context_interfaces_ex20f
 54:   IMPLICIT NONE
 55:   Mat                  :: F, Fcopy
 56:   TYPE(MatCtx)         :: ctxF
 57:   TYPE(MatCtx), POINTER :: ctxF_pt, ctxFcopy_pt
 58:   PetscErrorCode       :: ierr
 59:   PetscInt             :: n = 128
 60:   external MatDuplicate_F

 62:   PetscCallA(PetscInitialize(ierr))
 63:   ctxF%lambda = 3.14d0
 64:   PetscCallA(MatCreateShell(PETSC_COMM_WORLD, PETSC_DECIDE, PETSC_DECIDE, n, n, ctxF, F, ierr))
 65:   PetscCallA(MatShellSetOperation(F, MATOP_DUPLICATE, MatDuplicate_F, ierr))
 66:   PRINT *, 'ctxF%lambda = ', ctxF%lambda

 68:   PetscCallA(MatShellGetContext(F, ctxF_pt, ierr))
 69:   PRINT *, 'ctxF_pt%lambda = ', ctxF_pt%lambda

 71:   PetscCallA(MatDuplicate(F, MAT_DO_NOT_COPY_VALUES, Fcopy, ierr))
 72:   PetscCallA(MatShellGetContext(Fcopy, ctxFcopy_pt, ierr))
 73:   PRINT *, 'ctxFcopy_pt%lambda = ', ctxFcopy_pt%lambda

 75:   PetscCallA(MatDestroy(F, ierr))
 76:   PetscCallA(MatDestroy(Fcopy, ierr))
 77:   PetscCallA(PetscFinalize(ierr))
 78: END PROGRAM main

 80: SUBROUTINE MatDuplicate_F(F, opt, M, ierr)
 81:   USE solver_context_interfaces_ex20f
 82:   IMPLICIT NONE

 84:   Mat                  :: F, M
 85:   MatDuplicateOption   :: opt
 86:   PetscErrorCode       :: ierr
 87:   PetscInt             :: ml, nl
 88:   TYPE(MatCtx), POINTER :: ctxM, ctxF_pt
 89:   external MatDestroy_F

 91:   PetscCall(MatGetLocalSize(F, ml, nl, ierr))
 92:   PetscCall(MatShellGetContext(F, ctxF_pt, ierr))
 93:   allocate (ctxM)
 94:   ctxM%lambda = ctxF_pt%lambda
 95:   PetscCall(MatCreateShell(PETSC_COMM_WORLD, ml, nl, PETSC_DETERMINE, PETSC_DETERMINE, ctxM, M, ierr))
 96: !        PetscCall(MatShellSetOperation(M,MATOP_DUPLICATE,MatDuplicate_F,ierr))
 97:   PetscCall(MatShellSetOperation(M, MATOP_DESTROY, MatDestroy_F, ierr))
 98: END SUBROUTINE MatDuplicate_F

100: SUBROUTINE MatDestroy_F(F, ierr)
101:   USE solver_context_interfaces_ex20f
102:   IMPLICIT NONE

104:   Mat                  :: F
105:   PetscErrorCode       :: ierr
106:   TYPE(MatCtx), POINTER :: ctxF_pt
107:   PetscCall(MatShellGetContext(F, ctxF_pt, ierr))
108:   deallocate (ctxF_pt)
109: END SUBROUTINE MatDestroy_F

111: !/*TEST
112: !
113: !     build:
114: !       requires: double
115: !
116: !     test:
117: !
118: !TEST*/