1! 2! Demonstrates use of MatDuplicate() for a shell matrix with a context 3! 4#include "petsc/finclude/petscmat.h" 5MODULE solver_context_ex20f 6 USE petscmat 7 IMPLICIT NONE 8 TYPE :: MatCtx 9 PetscReal :: lambda 10 END TYPE MatCtx 11END MODULE solver_context_ex20f 12 13MODULE solver_context_interfaces_ex20f 14 USE solver_context_ex20f 15 IMPLICIT NONE 16 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 27 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 36 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 45 46END MODULE solver_context_interfaces_ex20f 47 48! ---------------------------------------------------- 49! main program 50! ---------------------------------------------------- 51PROGRAM main 52 USE solver_context_interfaces_ex20f 53 IMPLICIT NONE 54 Mat :: F, Fcopy 55 TYPE(MatCtx) :: ctxF 56 TYPE(MatCtx), POINTER :: ctxF_pt, ctxFcopy_pt 57 PetscErrorCode :: ierr 58 PetscInt :: n = 128 59 external MatDuplicate_F 60 61 PetscCallA(PetscInitialize(ierr)) 62 ctxF%lambda = 3.14d0 63 PetscCallA(MatCreateShell(PETSC_COMM_WORLD, PETSC_DECIDE, PETSC_DECIDE, n, n, ctxF, F, ierr)) 64 PetscCallA(MatShellSetOperation(F, MATOP_DUPLICATE, MatDuplicate_F, ierr)) 65 PRINT *, 'ctxF%lambda = ', ctxF%lambda 66 67 PetscCallA(MatShellGetContext(F, ctxF_pt, ierr)) 68 PRINT *, 'ctxF_pt%lambda = ', ctxF_pt%lambda 69 70 PetscCallA(MatDuplicate(F, MAT_DO_NOT_COPY_VALUES, Fcopy, ierr)) 71 PetscCallA(MatShellGetContext(Fcopy, ctxFcopy_pt, ierr)) 72 PRINT *, 'ctxFcopy_pt%lambda = ', ctxFcopy_pt%lambda 73 74 PetscCallA(MatDestroy(F, ierr)) 75 PetscCallA(MatDestroy(Fcopy, ierr)) 76 PetscCallA(PetscFinalize(ierr)) 77END PROGRAM main 78 79SUBROUTINE MatDuplicate_F(F, opt, M, ierr) 80 USE solver_context_interfaces_ex20f 81 IMPLICIT NONE 82 83 Mat :: F, M 84 MatDuplicateOption :: opt 85 PetscErrorCode :: ierr 86 PetscInt :: ml, nl 87 TYPE(MatCtx), POINTER :: ctxM, ctxF_pt 88 external MatDestroy_F 89 90 PetscCall(MatGetLocalSize(F, ml, nl, ierr)) 91 PetscCall(MatShellGetContext(F, ctxF_pt, ierr)) 92 allocate (ctxM) 93 ctxM%lambda = ctxF_pt%lambda 94 PetscCall(MatCreateShell(PETSC_COMM_WORLD, ml, nl, PETSC_DETERMINE, PETSC_DETERMINE, ctxM, M, ierr)) 95! PetscCall(MatShellSetOperation(M,MATOP_DUPLICATE,MatDuplicate_F,ierr)) 96 PetscCall(MatShellSetOperation(M, MATOP_DESTROY, MatDestroy_F, ierr)) 97END SUBROUTINE MatDuplicate_F 98 99SUBROUTINE MatDestroy_F(F, ierr) 100 USE solver_context_interfaces_ex20f 101 IMPLICIT NONE 102 103 Mat :: F 104 PetscErrorCode :: ierr 105 TYPE(MatCtx), POINTER :: ctxF_pt 106 PetscCall(MatShellGetContext(F, ctxF_pt, ierr)) 107 deallocate (ctxF_pt) 108END SUBROUTINE MatDestroy_F 109 110!/*TEST 111! 112! build: 113! requires: double 114! 115! test: 116! 117!TEST*/ 118