Actual source code: zshellf.c
1: #include <petsc/private/fortranimpl.h>
2: #include <petscmat.h>
4: #if defined(PETSC_HAVE_FORTRAN_CAPS)
5: #define matshellsetoperation_ MATSHELLSETOPERATION
6: #define matcreateshell_ MATCREATESHELL
7: #elif !defined(PETSC_HAVE_FORTRAN_UNDERSCORE)
8: #define matcreateshell_ matcreateshell
9: #define matshellsetoperation_ matshellsetoperation
10: #endif
12: /**
13: * Subset of MatOperation that is supported by the Fortran wrappers.
14: */
15: enum FortranMatOperation {
16: FORTRAN_MATOP_MULT = 0,
17: FORTRAN_MATOP_MULT_ADD = 1,
18: FORTRAN_MATOP_MULT_TRANSPOSE = 2,
19: FORTRAN_MATOP_MULT_TRANSPOSE_ADD = 3,
20: FORTRAN_MATOP_SOR = 4,
21: FORTRAN_MATOP_TRANSPOSE = 5,
22: FORTRAN_MATOP_GET_DIAGONAL = 6,
23: FORTRAN_MATOP_DIAGONAL_SCALE = 7,
24: FORTRAN_MATOP_ZERO_ENTRIES = 8,
25: FORTRAN_MATOP_AXPY = 9,
26: FORTRAN_MATOP_SHIFT = 10,
27: FORTRAN_MATOP_DIAGONAL_SET = 11,
28: FORTRAN_MATOP_DESTROY = 12,
29: FORTRAN_MATOP_VIEW = 13,
30: FORTRAN_MATOP_CREATE_VECS = 14,
31: FORTRAN_MATOP_GET_DIAGONAL_BLOCK = 15,
32: FORTRAN_MATOP_COPY = 16,
33: FORTRAN_MATOP_SCALE = 17,
34: FORTRAN_MATOP_SET_RANDOM = 18,
35: FORTRAN_MATOP_ASSEMBLY_BEGIN = 19,
36: FORTRAN_MATOP_ASSEMBLY_END = 20,
37: FORTRAN_MATOP_DUPLICATE = 21,
38: FORTRAN_MATOP_MULT_HT = 22,
39: FORTRAN_MATOP_MULT_HT_ADD = 23,
40: FORTRAN_MATOP_SIZE = 24
41: };
43: /*
44: The MatShell Matrix Vector product requires a C routine.
45: This C routine then calls the corresponding Fortran routine that was
46: set by the user.
47: */
48: PETSC_EXTERN void matcreateshell_(MPI_Comm *comm, PetscInt *m, PetscInt *n, PetscInt *M, PetscInt *N, void *ctx, Mat *mat, PetscErrorCode *ierr)
49: {
50: *ierr = MatCreateShell(MPI_Comm_f2c(*(MPI_Fint *)&*comm), *m, *n, *M, *N, ctx, mat);
51: }
53: static PetscErrorCode ourmult(Mat mat, Vec x, Vec y)
54: {
55: PetscCallFortranVoidFunction((*(void (*)(Mat *, Vec *, Vec *, PetscErrorCode *))(((PetscObject)mat)->fortran_func_pointers[FORTRAN_MATOP_MULT]))(&mat, &x, &y, &ierr));
56: return PETSC_SUCCESS;
57: }
59: static PetscErrorCode ourmultadd(Mat mat, Vec x, Vec y, Vec z)
60: {
61: PetscCallFortranVoidFunction((*(void (*)(Mat *, Vec *, Vec *, Vec *, PetscErrorCode *))(((PetscObject)mat)->fortran_func_pointers[FORTRAN_MATOP_MULT_ADD]))(&mat, &x, &y, &z, &ierr));
62: return PETSC_SUCCESS;
63: }
65: static PetscErrorCode ourmulttranspose(Mat mat, Vec x, Vec y)
66: {
67: PetscCallFortranVoidFunction((*(void (*)(Mat *, Vec *, Vec *, PetscErrorCode *))(((PetscObject)mat)->fortran_func_pointers[FORTRAN_MATOP_MULT_TRANSPOSE]))(&mat, &x, &y, &ierr));
68: return PETSC_SUCCESS;
69: }
71: static PetscErrorCode ourmulthermitiantranspose(Mat mat, Vec x, Vec y)
72: {
73: PetscCallFortranVoidFunction((*(void (*)(Mat *, Vec *, Vec *, PetscErrorCode *))(((PetscObject)mat)->fortran_func_pointers[FORTRAN_MATOP_MULT_HT]))(&mat, &x, &y, &ierr));
74: return PETSC_SUCCESS;
75: }
77: static PetscErrorCode ourmulttransposeadd(Mat mat, Vec x, Vec y, Vec z)
78: {
79: PetscCallFortranVoidFunction((*(void (*)(Mat *, Vec *, Vec *, Vec *, PetscErrorCode *))(((PetscObject)mat)->fortran_func_pointers[FORTRAN_MATOP_MULT_TRANSPOSE_ADD]))(&mat, &x, &y, &z, &ierr));
80: return PETSC_SUCCESS;
81: }
83: static PetscErrorCode ourmulthermitiantransposeadd(Mat mat, Vec x, Vec y, Vec z)
84: {
85: PetscCallFortranVoidFunction((*(void (*)(Mat *, Vec *, Vec *, Vec *, PetscErrorCode *))(((PetscObject)mat)->fortran_func_pointers[FORTRAN_MATOP_MULT_HT_ADD]))(&mat, &x, &y, &z, &ierr));
86: return PETSC_SUCCESS;
87: }
89: static PetscErrorCode oursor(Mat mat, Vec b, PetscReal omega, MatSORType flg, PetscReal shift, PetscInt its, PetscInt lits, Vec x)
90: {
91: PetscErrorCode ierr = PETSC_SUCCESS;
93: (*(void (*)(Mat *, Vec *, PetscReal *, MatSORType *, PetscReal *, PetscInt *, PetscInt *, Vec *, PetscErrorCode *))(((PetscObject)mat)->fortran_func_pointers[FORTRAN_MATOP_SOR]))(&mat, &b, &omega, &flg, &shift, &its, &lits, &x, &ierr);
94: return ierr;
95: }
97: static PetscErrorCode ourtranspose(Mat mat, MatReuse reuse, Mat *B)
98: {
99: Mat bb = (Mat)-1;
100: Mat *b = (!B ? &bb : B);
102: PetscCallFortranVoidFunction((*(void (*)(Mat *, MatReuse *, Mat *, PetscErrorCode *))(((PetscObject)mat)->fortran_func_pointers[FORTRAN_MATOP_TRANSPOSE]))(&mat, &reuse, b, &ierr));
103: return PETSC_SUCCESS;
104: }
106: static PetscErrorCode ourgetdiagonal(Mat mat, Vec x)
107: {
108: PetscCallFortranVoidFunction((*(void (*)(Mat *, Vec *, PetscErrorCode *))(((PetscObject)mat)->fortran_func_pointers[FORTRAN_MATOP_GET_DIAGONAL]))(&mat, &x, &ierr));
109: return PETSC_SUCCESS;
110: }
112: static PetscErrorCode ourdiagonalscale(Mat mat, Vec l, Vec r)
113: {
114: Vec aa = (Vec)-1;
115: Vec *a = (!l ? &aa : &l);
116: Vec *b = (!r ? &aa : &r);
118: PetscCallFortranVoidFunction((*(void (*)(Mat *, Vec *, Vec *, PetscErrorCode *))(((PetscObject)mat)->fortran_func_pointers[FORTRAN_MATOP_DIAGONAL_SCALE]))(&mat, a, b, &ierr));
119: return PETSC_SUCCESS;
120: }
122: static PetscErrorCode ourzeroentries(Mat mat)
123: {
124: PetscCallFortranVoidFunction((*(void (*)(Mat *, PetscErrorCode *))(((PetscObject)mat)->fortran_func_pointers[FORTRAN_MATOP_ZERO_ENTRIES]))(&mat, &ierr));
125: return PETSC_SUCCESS;
126: }
128: static PetscErrorCode ouraxpy(Mat mat, PetscScalar a, Mat X, MatStructure str)
129: {
130: PetscCallFortranVoidFunction((*(void (*)(Mat *, PetscScalar *, Mat *, MatStructure *, PetscErrorCode *))(((PetscObject)mat)->fortran_func_pointers[FORTRAN_MATOP_AXPY]))(&mat, &a, &X, &str, &ierr));
131: return PETSC_SUCCESS;
132: }
134: static PetscErrorCode ourshift(Mat mat, PetscScalar a)
135: {
136: PetscCallFortranVoidFunction((*(void (*)(Mat *, PetscScalar *, PetscErrorCode *))(((PetscObject)mat)->fortran_func_pointers[FORTRAN_MATOP_SHIFT]))(&mat, &a, &ierr));
137: return PETSC_SUCCESS;
138: }
140: static PetscErrorCode ourdiagonalset(Mat mat, Vec x, InsertMode ins)
141: {
142: PetscCallFortranVoidFunction((*(void (*)(Mat *, Vec *, InsertMode *, PetscErrorCode *))(((PetscObject)mat)->fortran_func_pointers[FORTRAN_MATOP_DIAGONAL_SET]))(&mat, &x, &ins, &ierr));
143: return PETSC_SUCCESS;
144: }
146: static PetscErrorCode ourdestroy(Mat mat)
147: {
148: PetscCallFortranVoidFunction((*(void (*)(Mat *, PetscErrorCode *))(((PetscObject)mat)->fortran_func_pointers[FORTRAN_MATOP_DESTROY]))(&mat, &ierr));
149: return PETSC_SUCCESS;
150: }
152: static PetscErrorCode ourview(Mat mat, PetscViewer v)
153: {
154: PetscCallFortranVoidFunction((*(void (*)(Mat *, PetscViewer *, PetscErrorCode *))(((PetscObject)mat)->fortran_func_pointers[FORTRAN_MATOP_VIEW]))(&mat, &v, &ierr));
155: return PETSC_SUCCESS;
156: }
158: static PetscErrorCode ourgetvecs(Mat mat, Vec *l, Vec *r)
159: {
160: Vec aa = (Vec)-1;
161: Vec *a = (!l ? &aa : l);
162: Vec *b = (!r ? &aa : r);
164: PetscCallFortranVoidFunction((*(void (*)(Mat *, Vec *, Vec *, PetscErrorCode *))(((PetscObject)mat)->fortran_func_pointers[FORTRAN_MATOP_CREATE_VECS]))(&mat, a, b, &ierr));
165: return PETSC_SUCCESS;
166: }
168: static PetscErrorCode ourgetdiagonalblock(Mat mat, Mat *l)
169: {
170: PetscCallFortranVoidFunction((*(void (*)(Mat *, Mat *, PetscErrorCode *))(((PetscObject)mat)->fortran_func_pointers[FORTRAN_MATOP_GET_DIAGONAL_BLOCK]))(&mat, l, &ierr));
171: return PETSC_SUCCESS;
172: }
174: static PetscErrorCode ourcopy(Mat mat, Mat B, MatStructure str)
175: {
176: PetscCallFortranVoidFunction((*(void (*)(Mat *, Mat *, MatStructure *, PetscErrorCode *))(((PetscObject)mat)->fortran_func_pointers[FORTRAN_MATOP_COPY]))(&mat, &B, &str, &ierr));
177: return PETSC_SUCCESS;
178: }
180: static PetscErrorCode ourscale(Mat mat, PetscScalar a)
181: {
182: PetscCallFortranVoidFunction((*(void (*)(Mat *, PetscScalar *, PetscErrorCode *))(((PetscObject)mat)->fortran_func_pointers[FORTRAN_MATOP_SCALE]))(&mat, &a, &ierr));
183: return PETSC_SUCCESS;
184: }
186: static PetscErrorCode oursetrandom(Mat mat, PetscRandom ctx)
187: {
188: PetscCallFortranVoidFunction((*(void (*)(Mat *, PetscRandom *, PetscErrorCode *))(((PetscObject)mat)->fortran_func_pointers[FORTRAN_MATOP_SET_RANDOM]))(&mat, &ctx, &ierr));
189: return PETSC_SUCCESS;
190: }
192: static PetscErrorCode ourassemblybegin(Mat mat, MatAssemblyType type)
193: {
194: PetscCallFortranVoidFunction((*(void (*)(Mat *, MatAssemblyType *, PetscErrorCode *))(((PetscObject)mat)->fortran_func_pointers[FORTRAN_MATOP_ASSEMBLY_BEGIN]))(&mat, &type, &ierr));
195: return PETSC_SUCCESS;
196: }
198: static PetscErrorCode ourassemblyend(Mat mat, MatAssemblyType type)
199: {
200: PetscCallFortranVoidFunction((*(void (*)(Mat *, MatAssemblyType *, PetscErrorCode *))(((PetscObject)mat)->fortran_func_pointers[FORTRAN_MATOP_ASSEMBLY_END]))(&mat, &type, &ierr));
201: return PETSC_SUCCESS;
202: }
204: static PetscErrorCode ourduplicate(Mat mat, MatDuplicateOption op, Mat *M)
205: {
206: PetscCallFortranVoidFunction((*(void (*)(Mat *, MatDuplicateOption *, Mat *, PetscErrorCode *))(((PetscObject)mat)->fortran_func_pointers[FORTRAN_MATOP_DUPLICATE]))(&mat, &op, M, &ierr));
207: return PETSC_SUCCESS;
208: }
210: PETSC_EXTERN void matshellsetoperation_(Mat *mat, MatOperation *op, PetscErrorCode (*f)(Mat *, Vec *, Vec *, PetscErrorCode *), PetscErrorCode *ierr)
211: {
212: MPI_Comm comm;
214: *ierr = PetscObjectGetComm((PetscObject)*mat, &comm);
215: if (*ierr) return;
216: PetscObjectAllocateFortranPointers(*mat, FORTRAN_MATOP_SIZE);
218: switch (*op) {
219: case MATOP_MULT:
220: *ierr = MatShellSetOperation(*mat, *op, (PetscVoidFn *)ourmult);
221: ((PetscObject)*mat)->fortran_func_pointers[FORTRAN_MATOP_MULT] = (PetscVoidFn *)f;
222: break;
223: case MATOP_MULT_ADD:
224: *ierr = MatShellSetOperation(*mat, *op, (PetscVoidFn *)ourmultadd);
225: ((PetscObject)*mat)->fortran_func_pointers[FORTRAN_MATOP_MULT_ADD] = (PetscVoidFn *)f;
226: break;
227: case MATOP_MULT_TRANSPOSE:
228: *ierr = MatShellSetOperation(*mat, *op, (PetscVoidFn *)ourmulttranspose);
229: ((PetscObject)*mat)->fortran_func_pointers[FORTRAN_MATOP_MULT_TRANSPOSE] = (PetscVoidFn *)f;
230: break;
231: case MATOP_MULT_HERMITIAN_TRANSPOSE:
232: *ierr = MatShellSetOperation(*mat, *op, (PetscVoidFn *)ourmulthermitiantranspose);
233: ((PetscObject)*mat)->fortran_func_pointers[FORTRAN_MATOP_MULT_HT] = (PetscVoidFn *)f;
234: break;
235: case MATOP_MULT_TRANSPOSE_ADD:
236: *ierr = MatShellSetOperation(*mat, *op, (PetscVoidFn *)ourmulttransposeadd);
237: ((PetscObject)*mat)->fortran_func_pointers[FORTRAN_MATOP_MULT_TRANSPOSE_ADD] = (PetscVoidFn *)f;
238: break;
239: case MATOP_MULT_HERMITIAN_TRANS_ADD:
240: *ierr = MatShellSetOperation(*mat, *op, (PetscVoidFn *)ourmulthermitiantransposeadd);
241: ((PetscObject)*mat)->fortran_func_pointers[FORTRAN_MATOP_MULT_HT_ADD] = (PetscVoidFn *)f;
242: break;
243: case MATOP_SOR:
244: *ierr = MatShellSetOperation(*mat, *op, (PetscVoidFn *)oursor);
245: ((PetscObject)*mat)->fortran_func_pointers[FORTRAN_MATOP_SOR] = (PetscVoidFn *)f;
246: break;
247: case MATOP_TRANSPOSE:
248: *ierr = MatShellSetOperation(*mat, *op, (PetscVoidFn *)ourtranspose);
249: ((PetscObject)*mat)->fortran_func_pointers[FORTRAN_MATOP_TRANSPOSE] = (PetscVoidFn *)f;
250: break;
251: case MATOP_GET_DIAGONAL:
252: *ierr = MatShellSetOperation(*mat, *op, (PetscVoidFn *)ourgetdiagonal);
253: ((PetscObject)*mat)->fortran_func_pointers[FORTRAN_MATOP_GET_DIAGONAL] = (PetscVoidFn *)f;
254: break;
255: case MATOP_DIAGONAL_SCALE:
256: *ierr = MatShellSetOperation(*mat, *op, (PetscVoidFn *)ourdiagonalscale);
257: ((PetscObject)*mat)->fortran_func_pointers[FORTRAN_MATOP_DIAGONAL_SCALE] = (PetscVoidFn *)f;
258: break;
259: case MATOP_ZERO_ENTRIES:
260: *ierr = MatShellSetOperation(*mat, *op, (PetscVoidFn *)ourzeroentries);
261: ((PetscObject)*mat)->fortran_func_pointers[FORTRAN_MATOP_ZERO_ENTRIES] = (PetscVoidFn *)f;
262: break;
263: case MATOP_AXPY:
264: *ierr = MatShellSetOperation(*mat, *op, (PetscVoidFn *)ouraxpy);
265: ((PetscObject)*mat)->fortran_func_pointers[FORTRAN_MATOP_AXPY] = (PetscVoidFn *)f;
266: break;
267: case MATOP_SHIFT:
268: *ierr = MatShellSetOperation(*mat, *op, (PetscVoidFn *)ourshift);
269: ((PetscObject)*mat)->fortran_func_pointers[FORTRAN_MATOP_SHIFT] = (PetscVoidFn *)f;
270: break;
271: case MATOP_DIAGONAL_SET:
272: *ierr = MatShellSetOperation(*mat, *op, (PetscVoidFn *)ourdiagonalset);
273: ((PetscObject)*mat)->fortran_func_pointers[FORTRAN_MATOP_DIAGONAL_SET] = (PetscVoidFn *)f;
274: break;
275: case MATOP_DESTROY:
276: *ierr = MatShellSetOperation(*mat, *op, (PetscVoidFn *)ourdestroy);
277: ((PetscObject)*mat)->fortran_func_pointers[FORTRAN_MATOP_DESTROY] = (PetscVoidFn *)f;
278: break;
279: case MATOP_VIEW:
280: *ierr = MatShellSetOperation(*mat, *op, (PetscVoidFn *)ourview);
281: ((PetscObject)*mat)->fortran_func_pointers[FORTRAN_MATOP_VIEW] = (PetscVoidFn *)f;
282: break;
283: case MATOP_CREATE_VECS:
284: *ierr = MatShellSetOperation(*mat, *op, (PetscVoidFn *)ourgetvecs);
285: ((PetscObject)*mat)->fortran_func_pointers[FORTRAN_MATOP_CREATE_VECS] = (PetscVoidFn *)f;
286: break;
287: case MATOP_GET_DIAGONAL_BLOCK:
288: *ierr = MatShellSetOperation(*mat, *op, (PetscVoidFn *)ourgetdiagonalblock);
289: ((PetscObject)*mat)->fortran_func_pointers[FORTRAN_MATOP_GET_DIAGONAL_BLOCK] = (PetscVoidFn *)f;
290: break;
291: case MATOP_COPY:
292: *ierr = MatShellSetOperation(*mat, *op, (PetscVoidFn *)ourcopy);
293: ((PetscObject)*mat)->fortran_func_pointers[FORTRAN_MATOP_COPY] = (PetscVoidFn *)f;
294: break;
295: case MATOP_SCALE:
296: *ierr = MatShellSetOperation(*mat, *op, (PetscVoidFn *)ourscale);
297: ((PetscObject)*mat)->fortran_func_pointers[FORTRAN_MATOP_SCALE] = (PetscVoidFn *)f;
298: break;
299: case MATOP_SET_RANDOM:
300: *ierr = MatShellSetOperation(*mat, *op, (PetscVoidFn *)oursetrandom);
301: ((PetscObject)*mat)->fortran_func_pointers[FORTRAN_MATOP_SET_RANDOM] = (PetscVoidFn *)f;
302: break;
303: case MATOP_ASSEMBLY_BEGIN:
304: *ierr = MatShellSetOperation(*mat, *op, (PetscVoidFn *)ourassemblybegin);
305: ((PetscObject)*mat)->fortran_func_pointers[FORTRAN_MATOP_ASSEMBLY_BEGIN] = (PetscVoidFn *)f;
306: break;
307: case MATOP_ASSEMBLY_END:
308: *ierr = MatShellSetOperation(*mat, *op, (PetscVoidFn *)ourassemblyend);
309: ((PetscObject)*mat)->fortran_func_pointers[FORTRAN_MATOP_ASSEMBLY_END] = (PetscVoidFn *)f;
310: break;
311: case MATOP_DUPLICATE:
312: *ierr = MatShellSetOperation(*mat, *op, (PetscVoidFn *)ourduplicate);
313: ((PetscObject)*mat)->fortran_func_pointers[FORTRAN_MATOP_DUPLICATE] = (PetscVoidFn *)f;
314: break;
315: default:
316: *ierr = PetscError(comm, __LINE__, "MatShellSetOperation_Fortran", __FILE__, PETSC_ERR_ARG_WRONG, PETSC_ERROR_INITIAL, "Cannot set that matrix operation");
317: *ierr = PETSC_ERR_ARG_WRONG;
318: }
319: }