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