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 12 13 MODULE 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 46 END MODULE solver_context_interfaces_ex20f 47 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 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)) 78 END PROGRAM main 79 80 SUBROUTINE 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)) 98 END SUBROUTINE MatDuplicate_F 99 100 SUBROUTINE 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) 109 END SUBROUTINE MatDestroy_F 110 111!/*TEST 112! 113! build: 114! requires: double 115! 116! test: 117! 118!TEST*/ 119