1! 2! Demonstrates use of MatDuplicate() for a shell matrix with a context 3! 4MODULE 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 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#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 61 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 67 68 PetscCallA(MatShellGetContext(F, ctxF_pt, ierr)) 69 PRINT *, 'ctxF_pt%lambda = ', ctxF_pt%lambda 70 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 74 75 PetscCallA(MatDestroy(F, ierr)) 76 PetscCallA(MatDestroy(Fcopy, ierr)) 77 PetscCallA(PetscFinalize(ierr)) 78END PROGRAM main 79 80SUBROUTINE MatDuplicate_F(F, opt, M, ierr) 81 USE solver_context_interfaces_ex20f 82 IMPLICIT NONE 83 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 90 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)) 98END SUBROUTINE MatDuplicate_F 99 100SUBROUTINE MatDestroy_F(F, ierr) 101 USE solver_context_interfaces_ex20f 102 IMPLICIT NONE 103 104 Mat :: F 105 PetscErrorCode :: ierr 106 TYPE(MatCtx), POINTER :: ctxF_pt 107 PetscCall(MatShellGetContext(F, ctxF_pt, ierr)) 108 deallocate (ctxF_pt) 109END SUBROUTINE MatDestroy_F 110 111!/*TEST 112! 113! build: 114! requires: double 115! 116! test: 117! 118!TEST*/ 119