1: !
  2: !     Demonstrates use of MatShellSetContext() and MatShellGetContext()
  3: !
  4: !     Contributed by:  Samuel Lanthaler
  5: !
  6:      MODULE solver_context
  7: #include "petsc/finclude/petsc.h"
  8:        USE petscsys
  9:        USE petscmat
 10:        IMPLICIT NONE
 11:        TYPE :: MatCtx
 12:          PetscReal :: lambda,kappa
 13:          PetscReal :: h
 14:        END TYPE MatCtx
 15:      END MODULE solver_context

 17:      MODULE solver_context_interfaces
 18:        USE solver_context
 19:        IMPLICIT NONE

 21: ! ----------------------------------------------------
 22:        INTERFACE MatCreateShell
 23:          SUBROUTINE MatCreateShell(comm,mloc,nloc,m,n,ctx,mat,ierr)
 24:            USE solver_context
 25:            MPI_Comm :: comm
 26:            PetscInt :: mloc,nloc,m,n
 27:            TYPE(MatCtx) :: ctx
 28:            Mat :: mat
 29:            PetscErrorCode :: ierr
 30:          END SUBROUTINE MatCreateShell
 31:        END INTERFACE MatCreateShell
 32: ! ----------------------------------------------------

 34: ! ----------------------------------------------------
 35:        INTERFACE MatShellSetContext
 36:          SUBROUTINE MatShellSetContext(mat,ctx,ierr)
 37:            USE solver_context
 38:            Mat :: mat
 39:            TYPE(MatCtx) :: ctx
 40:            PetscErrorCode :: ierr
 41:          END SUBROUTINE MatShellSetContext
 42:        END INTERFACE MatShellSetContext
 43: ! ----------------------------------------------------

 45: ! ----------------------------------------------------
 46:        INTERFACE MatShellGetContext
 47:          SUBROUTINE MatShellGetContext(mat,ctx,ierr)
 48:            USE solver_context
 49:            Mat :: mat
 50:            TYPE(MatCtx),  POINTER :: ctx
 51:            PetscErrorCode :: ierr
 52:          END SUBROUTINE MatShellGetContext
 53:        END INTERFACE MatShellGetContext

 55:      END MODULE solver_context_interfaces

 57: ! ----------------------------------------------------
 58: !                    main program
 59: ! ----------------------------------------------------
 60:      PROGRAM main
 61: #include "petsc/finclude/petsc.h"
 62:        USE solver_context_interfaces
 63:        IMPLICIT NONE
 64:        Mat :: F
 65:        TYPE(MatCtx) :: ctxF
 66:        TYPE(MatCtx),POINTER :: ctxF_pt
 67:        PetscErrorCode :: ierr
 68:        PetscInt :: n=128

 70:        CALL PetscInitialize(PETSC_NULL_CHARACTER,ierr)
 71:        if (ierr .ne. 0) then
 72:           print*,'Unable to initialize PETSc'
 73:           stop
 74:         endif

 76:         ctxF%lambda = 3.14d0
 77:         CALL MatCreateShell(PETSC_COMM_WORLD,n,n,n,n,ctxF,F,ierr)
 78:         CALL MatShellSetContext(F,ctxF,ierr)
 79:         PRINT*,'ctxF%lambda = ',ctxF%lambda

 81:         CALL MatShellGetContext(F,ctxF_pt,ierr)
 82:         PRINT*,'ctxF_pt%lambda = ',ctxF_pt%lambda

 84:         call MatDestroy(F,ierr)
 85:         CALL PetscFinalize(ierr)
 86:       END PROGRAM main

 88: !/*TEST
 89: !
 90: !     build:
 91: !       requires: double
 92: !
 93: !     test:
 94: !
 95: !TEST*/