xref: /petsc/src/mat/tutorials/ex20f.F90 (revision d7974de0bb28820a4deab863dae36e244f8c42e4) 
1!
2!     Demonstrates use of MatDuplicate() for a shell matrix with a context
3!
4#include "petsc/finclude/petscmat.h"
5module ex20fmodule
6  use petscmat
7  implicit none
8  type :: MatCtx
9    PetscReal :: lambda
10  end type MatCtx
11
12  interface
13    subroutine MatCreateShell(comm, mloc, nloc, m, n, ctx, mat, ierr)
14      use petscmat
15      import MatCtx
16      implicit none
17      MPI_Comm :: comm
18      PetscInt :: mloc, nloc, m, n
19      type(MatCtx) :: ctx
20      Mat :: mat
21      PetscErrorCode :: ierr
22    end subroutine MatCreateShell
23
24    subroutine MatShellSetContext(mat, ctx, ierr)
25      use petscmat
26      import MatCtx
27      implicit none
28      Mat :: mat
29      type(MatCtx) :: ctx
30      PetscErrorCode :: ierr
31    end subroutine MatShellSetContext
32
33    subroutine MatShellGetContext(mat, ctx, ierr)
34      use petscmat
35      import MatCtx
36      implicit none
37      Mat :: mat
38      type(MatCtx), pointer :: ctx
39      PetscErrorCode :: ierr
40    end subroutine MatShellGetContext
41  end interface
42
43contains
44  subroutine MatDuplicate_F(F, opt, M, ierr)
45
46    Mat                  :: F, M
47    MatDuplicateOption   :: opt
48    PetscErrorCode       :: ierr
49    PetscInt             :: ml, nl
50    type(MatCtx), pointer :: ctxM, ctxF_pt
51
52    PetscCall(MatGetLocalSize(F, ml, nl, ierr))
53    PetscCall(MatShellGetContext(F, ctxF_pt, ierr))
54    allocate (ctxM)
55    ctxM%lambda = ctxF_pt%lambda
56    PetscCall(MatCreateShell(PETSC_COMM_WORLD, ml, nl, PETSC_DETERMINE, PETSC_DETERMINE, ctxM, M, ierr))
57!        PetscCall(MatShellSetOperation(M,MATOP_DUPLICATE,MatDuplicate_F,ierr))
58    PetscCall(MatShellSetOperation(M, MATOP_DESTROY, MatDestroy_F, ierr))
59  end subroutine MatDuplicate_F
60
61  subroutine MatDestroy_F(F, ierr)
62
63    Mat                  :: F
64    PetscErrorCode       :: ierr
65    type(MatCtx), pointer :: ctxF_pt
66    PetscCall(MatShellGetContext(F, ctxF_pt, ierr))
67    deallocate (ctxF_pt)
68  end subroutine MatDestroy_F
69
70end module ex20fmodule
71
72! ----------------------------------------------------
73!                    main program
74! ----------------------------------------------------
75program main
76  use ex20fmodule
77  implicit none
78  Mat                  :: F, Fcopy
79  type(MatCtx)         :: ctxF
80  type(MatCtx), pointer :: ctxF_pt, ctxFcopy_pt
81  PetscErrorCode       :: ierr
82  PetscInt             :: n = 128
83
84  PetscCallA(PetscInitialize(ierr))
85  ctxF%lambda = 3.14d0
86  PetscCallA(MatCreateShell(PETSC_COMM_WORLD, PETSC_DECIDE, PETSC_DECIDE, n, n, ctxF, F, ierr))
87  PetscCallA(MatShellSetOperation(F, MATOP_DUPLICATE, MatDuplicate_F, ierr))
88  print *, 'ctxF%lambda = ', ctxF%lambda
89
90  PetscCallA(MatShellGetContext(F, ctxF_pt, ierr))
91  print *, 'ctxF_pt%lambda = ', ctxF_pt%lambda
92
93  PetscCallA(MatDuplicate(F, MAT_DO_NOT_COPY_VALUES, Fcopy, ierr))
94  PetscCallA(MatShellGetContext(Fcopy, ctxFcopy_pt, ierr))
95  print *, 'ctxFcopy_pt%lambda = ', ctxFcopy_pt%lambda
96
97  PetscCallA(MatDestroy(F, ierr))
98  PetscCallA(MatDestroy(Fcopy, ierr))
99  PetscCallA(PetscFinalize(ierr))
100end program main
101
102!/*TEST
103!
104!     build:
105!       requires: double
106!
107!     test:
108!
109!TEST*/
110