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*/