1*c4762a1bSJed Brown! 2*c4762a1bSJed Brown! Demonstrates use of MatShellSetContext() and MatShellGetContext() 3*c4762a1bSJed Brown! 4*c4762a1bSJed Brown! Contributed by: Samuel Lanthaler 5*c4762a1bSJed Brown! 6*c4762a1bSJed Brown MODULE solver_context 7*c4762a1bSJed Brown#include "petsc/finclude/petsc.h" 8*c4762a1bSJed Brown USE petscsys 9*c4762a1bSJed Brown USE petscmat 10*c4762a1bSJed Brown IMPLICIT NONE 11*c4762a1bSJed Brown TYPE :: MatCtx 12*c4762a1bSJed Brown PetscReal :: lambda,kappa 13*c4762a1bSJed Brown PetscReal :: h 14*c4762a1bSJed Brown END TYPE MatCtx 15*c4762a1bSJed Brown END MODULE solver_context 16*c4762a1bSJed Brown 17*c4762a1bSJed Brown MODULE solver_context_interfaces 18*c4762a1bSJed Brown USE solver_context 19*c4762a1bSJed Brown IMPLICIT NONE 20*c4762a1bSJed Brown 21*c4762a1bSJed Brown! ---------------------------------------------------- 22*c4762a1bSJed Brown INTERFACE MatCreateShell 23*c4762a1bSJed Brown SUBROUTINE MatCreateShell(comm,mloc,nloc,m,n,ctx,mat,ierr) 24*c4762a1bSJed Brown USE solver_context 25*c4762a1bSJed Brown MPI_Comm :: comm 26*c4762a1bSJed Brown PetscInt :: mloc,nloc,m,n 27*c4762a1bSJed Brown TYPE(MatCtx) :: ctx 28*c4762a1bSJed Brown Mat :: mat 29*c4762a1bSJed Brown PetscErrorCode :: ierr 30*c4762a1bSJed Brown END SUBROUTINE MatCreateShell 31*c4762a1bSJed Brown END INTERFACE MatCreateShell 32*c4762a1bSJed Brown! ---------------------------------------------------- 33*c4762a1bSJed Brown 34*c4762a1bSJed Brown! ---------------------------------------------------- 35*c4762a1bSJed Brown INTERFACE MatShellSetContext 36*c4762a1bSJed Brown SUBROUTINE MatShellSetContext(mat,ctx,ierr) 37*c4762a1bSJed Brown USE solver_context 38*c4762a1bSJed Brown Mat :: mat 39*c4762a1bSJed Brown TYPE(MatCtx) :: ctx 40*c4762a1bSJed Brown PetscErrorCode :: ierr 41*c4762a1bSJed Brown END SUBROUTINE MatShellSetContext 42*c4762a1bSJed Brown END INTERFACE MatShellSetContext 43*c4762a1bSJed Brown! ---------------------------------------------------- 44*c4762a1bSJed Brown 45*c4762a1bSJed Brown! ---------------------------------------------------- 46*c4762a1bSJed Brown INTERFACE MatShellGetContext 47*c4762a1bSJed Brown SUBROUTINE MatShellGetContext(mat,ctx,ierr) 48*c4762a1bSJed Brown USE solver_context 49*c4762a1bSJed Brown Mat :: mat 50*c4762a1bSJed Brown TYPE(MatCtx), POINTER :: ctx 51*c4762a1bSJed Brown PetscErrorCode :: ierr 52*c4762a1bSJed Brown END SUBROUTINE MatShellGetContext 53*c4762a1bSJed Brown END INTERFACE MatShellGetContext 54*c4762a1bSJed Brown 55*c4762a1bSJed Brown END MODULE solver_context_interfaces 56*c4762a1bSJed Brown 57*c4762a1bSJed Brown! ---------------------------------------------------- 58*c4762a1bSJed Brown! main program 59*c4762a1bSJed Brown! ---------------------------------------------------- 60*c4762a1bSJed Brown PROGRAM main 61*c4762a1bSJed Brown#include "petsc/finclude/petsc.h" 62*c4762a1bSJed Brown USE solver_context_interfaces 63*c4762a1bSJed Brown IMPLICIT NONE 64*c4762a1bSJed Brown Mat :: F 65*c4762a1bSJed Brown TYPE(MatCtx) :: ctxF 66*c4762a1bSJed Brown TYPE(MatCtx),POINTER :: ctxF_pt 67*c4762a1bSJed Brown PetscErrorCode :: ierr 68*c4762a1bSJed Brown PetscInt :: n=128 69*c4762a1bSJed Brown 70*c4762a1bSJed Brown CALL PetscInitialize(PETSC_NULL_CHARACTER,ierr) 71*c4762a1bSJed Brown if (ierr .ne. 0) then 72*c4762a1bSJed Brown print*,'Unable to initialize PETSc' 73*c4762a1bSJed Brown stop 74*c4762a1bSJed Brown endif 75*c4762a1bSJed Brown 76*c4762a1bSJed Brown ctxF%lambda = 3.14d0 77*c4762a1bSJed Brown CALL MatCreateShell(PETSC_COMM_WORLD,n,n,n,n,ctxF,F,ierr) 78*c4762a1bSJed Brown CALL MatShellSetContext(F,ctxF,ierr) 79*c4762a1bSJed Brown PRINT*,'ctxF%lambda = ',ctxF%lambda 80*c4762a1bSJed Brown 81*c4762a1bSJed Brown CALL MatShellGetContext(F,ctxF_pt,ierr) 82*c4762a1bSJed Brown PRINT*,'ctxF_pt%lambda = ',ctxF_pt%lambda 83*c4762a1bSJed Brown 84*c4762a1bSJed Brown call MatDestroy(F,ierr) 85*c4762a1bSJed Brown CALL PetscFinalize(ierr) 86*c4762a1bSJed Brown END PROGRAM main 87*c4762a1bSJed Brown 88*c4762a1bSJed Brown!/*TEST 89*c4762a1bSJed Brown! 90*c4762a1bSJed Brown! build: 91*c4762a1bSJed Brown! requires: double 92*c4762a1bSJed Brown! 93*c4762a1bSJed Brown! test: 94*c4762a1bSJed Brown! 95*c4762a1bSJed Brown!TEST*/ 96