Actual source code: ex201f.F
petsc-3.12.2 2019-11-22
1: !
2: !
3: ! This program demonstrates use of MatShellSetOperation()
4: !
5: subroutine mymatmult(A, x, y, ierr)
6: #include <petsc/finclude/petscmat.h>
7: use petscmat
8: implicit none
11: Mat A
12: Vec x, y
13: PetscErrorCode ierr
15: print*, "Called MatMult"
16: return
17: end
19: subroutine mymatmultadd(A, x, y, z, ierr)
20: use petscmat
21: implicit none
22: Mat A
23: Vec x, y, z
24: PetscErrorCode ierr
26: print*, "Called MatMultAdd"
27: return
28: end
30: subroutine mymatmulttranspose(A, x, y, ierr)
31: use petscmat
32: implicit none
33: Mat A
34: Vec x, y
35: PetscErrorCode ierr
37: print*, "Called MatMultTranspose"
38: return
39: end
41: subroutine mymatmulttransposeadd(A, x, y, z, ierr)
42: use petscmat
43: implicit none
44: Mat A
45: Vec x, y, z
46: PetscErrorCode ierr
48: print*, "Called MatMultTransposeAdd"
49: return
50: end
52: subroutine mymattranspose(A, reuse, B, ierr)
53: use petscmat
54: implicit none
55: Mat A, B
56: MatReuse reuse
57: PetscErrorCode ierr
58: PetscInt i12,i0
60: i12 = 12
61: i0 = 0
62: call MatCreateShell(PETSC_COMM_SELF,i12,i12,i12,i12,i0,B,ierr)
63: call MatAssemblyBegin(B, MAT_FINAL_ASSEMBLY, ierr)
64: call MatAssemblyEnd(B, MAT_FINAL_ASSEMBLY, ierr)
66: print*, "Called MatTranspose"
67: return
68: end
70: subroutine mymatgetdiagonal(A, x, ierr)
71: use petscmat
72: implicit none
73: Mat A
74: Vec x
75: PetscErrorCode ierr
77: print*, "Called MatGetDiagonal"
78: return
79: end
81: subroutine mymatdiagonalscale(A, x, y, ierr)
82: use petscmat
83: implicit none
84: Mat A
85: Vec x, y
86: PetscErrorCode ierr
88: print*, "Called MatDiagonalScale"
89: return
90: end
92: subroutine mymatzeroentries(A, ierr)
93: use petscmat
94: implicit none
95: Mat A
96: PetscErrorCode ierr
98: print*, "Called MatZeroEntries"
99: return
100: end
102: subroutine mymataxpy(A, alpha, B, str, ierr)
103: use petscmat
104: implicit none
105: Mat A, B
106: PetscScalar alpha
107: MatStructure str
108: PetscErrorCode ierr
110: print*, "Called MatAXPY"
111: return
112: end
114: subroutine mymatshift(A, alpha, ierr)
115: use petscmat
116: implicit none
117: Mat A
118: PetscScalar alpha
119: PetscErrorCode ierr
121: print*, "Called MatShift"
122: return
123: end
125: subroutine mymatdiagonalset(A, x, ins, ierr)
126: use petscmat
127: implicit none
128: Mat A
129: Vec x
130: InsertMode ins
131: PetscErrorCode ierr
133: print*, "Called MatDiagonalSet"
134: return
135: end
137: subroutine mymatdestroy(A, ierr)
138: use petscmat
139: implicit none
140: Mat A
141: PetscErrorCode ierr
143: print*, "Called MatDestroy"
144: return
145: end
147: subroutine mymatview(A, viewer, ierr)
148: use petscmat
149: implicit none
150: Mat A
151: PetscViewer viewer
152: PetscErrorCode ierr
154: print*, "Called MatView"
155: return
156: end
158: subroutine mymatgetvecs(A, x, y, ierr)
159: use petscmat
160: implicit none
161: Mat A
162: Vec x, y
163: PetscErrorCode ierr
165: print*, "Called MatCreateVecs"
166: return
167: end
169: program main
170: use petscmat
171: implicit none
173: Mat m, mt
174: Vec x, y, z
175: PetscScalar a
176: PetscViewer viewer
177: MatOperation op
178: PetscErrorCode ierr
179: PetscInt i12,i0
180: external mymatmult
181: external mymatmultadd
182: external mymatmulttranspose
183: external mymatmulttransposeadd
184: external mymattranspose
185: external mymatgetdiagonal
186: external mymatdiagonalscale
187: external mymatzeroentries
188: external mymataxpy
189: external mymatshift
190: external mymatdiagonalset
191: external mymatdestroy
192: external mymatview
193: external mymatgetvecs
195: call PetscInitialize(PETSC_NULL_CHARACTER, ierr)
196: if (ierr .ne. 0) then
197: print*,'Unable to initialize PETSc'
198: stop
199: endif
201: viewer = PETSC_VIEWER_STDOUT_SELF
202: i12 = 12
203: i0 = 0
204: call VecCreateSeq(PETSC_COMM_SELF, i12, x, ierr)
205: call VecCreateSeq(PETSC_COMM_SELF, i12, y, ierr)
206: call VecCreateSeq(PETSC_COMM_SELF, i12, z, ierr)
207: call MatCreateShell(PETSC_COMM_SELF,i12,i12,i12,i12,i0,m,ierr)
208: call MatShellSetManageScalingShifts(m,ierr)
209: call MatAssemblyBegin(m, MAT_FINAL_ASSEMBLY, ierr)
210: call MatAssemblyEnd(m, MAT_FINAL_ASSEMBLY, ierr)
212: op = MATOP_MULT
213: call MatShellSetOperation(m, op, mymatmult, ierr)
214: op = MATOP_MULT_ADD
215: call MatShellSetOperation(m, op, mymatmultadd, ierr)
216: op = MATOP_MULT_TRANSPOSE
217: call MatShellSetOperation(m, op, mymatmulttranspose, ierr)
218: op = MATOP_MULT_TRANSPOSE_ADD
219: call MatShellSetOperation(m, op, mymatmulttransposeadd, ierr)
220: op = MATOP_TRANSPOSE
221: call MatShellSetOperation(m, op, mymattranspose, ierr)
222: op = MATOP_GET_DIAGONAL
223: call MatShellSetOperation(m, op, mymatgetdiagonal, ierr)
224: op = MATOP_DIAGONAL_SCALE
225: call MatShellSetOperation(m, op, mymatdiagonalscale, ierr)
226: op = MATOP_ZERO_ENTRIES
227: call MatShellSetOperation(m, op, mymatzeroentries, ierr)
228: op = MATOP_AXPY
229: call MatShellSetOperation(m, op, mymataxpy, ierr)
230: op = MATOP_SHIFT
231: call MatShellSetOperation(m, op, mymatshift, ierr)
232: op = MATOP_DIAGONAL_SET
233: call MatShellSetOperation(m, op, mymatdiagonalset, ierr)
234: op = MATOP_DESTROY
235: call MatShellSetOperation(m, op, mymatdestroy, ierr)
236: op = MATOP_VIEW
237: call MatShellSetOperation(m, op, mymatview, ierr)
238: op = MATOP_CREATE_VECS
239: call MatShellSetOperation(m, op, mymatgetvecs, ierr)
241: call MatMult(m, x, y, ierr)
242: call MatMultAdd(m, x, y, z, ierr)
243: call MatMultTranspose(m, x, y, ierr)
244: call MatMultTransposeAdd(m, x, y, z, ierr)
245: call MatTranspose(m, MAT_INITIAL_MATRIX, mt, ierr)
246: call MatGetDiagonal(m, x, ierr)
247: call MatDiagonalScale(m, x, y, ierr)
248: call MatZeroEntries(m, ierr)
249: a = 102.
250: call MatAXPY(m, a, mt, SAME_NONZERO_PATTERN, ierr)
251: call MatShift(m, a, ierr)
252: call MatDiagonalSet(m, x, INSERT_VALUES, ierr)
253: call MatView(m, viewer, ierr)
254: call MatCreateVecs(m, x, y, ierr)
255: call MatDestroy(m,ierr)
256: call MatDestroy(mt, ierr)
257: call VecDestroy(x, ierr)
258: call VecDestroy(y, ierr)
259: call VecDestroy(z, ierr)
261: call PetscFinalize(ierr)
262: end
264: !/*TEST
265: !
266: ! test:
267: ! args: -malloc_dump
268: ! filter: sort -b
269: ! filter_output: sort -b
270: !
271: !TEST*/