Actual source code: ftnimpl.h
1: #pragma once
3: #include <petsc/private/petscimpl.h>
4: PETSC_INTERN PetscErrorCode PETScParseFortranArgs_Private(int *, char ***);
5: PETSC_EXTERN PetscErrorCode PetscMPIFortranDatatypeToC(MPI_Fint, MPI_Datatype *);
7: PETSC_EXTERN PetscErrorCode PetscScalarAddressToFortran(PetscObject, PetscInt, PetscScalar *, PetscScalar *, PetscInt, size_t *);
8: PETSC_EXTERN PetscErrorCode PetscScalarAddressFromFortran(PetscObject, PetscScalar *, size_t, PetscInt, PetscScalar **);
9: PETSC_EXTERN size_t PetscIntAddressToFortran(const PetscInt *, const PetscInt *);
10: PETSC_EXTERN PetscInt *PetscIntAddressFromFortran(const PetscInt *, size_t);
11: PETSC_EXTERN char *PETSC_NULL_CHARACTER_Fortran;
12: PETSC_EXTERN void *PETSC_NULL_INTEGER_Fortran;
13: PETSC_EXTERN void *PETSC_NULL_SCALAR_Fortran;
14: PETSC_EXTERN void *PETSC_NULL_DOUBLE_Fortran;
15: PETSC_EXTERN void *PETSC_NULL_REAL_Fortran;
16: PETSC_EXTERN void *PETSC_NULL_BOOL_Fortran;
17: PETSC_EXTERN void *PETSC_NULL_ENUM_Fortran;
18: PETSC_EXTERN void *PETSC_NULL_INTEGER_ARRAY_Fortran;
19: PETSC_EXTERN void *PETSC_NULL_SCALAR_ARRAY_Fortran;
20: PETSC_EXTERN void *PETSC_NULL_REAL_ARRAY_Fortran;
21: PETSC_EXTERN void *PETSC_NULL_MPI_COMM_Fortran;
22: PETSC_EXTERN void *PETSC_NULL_INTEGER_POINTER_Fortran;
23: PETSC_EXTERN void *PETSC_NULL_SCALAR_POINTER_Fortran;
24: PETSC_EXTERN void *PETSC_NULL_REAL_POINTER_Fortran;
25: PETSC_EXTERN void (*PETSC_NULL_FUNCTION_Fortran)(void);
27: PETSC_INTERN PetscErrorCode PetscInitFortran_Private(const char *, PetscInt);
29: /* ----------------------------------------------------------------------*/
30: /*
31: PETSc object C pointers are stored directly as
32: Fortran integer*4 or *8 depending on the size of pointers.
33: */
35: /* --------------------------------------------------------------------*/
36: /*
37: Since Fortran does not null terminate strings we need to insure the string is null terminated before passing it
38: to C. This may require a memory allocation which is then freed with FREECHAR().
39: */
40: #define FIXCHAR(a, n, b) \
41: do { \
42: if ((a) == PETSC_NULL_CHARACTER_Fortran) { \
43: (b) = PETSC_NULLPTR; \
44: (a) = PETSC_NULLPTR; \
45: } else { \
46: while (((n) > 0) && ((a)[(n) - 1] == ' ')) (n)--; \
47: *ierr = PetscMalloc1((n) + 1, &(b)); \
48: if (*ierr) return; \
49: *ierr = PetscMemcpy((b), (a), (n)); \
50: (b)[n] = '\0'; \
51: if (*ierr) return; \
52: } \
53: } while (0)
54: #define FREECHAR(a, b) \
55: do { \
56: if (a != b) *ierr = PetscFree(b); \
57: } while (0)
59: /*
60: Fortran expects any unneeded characters at the end of its strings to be filled with the blank character.
61: */
62: #define FIXRETURNCHAR(flg, a, n) \
63: do { \
64: if (flg) { \
65: PETSC_FORTRAN_CHARLEN_T __i; \
66: for (__i = 0; __i < n && a[__i] != 0; __i++) { }; \
67: for (; __i < n; __i++) a[__i] = ' '; \
68: } \
69: } while (0)
71: /*
72: The cast through PETSC_UINTPTR_T is so that compilers that warn about casting to/from void * to void(*)(void)
73: will not complain about these comparisons. It is not know if this works for all compilers
74: */
75: #define FORTRANNULLINTEGERPOINTER(a) (((void *)(PETSC_UINTPTR_T)a) == PETSC_NULL_INTEGER_POINTER_Fortran)
76: #define FORTRANNULLSCALARPOINTER(a) (((void *)(PETSC_UINTPTR_T)a) == PETSC_NULL_SCALAR_POINTER_Fortran)
77: #define FORTRANNULLREALPOINTER(a) (((void *)(PETSC_UINTPTR_T)a) == PETSC_NULL_REAL_POINTER_Fortran)
78: #define FORTRANNULLINTEGER(a) (((void *)(PETSC_UINTPTR_T)a) == PETSC_NULL_INTEGER_Fortran || ((void *)(PETSC_UINTPTR_T)a) == PETSC_NULL_INTEGER_ARRAY_Fortran)
79: #define FORTRANNULLSCALAR(a) (((void *)(PETSC_UINTPTR_T)a) == PETSC_NULL_SCALAR_Fortran || ((void *)(PETSC_UINTPTR_T)a) == PETSC_NULL_SCALAR_ARRAY_Fortran)
80: #define FORTRANNULLREAL(a) (((void *)(PETSC_UINTPTR_T)a) == PETSC_NULL_REAL_Fortran || ((void *)(PETSC_UINTPTR_T)a) == PETSC_NULL_REAL_ARRAY_Fortran)
81: #define FORTRANNULLDOUBLE(a) (((void *)(PETSC_UINTPTR_T)a) == PETSC_NULL_DOUBLE_Fortran)
82: #define FORTRANNULLBOOL(a) (((void *)(PETSC_UINTPTR_T)a) == PETSC_NULL_BOOL_Fortran)
83: #define FORTRANNULLENUM(a) ((((void *)(PETSC_UINTPTR_T)a) == PETSC_NULL_ENUM_Fortran) || (((void *)(PETSC_UINTPTR_T)a) == (void *)-50))
84: #define FORTRANNULLCHARACTER(a) (((void *)(PETSC_UINTPTR_T)a) == PETSC_NULL_CHARACTER_Fortran)
85: #define FORTRANNULLFUNCTION(a) (((void (*)(void))(PETSC_UINTPTR_T)a) == PETSC_NULL_FUNCTION_Fortran)
86: #define FORTRANNULLOBJECT(a) (*(void **)(PETSC_UINTPTR_T)a == (void *)0)
87: #define FORTRANNULLMPICOMM(a) (((void *)(PETSC_UINTPTR_T)a) == PETSC_NULL_MPI_COMM_Fortran)
89: /*
90: A Fortran object with a value of (void*) 0 is indicated in Fortran by PETSC_NULL_XXXX, it is passed to routines to indicate the argument value is not requested or provided
91: similar to how NULL is used with PETSc objects in C
93: A Fortran object with a value of (void*) PETSC_FORTRAN_TYPE_INITIALIZE (-2) is an object that was never created or was destroyed (see checkFortranTypeInitialize()).
95: A Fortran object with a value of (void*) -3 happens when a PETSc routine returns in one of its arguments a NULL object
96: (it cannot return a value of (void*) 0 because if later the returned variable is passed to a creation routine, it would think one has passed in a PETSC_NULL_XXX and error).
98: These three values are used because Fortran always uses pass by reference so one cannot pass a NULL address, only an address with special
99: values at the location.
100: */
102: #define CHKFORTRANNULL(a) \
103: do { \
104: if (FORTRANNULLINTEGER(a) || FORTRANNULLENUM(a) || FORTRANNULLDOUBLE(a) || FORTRANNULLSCALAR(a) || FORTRANNULLREAL(a) || FORTRANNULLBOOL(a) || FORTRANNULLFUNCTION(a) || FORTRANNULLCHARACTER(a) || FORTRANNULLMPICOMM(a)) { a = PETSC_NULLPTR; } \
105: } while (0)
107: #define CHKFORTRANNULLENUM(a) \
108: do { \
109: if (FORTRANNULLENUM(a)) { a = PETSC_NULLPTR; } \
110: } while (0)
112: #define CHKFORTRANNULLINTEGER(a) \
113: do { \
114: if (FORTRANNULLINTEGER(a) || FORTRANNULLENUM(a)) { \
115: a = PETSC_NULLPTR; \
116: } else if (FORTRANNULLDOUBLE(a) || FORTRANNULLSCALAR(a) || FORTRANNULLREAL(a) || FORTRANNULLBOOL(a) || FORTRANNULLFUNCTION(a) || FORTRANNULLCHARACTER(a) || FORTRANNULLMPICOMM(a)) { \
117: *ierr = PetscError(PETSC_COMM_SELF, __LINE__, PETSC_FUNCTION_NAME, __FILE__, PETSC_ERR_ARG_WRONG, PETSC_ERROR_INITIAL, "Use PETSC_NULL_INTEGER"); \
118: *ierr = PETSC_ERR_ARG_BADPTR; \
119: return; \
120: } \
121: } while (0)
123: #define CHKFORTRANNULLSCALAR(a) \
124: do { \
125: if (FORTRANNULLSCALAR(a)) { \
126: a = PETSC_NULLPTR; \
127: } else if (FORTRANNULLINTEGER(a) || FORTRANNULLDOUBLE(a) || FORTRANNULLREAL(a) || FORTRANNULLBOOL(a) || FORTRANNULLFUNCTION(a) || FORTRANNULLCHARACTER(a) || FORTRANNULLMPICOMM(a)) { \
128: *ierr = PetscError(PETSC_COMM_SELF, __LINE__, PETSC_FUNCTION_NAME, __FILE__, PETSC_ERR_ARG_WRONG, PETSC_ERROR_INITIAL, "Use PETSC_NULL_SCALAR"); \
129: *ierr = PETSC_ERR_ARG_BADPTR; \
130: return; \
131: } \
132: } while (0)
134: #define CHKFORTRANNULLDOUBLE(a) \
135: do { \
136: if (FORTRANNULLDOUBLE(a)) { \
137: a = PETSC_NULLPTR; \
138: } else if (FORTRANNULLINTEGER(a) || FORTRANNULLSCALAR(a) || FORTRANNULLREAL(a) || FORTRANNULLBOOL(a) || FORTRANNULLFUNCTION(a) || FORTRANNULLCHARACTER(a) || FORTRANNULLMPICOMM(a)) { \
139: *ierr = PetscError(PETSC_COMM_SELF, __LINE__, PETSC_FUNCTION_NAME, __FILE__, PETSC_ERR_ARG_WRONG, PETSC_ERROR_INITIAL, "Use PETSC_NULL_DOUBLE"); \
140: *ierr = PETSC_ERR_ARG_BADPTR; \
141: return; \
142: } \
143: } while (0)
145: #define CHKFORTRANNULLREAL(a) \
146: do { \
147: if (FORTRANNULLREAL(a)) { \
148: a = PETSC_NULLPTR; \
149: } else if (FORTRANNULLINTEGER(a) || FORTRANNULLDOUBLE(a) || FORTRANNULLSCALAR(a) || FORTRANNULLBOOL(a) || FORTRANNULLFUNCTION(a) || FORTRANNULLCHARACTER(a) || FORTRANNULLMPICOMM(a)) { \
150: *ierr = PetscError(PETSC_COMM_SELF, __LINE__, PETSC_FUNCTION_NAME, __FILE__, PETSC_ERR_ARG_WRONG, PETSC_ERROR_INITIAL, "Use PETSC_NULL_REAL"); \
151: *ierr = PETSC_ERR_ARG_BADPTR; \
152: return; \
153: } \
154: } while (0)
156: #define CHKFORTRANNULLOBJECT(a) \
157: do { \
158: if (!(*(void **)a)) { \
159: a = PETSC_NULLPTR; \
160: } else if (FORTRANNULLINTEGER(a) || FORTRANNULLDOUBLE(a) || FORTRANNULLSCALAR(a) || FORTRANNULLREAL(a) || FORTRANNULLBOOL(a) || FORTRANNULLFUNCTION(a) || FORTRANNULLCHARACTER(a) || FORTRANNULLMPICOMM(a)) { \
161: *ierr = PetscError(PETSC_COMM_SELF, __LINE__, PETSC_FUNCTION_NAME, __FILE__, PETSC_ERR_ARG_WRONG, PETSC_ERROR_INITIAL, "Use PETSC_NULL_XXX where XXX is the name of a particular object class"); \
162: *ierr = PETSC_ERR_ARG_BADPTR; \
163: return; \
164: } \
165: } while (0)
167: #define CHKFORTRANNULLBOOL(a) \
168: do { \
169: if (FORTRANNULLBOOL(a)) { \
170: a = PETSC_NULLPTR; \
171: } else if (FORTRANNULLSCALAR(a) || FORTRANNULLINTEGER(a) || FORTRANNULLDOUBLE(a) || FORTRANNULLSCALAR(a) || FORTRANNULLREAL(a) || FORTRANNULLFUNCTION(a) || FORTRANNULLCHARACTER(a) || FORTRANNULLMPICOMM(a)) { \
172: *ierr = PetscError(PETSC_COMM_SELF, __LINE__, PETSC_FUNCTION_NAME, __FILE__, PETSC_ERR_ARG_WRONG, PETSC_ERROR_INITIAL, "Use PETSC_NULL_BOOL"); \
173: *ierr = PETSC_ERR_ARG_BADPTR; \
174: return; \
175: } \
176: } while (0)
178: #define CHKFORTRANNULLFUNCTION(a) \
179: do { \
180: if (FORTRANNULLFUNCTION(a)) { \
181: a = PETSC_NULLPTR; \
182: } else if (FORTRANNULLOBJECT(a) || FORTRANNULLSCALAR(a) || FORTRANNULLDOUBLE(a) || FORTRANNULLREAL(a) || FORTRANNULLINTEGER(a) || FORTRANNULLBOOL(a) || FORTRANNULLCHARACTER(a) || FORTRANNULLMPICOMM(a)) { \
183: *ierr = PetscError(PETSC_COMM_SELF, __LINE__, PETSC_FUNCTION_NAME, __FILE__, PETSC_ERR_ARG_WRONG, PETSC_ERROR_INITIAL, "Use PETSC_NULL_FUNCTION"); \
184: *ierr = PETSC_ERR_ARG_BADPTR; \
185: return; \
186: } \
187: } while (0)
189: #define CHKFORTRANNULLMPICOMM(a) \
190: do { \
191: if (FORTRANNULLMPICOMM(a)) { \
192: a = PETSC_NULLPTR; \
193: } else if (FORTRANNULLINTEGER(a) || FORTRANNULLDOUBLE(a) || FORTRANNULLSCALAR(a) || FORTRANNULLREAL(a) || FORTRANNULLBOOL(a) || FORTRANNULLFUNCTION(a) || FORTRANNULLCHARACTER(a)) { \
194: *ierr = PetscError(PETSC_COMM_SELF, __LINE__, PETSC_FUNCTION_NAME, __FILE__, PETSC_ERR_ARG_WRONG, PETSC_ERROR_INITIAL, "Use PETSC_NULL_MPI_COMM"); \
195: *ierr = PETSC_ERR_ARG_BADPTR; \
196: return; \
197: } \
198: } while (0)
200: /* In the beginning of Fortran XxxCreate() ensure object is not NULL or already created */
201: #define PETSC_FORTRAN_OBJECT_CREATE(a) \
202: do { \
203: if (!(*(void **)a)) { \
204: *ierr = PetscError(PETSC_COMM_SELF, __LINE__, PETSC_FUNCTION_NAME, __FILE__, PETSC_ERR_ARG_WRONG, PETSC_ERROR_INITIAL, "Cannot create PETSC_NULL_XXX object"); \
205: *ierr = PETSC_ERR_ARG_WRONG; \
206: return; \
207: } else if (*((void **)(a)) != (void *)-2 && *((void **)(a)) != (void *)-3) { \
208: *ierr = PetscError(PETSC_COMM_SELF, __LINE__, PETSC_FUNCTION_NAME, __FILE__, PETSC_ERR_ARG_WRONG, PETSC_ERROR_INITIAL, "Cannot create already existing object"); \
209: *ierr = PETSC_ERR_ARG_WRONG; \
210: return; \
211: } \
212: } while (0)
214: /*
215: In the beginning of Fortran XxxDestroy(a), if the input object was destroyed, change it to a PETSc C NULL object so that it won't crash C XxxDestory()
216: If it is PETSC_NULL_XXX just return since these objects cannot be destroyed
217: */
218: #define PETSC_FORTRAN_OBJECT_F_DESTROYED_TO_C_NULL(a) \
219: do { \
220: if (!*(void **)a || *((void **)(a)) == (void *)-2 || *((void **)(a)) == (void *)-3) { \
221: *ierr = PETSC_SUCCESS; \
222: return; \
223: } \
224: } while (0)
226: /* After C XxxDestroy(a) is called, change a's state from NULL to destroyed, so that it can be used/destroyed again by Fortran.
227: E.g., in VecScatterCreateToAll(x,vscat,seq,ierr), if seq = PETSC_NULL_VEC, PETSc won't create seq. But if seq is a
228: destroyed object (e.g., as a result of a previous Fortran VecDestroy), PETSc will create seq.
229: */
230: #define PETSC_FORTRAN_OBJECT_C_NULL_TO_F_DESTROYED(a) \
231: do { \
232: *((void **)(a)) = (void *)-2; \
233: } while (0)
235: /*
236: Variable type where we stash PETSc object pointers in Fortran.
237: */
238: typedef PETSC_UINTPTR_T PetscFortranAddr;
240: /*
241: These are used to support the default viewers that are
242: created at run time, in C using the , trick.
244: The numbers here must match the numbers in include/petsc/finclude/petscsys.h
245: */
246: #define PETSC_VIEWER_DRAW_WORLD_FORTRAN 4
247: #define PETSC_VIEWER_DRAW_SELF_FORTRAN 5
248: #define PETSC_VIEWER_SOCKET_WORLD_FORTRAN 6
249: #define PETSC_VIEWER_SOCKET_SELF_FORTRAN 7
250: #define PETSC_VIEWER_STDOUT_WORLD_FORTRAN 8
251: #define PETSC_VIEWER_STDOUT_SELF_FORTRAN 9
252: #define PETSC_VIEWER_STDERR_WORLD_FORTRAN 10
253: #define PETSC_VIEWER_STDERR_SELF_FORTRAN 11
254: #define PETSC_VIEWER_BINARY_WORLD_FORTRAN 12
255: #define PETSC_VIEWER_BINARY_SELF_FORTRAN 13
256: #define PETSC_VIEWER_MATLAB_WORLD_FORTRAN 14
257: #define PETSC_VIEWER_MATLAB_SELF_FORTRAN 15
259: #include <petscviewer.h>
261: static inline PetscViewer PetscPatchDefaultViewers(PetscViewer *v)
262: {
263: if (!v) return PETSC_NULLPTR;
264: if (!(*(void **)v)) return PETSC_NULLPTR;
265: switch (*(PetscFortranAddr *)v) {
266: case PETSC_VIEWER_DRAW_WORLD_FORTRAN:
267: return PETSC_VIEWER_DRAW_WORLD;
268: case PETSC_VIEWER_DRAW_SELF_FORTRAN:
269: return PETSC_VIEWER_DRAW_SELF;
271: case PETSC_VIEWER_STDOUT_WORLD_FORTRAN:
272: return PETSC_VIEWER_STDOUT_WORLD;
273: case PETSC_VIEWER_STDOUT_SELF_FORTRAN:
274: return PETSC_VIEWER_STDOUT_SELF;
276: case PETSC_VIEWER_STDERR_WORLD_FORTRAN:
277: return PETSC_VIEWER_STDERR_WORLD;
278: case PETSC_VIEWER_STDERR_SELF_FORTRAN:
279: return PETSC_VIEWER_STDERR_SELF;
281: case PETSC_VIEWER_BINARY_WORLD_FORTRAN:
282: return PETSC_VIEWER_BINARY_WORLD;
283: case PETSC_VIEWER_BINARY_SELF_FORTRAN:
284: return PETSC_VIEWER_BINARY_SELF;
286: #if defined(PETSC_HAVE_MATLAB)
287: case PETSC_VIEWER_MATLAB_SELF_FORTRAN:
288: return PETSC_VIEWER_MATLAB_SELF;
289: case PETSC_VIEWER_MATLAB_WORLD_FORTRAN:
290: return PETSC_VIEWER_MATLAB_WORLD;
291: #endif
293: #if defined(PETSC_USE_SOCKET_VIEWER)
294: case PETSC_VIEWER_SOCKET_WORLD_FORTRAN:
295: return PETSC_VIEWER_SOCKET_WORLD;
296: case PETSC_VIEWER_SOCKET_SELF_FORTRAN:
297: return PETSC_VIEWER_SOCKET_SELF;
298: #endif
300: default:
301: return *v;
302: }
303: }
305: #if defined(PETSC_USE_SOCKET_VIEWER)
306: #define PetscPatchDefaultViewers_Fortran_Socket(vin, v) \
307: } \
308: else if ((*(PetscFortranAddr *)vin) == PETSC_VIEWER_SOCKET_WORLD_FORTRAN) \
309: { \
310: v = PETSC_VIEWER_SOCKET_WORLD; \
311: } \
312: else if ((*(PetscFortranAddr *)vin) == PETSC_VIEWER_SOCKET_SELF_FORTRAN) \
313: { \
314: v = PETSC_VIEWER_SOCKET_SELF
315: #else
316: #define PetscPatchDefaultViewers_Fortran_Socket(vin, v)
317: #endif
319: #define PetscPatchDefaultViewers_Fortran(vin, v) \
320: do { \
321: if ((*(PetscFortranAddr *)vin) == PETSC_VIEWER_DRAW_WORLD_FORTRAN) { \
322: v = PETSC_VIEWER_DRAW_WORLD; \
323: } else if ((*(PetscFortranAddr *)vin) == PETSC_VIEWER_DRAW_SELF_FORTRAN) { \
324: v = PETSC_VIEWER_DRAW_SELF; \
325: } else if ((*(PetscFortranAddr *)vin) == PETSC_VIEWER_STDOUT_WORLD_FORTRAN) { \
326: v = PETSC_VIEWER_STDOUT_WORLD; \
327: } else if ((*(PetscFortranAddr *)vin) == PETSC_VIEWER_STDOUT_SELF_FORTRAN) { \
328: v = PETSC_VIEWER_STDOUT_SELF; \
329: } else if ((*(PetscFortranAddr *)vin) == PETSC_VIEWER_STDERR_WORLD_FORTRAN) { \
330: v = PETSC_VIEWER_STDERR_WORLD; \
331: } else if ((*(PetscFortranAddr *)vin) == PETSC_VIEWER_STDERR_SELF_FORTRAN) { \
332: v = PETSC_VIEWER_STDERR_SELF; \
333: } else if ((*(PetscFortranAddr *)vin) == PETSC_VIEWER_BINARY_WORLD_FORTRAN) { \
334: v = PETSC_VIEWER_BINARY_WORLD; \
335: } else if ((*(PetscFortranAddr *)vin) == PETSC_VIEWER_BINARY_SELF_FORTRAN) { \
336: v = PETSC_VIEWER_BINARY_SELF; \
337: } else if ((*(PetscFortranAddr *)vin) == PETSC_VIEWER_MATLAB_WORLD_FORTRAN) { \
338: v = PETSC_VIEWER_BINARY_WORLD; \
339: } else if ((*(PetscFortranAddr *)vin) == PETSC_VIEWER_MATLAB_SELF_FORTRAN) { \
340: v = PETSC_VIEWER_BINARY_SELF; \
341: PetscPatchDefaultViewers_Fortran_Socket(vin, v); \
342: } else { \
343: v = *vin; \
344: } \
345: } while (0)
347: /*
348: Allocates enough space to store Fortran function pointers in PETSc object
349: that are needed by the Fortran interface.
350: */
351: #define PetscObjectAllocateFortranPointers(obj, N) \
352: do { \
353: if (!((PetscObject)(obj))->fortran_func_pointers) { \
354: *ierr = PetscCalloc((N) * sizeof(void (*)(void)), &((PetscObject)(obj))->fortran_func_pointers); \
355: if (*ierr) return; \
356: ((PetscObject)obj)->num_fortran_func_pointers = (N); \
357: } \
358: } while (0)
360: #define PetscCallFortranVoidFunction(...) \
361: do { \
362: PetscErrorCode ierr = PETSC_SUCCESS; \
363: /* the function may or may not access ierr */ \
364: __VA_ARGS__; \
365: PetscCall(ierr); \
366: } while (0)
368: /* Entire function body, _ctx is a "special" variable that can be passed along */
369: #define PetscObjectUseFortranCallback_Private(obj, cid, types, args, cbclass) \
370: do { \
371: void(*func) types, *_ctx; \
372: PetscFunctionBegin; \
373: PetscCall(PetscObjectGetFortranCallback((PetscObject)(obj), (cbclass), (cid), (PetscVoidFn **)&func, &_ctx)); \
374: if (func) PetscCallFortranVoidFunction((*func)args); \
375: PetscFunctionReturn(PETSC_SUCCESS); \
376: } while (0)
377: #define PetscObjectUseFortranCallback(obj, cid, types, args) PetscObjectUseFortranCallback_Private(obj, cid, types, args, PETSC_FORTRAN_CALLBACK_CLASS)
378: #define PetscObjectUseFortranCallbackSubType(obj, cid, types, args) PetscObjectUseFortranCallback_Private(obj, cid, types, args, PETSC_FORTRAN_CALLBACK_SUBTYPE)
380: /* Disable deprecation warnings while building Fortran wrappers */
381: #undef PETSC_DEPRECATED_OBJECT
382: #define PETSC_DEPRECATED_OBJECT(...)
383: #undef PETSC_DEPRECATED_FUNCTION
384: #define PETSC_DEPRECATED_FUNCTION(...)
385: #undef PETSC_DEPRECATED_ENUM
386: #define PETSC_DEPRECATED_ENUM(...)
387: #undef PETSC_DEPRECATED_TYPEDEF
388: #define PETSC_DEPRECATED_TYPEDEF(...)
389: #undef PETSC_DEPRECATED_MACRO
390: #define PETSC_DEPRECATED_MACRO(...)
392: /* PGI compilers pass in f90 pointers as 2 arguments */
393: #if defined(PETSC_HAVE_F90_2PTR_ARG)
394: #define PETSC_F90_2PTR_PROTO_NOVAR , void *
395: #define PETSC_F90_2PTR_PROTO(ptr) , void *ptr
396: #define PETSC_F90_2PTR_PARAM(ptr) , ptr
397: #else
398: #define PETSC_F90_2PTR_PROTO_NOVAR
399: #define PETSC_F90_2PTR_PROTO(ptr)
400: #define PETSC_F90_2PTR_PARAM(ptr)
401: #endif
403: typedef struct {
404: char dummy;
405: } F90Array1d;
406: typedef struct {
407: char dummy;
408: } F90Array2d;
409: typedef struct {
410: char dummy;
411: } F90Array3d;
412: typedef struct {
413: char dummy;
414: } F90Array4d;
416: PETSC_EXTERN PetscErrorCode F90Array1dCreate(void *, MPI_Datatype, PetscInt, PetscInt, F90Array1d *PETSC_F90_2PTR_PROTO_NOVAR);
417: PETSC_EXTERN PetscErrorCode F90Array1dAccess(F90Array1d *, MPI_Datatype, void **PETSC_F90_2PTR_PROTO_NOVAR);
418: PETSC_EXTERN PetscErrorCode F90Array1dDestroy(F90Array1d *, MPI_Datatype PETSC_F90_2PTR_PROTO_NOVAR);
420: PETSC_EXTERN PetscErrorCode F90Array2dCreate(void *, MPI_Datatype, PetscInt, PetscInt, PetscInt, PetscInt, F90Array2d *PETSC_F90_2PTR_PROTO_NOVAR);
421: PETSC_EXTERN PetscErrorCode F90Array2dAccess(F90Array2d *, MPI_Datatype, void **PETSC_F90_2PTR_PROTO_NOVAR);
422: PETSC_EXTERN PetscErrorCode F90Array2dDestroy(F90Array2d *, MPI_Datatype PETSC_F90_2PTR_PROTO_NOVAR);
424: PETSC_EXTERN PetscErrorCode F90Array3dCreate(void *, MPI_Datatype, PetscInt, PetscInt, PetscInt, PetscInt, PetscInt, PetscInt, F90Array3d *PETSC_F90_2PTR_PROTO_NOVAR);
425: PETSC_EXTERN PetscErrorCode F90Array3dAccess(F90Array3d *, MPI_Datatype, void **PETSC_F90_2PTR_PROTO_NOVAR);
426: PETSC_EXTERN PetscErrorCode F90Array3dDestroy(F90Array3d *, MPI_Datatype PETSC_F90_2PTR_PROTO_NOVAR);
428: PETSC_EXTERN PetscErrorCode F90Array4dCreate(void *, MPI_Datatype, PetscInt, PetscInt, PetscInt, PetscInt, PetscInt, PetscInt, PetscInt, PetscInt, F90Array4d *PETSC_F90_2PTR_PROTO_NOVAR);
429: PETSC_EXTERN PetscErrorCode F90Array4dAccess(F90Array4d *, MPI_Datatype, void **PETSC_F90_2PTR_PROTO_NOVAR);
430: PETSC_EXTERN PetscErrorCode F90Array4dDestroy(F90Array4d *, MPI_Datatype PETSC_F90_2PTR_PROTO_NOVAR);
432: /*
433: F90Array1dCreate - Given a C pointer to a one dimensional
434: array and its length; this fills in the appropriate Fortran 90
435: pointer data structure.
437: Input Parameters:
438: + array - regular C pointer (address)
439: . type - DataType of the array
440: . start - starting index of the array
441: - len - length of array (in items)
443: Output Parameter:
444: . ptr - Fortran 90 pointer
445: */