Actual source code: ex20f.F90

      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

     13:      MODULE solver_context_interfaces_ex20f
     14:        USE solver_context_ex20f
     15:        IMPLICIT NONE

     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

     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

     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

     46:      END MODULE solver_context_interfaces_ex20f

     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

     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

     68:        PetscCallA(MatShellGetContext(F,ctxF_pt,ierr))
     69:        PRINT*,'ctxF_pt%lambda = ',ctxF_pt%lambda

     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

     75:        PetscCallA(MatDestroy(F,ierr))
     76:        PetscCallA(MatDestroy(Fcopy,ierr))
     77:        PetscCallA(PetscFinalize(ierr))
     78:      END PROGRAM main

     80:        SUBROUTINE MatDuplicate_F(F, opt, M, ierr)
     81:        USE solver_context_interfaces_ex20f
     82:        IMPLICIT NONE

     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

     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

    100:        SUBROUTINE MatDestroy_F(F, ierr)
    101:        USE solver_context_interfaces_ex20f
    102:        IMPLICIT NONE

    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

    111: !/*TEST
    112: !
    113: !     build:
    114: !       requires: double
    115: !
    116: !     test:
    117: !
    118: !TEST*/