1: !
  2: !     Demonstrates use of MatDuplicate() for a shell matrix with a context
  3: !
  4: #include "petsc/finclude/petscmat.h"
  5: module ex20fmodule
  6:   use petscmat
  7:   implicit none
  8:   type :: MatCtx
  9:     PetscReal :: lambda
 10:   end type MatCtx

 12:   interface
 13:     subroutine MatCreateShell(comm, mloc, nloc, m, n, ctx, mat, ierr)
 14:       use petscmat
 15:       import MatCtx
 16:       implicit none
 17:       MPI_Comm :: comm
 18:       PetscInt :: mloc, nloc, m, n
 19:       type(MatCtx) :: ctx
 20:       Mat :: mat
 21:       PetscErrorCode :: ierr
 22:     end subroutine MatCreateShell

 24:     subroutine MatShellSetContext(mat, ctx, ierr)
 25:       use petscmat
 26:       import MatCtx
 27:       implicit none
 28:       Mat :: mat
 29:       type(MatCtx) :: ctx
 30:       PetscErrorCode :: ierr
 31:     end subroutine MatShellSetContext

 33:     subroutine MatShellGetContext(mat, ctx, ierr)
 34:       use petscmat
 35:       import MatCtx
 36:       implicit none
 37:       Mat :: mat
 38:       type(MatCtx), pointer :: ctx
 39:       PetscErrorCode :: ierr
 40:     end subroutine MatShellGetContext
 41:   end interface

 43: contains
 44:   subroutine MatDuplicate_F(F, opt, M, ierr)

 46:     Mat                  :: F, M
 47:     MatDuplicateOption   :: opt
 48:     PetscErrorCode       :: ierr
 49:     PetscInt             :: ml, nl
 50:     type(MatCtx), pointer :: ctxM, ctxF_pt

 52:     PetscCall(MatGetLocalSize(F, ml, nl, ierr))
 53:     PetscCall(MatShellGetContext(F, ctxF_pt, ierr))
 54:     allocate (ctxM)
 55:     ctxM%lambda = ctxF_pt%lambda
 56:     PetscCall(MatCreateShell(PETSC_COMM_WORLD, ml, nl, PETSC_DETERMINE, PETSC_DETERMINE, ctxM, M, ierr))
 57: !        PetscCall(MatShellSetOperation(M,MATOP_DUPLICATE,MatDuplicate_F,ierr))
 58:     PetscCall(MatShellSetOperation(M, MATOP_DESTROY, MatDestroy_F, ierr))
 59:   end subroutine MatDuplicate_F

 61:   subroutine MatDestroy_F(F, ierr)

 63:     Mat                  :: F
 64:     PetscErrorCode       :: ierr
 65:     type(MatCtx), pointer :: ctxF_pt
 66:     PetscCall(MatShellGetContext(F, ctxF_pt, ierr))
 67:     deallocate (ctxF_pt)
 68:   end subroutine MatDestroy_F

 70: end module ex20fmodule

 72: ! ----------------------------------------------------
 73: !                    main program
 74: ! ----------------------------------------------------
 75: program main
 76:   use ex20fmodule
 77:   implicit none
 78:   Mat                  :: F, Fcopy
 79:   type(MatCtx)         :: ctxF
 80:   type(MatCtx), pointer :: ctxF_pt, ctxFcopy_pt
 81:   PetscErrorCode       :: ierr
 82:   PetscInt             :: n = 128

 84:   PetscCallA(PetscInitialize(ierr))
 85:   ctxF%lambda = 3.14d0
 86:   PetscCallA(MatCreateShell(PETSC_COMM_WORLD, PETSC_DECIDE, PETSC_DECIDE, n, n, ctxF, F, ierr))
 87:   PetscCallA(MatShellSetOperation(F, MATOP_DUPLICATE, MatDuplicate_F, ierr))
 88:   print *, 'ctxF%lambda = ', ctxF%lambda

 90:   PetscCallA(MatShellGetContext(F, ctxF_pt, ierr))
 91:   print *, 'ctxF_pt%lambda = ', ctxF_pt%lambda

 93:   PetscCallA(MatDuplicate(F, MAT_DO_NOT_COPY_VALUES, Fcopy, ierr))
 94:   PetscCallA(MatShellGetContext(Fcopy, ctxFcopy_pt, ierr))
 95:   print *, 'ctxFcopy_pt%lambda = ', ctxFcopy_pt%lambda

 97:   PetscCallA(MatDestroy(F, ierr))
 98:   PetscCallA(MatDestroy(Fcopy, ierr))
 99:   PetscCallA(PetscFinalize(ierr))
100: end program main

102: !/*TEST
103: !
104: !     build:
105: !       requires: double
106: !
107: !     test:
108: !
109: !TEST*/