1 #pragma once
2
3 #include <petsc/private/petscimpl.h>
4 PETSC_INTERN PetscErrorCode PETScParseFortranArgs_Private(int *, char ***);
5 PETSC_EXTERN PetscErrorCode PetscMPIFortranDatatypeToC(MPI_Fint, MPI_Datatype *);
6
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 PetscFortranCallbackFn *PETSC_NULL_FUNCTION_Fortran;
26
27 PETSC_INTERN PetscErrorCode PetscInitFortran_Private(const char *, PetscInt);
28
29 /* ----------------------------------------------------------------------*/
30 /*
31 PETSc object C pointers are stored directly as
32 Fortran integer*4 or *8 depending on the size of pointers.
33 */
34
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)
58
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)
70
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) (((PetscFortranCallbackFn *)(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)
88
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
92
93 A Fortran object with a value of (void*) PETSC_FORTRAN_TYPE_INITIALIZE is an object that was never created or was destroyed (see checkFortranTypeInitialize()).
94
95 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
96 (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).
97
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
101 PETSC_FORTRAN_TYPE_INITIALIZE is also defined in include/petsc/finclude/petscsysbase.h
102 */
103 #define PETSC_FORTRAN_TYPE_INITIALIZE (void *)-2
104 #define PETSC_FORTRAN_TYPE_NULL_RETURN (void *)-3
105
106 #define CHKFORTRANNULL(a) \
107 do { \
108 if (FORTRANNULLINTEGER(a) || FORTRANNULLENUM(a) || FORTRANNULLDOUBLE(a) || FORTRANNULLSCALAR(a) || FORTRANNULLREAL(a) || FORTRANNULLBOOL(a) || FORTRANNULLFUNCTION(a) || FORTRANNULLCHARACTER(a) || FORTRANNULLMPICOMM(a)) a = PETSC_NULLPTR; \
109 } while (0)
110
111 #define CHKFORTRANNULLENUM(a) \
112 do { \
113 if (FORTRANNULLENUM(a)) a = PETSC_NULLPTR; \
114 } while (0)
115
116 #define CHKFORTRANNULLINTEGER(a) \
117 do { \
118 if (FORTRANNULLINTEGER(a) || FORTRANNULLENUM(a)) a = PETSC_NULLPTR; \
119 else if (FORTRANNULLDOUBLE(a) || FORTRANNULLSCALAR(a) || FORTRANNULLREAL(a) || FORTRANNULLBOOL(a) || FORTRANNULLFUNCTION(a) || FORTRANNULLCHARACTER(a) || FORTRANNULLMPICOMM(a)) { \
120 *ierr = PetscError(PETSC_COMM_SELF, __LINE__, PETSC_FUNCTION_NAME, __FILE__, PETSC_ERR_ARG_WRONG, PETSC_ERROR_INITIAL, "Use PETSC_NULL_INTEGER"); \
121 *ierr = PETSC_ERR_ARG_BADPTR; \
122 return; \
123 } \
124 } while (0)
125
126 #define CHKFORTRANNULLSCALAR(a) \
127 do { \
128 if (FORTRANNULLSCALAR(a)) { \
129 a = PETSC_NULLPTR; \
130 } else if (FORTRANNULLINTEGER(a) || FORTRANNULLDOUBLE(a) || FORTRANNULLREAL(a) || FORTRANNULLBOOL(a) || FORTRANNULLFUNCTION(a) || FORTRANNULLCHARACTER(a) || FORTRANNULLMPICOMM(a)) { \
131 *ierr = PetscError(PETSC_COMM_SELF, __LINE__, PETSC_FUNCTION_NAME, __FILE__, PETSC_ERR_ARG_WRONG, PETSC_ERROR_INITIAL, "Use PETSC_NULL_SCALAR"); \
132 *ierr = PETSC_ERR_ARG_BADPTR; \
133 return; \
134 } \
135 } while (0)
136
137 #define CHKFORTRANNULLDOUBLE(a) \
138 do { \
139 if (FORTRANNULLDOUBLE(a)) { \
140 a = PETSC_NULLPTR; \
141 } else if (FORTRANNULLINTEGER(a) || FORTRANNULLSCALAR(a) || FORTRANNULLREAL(a) || FORTRANNULLBOOL(a) || FORTRANNULLFUNCTION(a) || FORTRANNULLCHARACTER(a) || FORTRANNULLMPICOMM(a)) { \
142 *ierr = PetscError(PETSC_COMM_SELF, __LINE__, PETSC_FUNCTION_NAME, __FILE__, PETSC_ERR_ARG_WRONG, PETSC_ERROR_INITIAL, "Use PETSC_NULL_DOUBLE"); \
143 *ierr = PETSC_ERR_ARG_BADPTR; \
144 return; \
145 } \
146 } while (0)
147
148 #define CHKFORTRANNULLREAL(a) \
149 do { \
150 if (FORTRANNULLREAL(a)) { \
151 a = PETSC_NULLPTR; \
152 } else if (FORTRANNULLINTEGER(a) || FORTRANNULLDOUBLE(a) || FORTRANNULLSCALAR(a) || FORTRANNULLBOOL(a) || FORTRANNULLFUNCTION(a) || FORTRANNULLCHARACTER(a) || FORTRANNULLMPICOMM(a)) { \
153 *ierr = PetscError(PETSC_COMM_SELF, __LINE__, PETSC_FUNCTION_NAME, __FILE__, PETSC_ERR_ARG_WRONG, PETSC_ERROR_INITIAL, "Use PETSC_NULL_REAL"); \
154 *ierr = PETSC_ERR_ARG_BADPTR; \
155 return; \
156 } \
157 } while (0)
158
159 #define CHKFORTRANNULLOBJECT(a) \
160 do { \
161 if (!(*(void **)a)) { \
162 a = PETSC_NULLPTR; \
163 } else if (FORTRANNULLINTEGER(a) || FORTRANNULLDOUBLE(a) || FORTRANNULLSCALAR(a) || FORTRANNULLREAL(a) || FORTRANNULLBOOL(a) || FORTRANNULLFUNCTION(a) || FORTRANNULLCHARACTER(a) || FORTRANNULLMPICOMM(a)) { \
164 *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"); \
165 *ierr = PETSC_ERR_ARG_BADPTR; \
166 return; \
167 } \
168 } while (0)
169
170 #define CHKFORTRANNULLBOOL(a) \
171 do { \
172 if (FORTRANNULLBOOL(a)) { \
173 a = PETSC_NULLPTR; \
174 } else if (FORTRANNULLSCALAR(a) || FORTRANNULLINTEGER(a) || FORTRANNULLDOUBLE(a) || FORTRANNULLSCALAR(a) || FORTRANNULLREAL(a) || FORTRANNULLFUNCTION(a) || FORTRANNULLCHARACTER(a) || FORTRANNULLMPICOMM(a)) { \
175 *ierr = PetscError(PETSC_COMM_SELF, __LINE__, PETSC_FUNCTION_NAME, __FILE__, PETSC_ERR_ARG_WRONG, PETSC_ERROR_INITIAL, "Use PETSC_NULL_BOOL"); \
176 *ierr = PETSC_ERR_ARG_BADPTR; \
177 return; \
178 } \
179 } while (0)
180
181 #define CHKFORTRANNULLFUNCTION(a) \
182 do { \
183 if (FORTRANNULLFUNCTION(a)) { \
184 a = PETSC_NULLPTR; \
185 } else if (FORTRANNULLOBJECT(a) || FORTRANNULLSCALAR(a) || FORTRANNULLDOUBLE(a) || FORTRANNULLREAL(a) || FORTRANNULLINTEGER(a) || FORTRANNULLBOOL(a) || FORTRANNULLCHARACTER(a) || FORTRANNULLMPICOMM(a)) { \
186 *ierr = PetscError(PETSC_COMM_SELF, __LINE__, PETSC_FUNCTION_NAME, __FILE__, PETSC_ERR_ARG_WRONG, PETSC_ERROR_INITIAL, "Use PETSC_NULL_FUNCTION"); \
187 *ierr = PETSC_ERR_ARG_BADPTR; \
188 return; \
189 } \
190 } while (0)
191
192 #define CHKFORTRANNULLMPICOMM(a) \
193 do { \
194 if (FORTRANNULLMPICOMM(a)) { \
195 a = PETSC_NULLPTR; \
196 } else if (FORTRANNULLINTEGER(a) || FORTRANNULLDOUBLE(a) || FORTRANNULLSCALAR(a) || FORTRANNULLREAL(a) || FORTRANNULLBOOL(a) || FORTRANNULLFUNCTION(a) || FORTRANNULLCHARACTER(a)) { \
197 *ierr = PetscError(PETSC_COMM_SELF, __LINE__, PETSC_FUNCTION_NAME, __FILE__, PETSC_ERR_ARG_WRONG, PETSC_ERROR_INITIAL, "Use PETSC_NULL_MPI_COMM"); \
198 *ierr = PETSC_ERR_ARG_BADPTR; \
199 return; \
200 } \
201 } while (0)
202
203 /* In the beginning of Fortran XxxCreate() ensure object is not NULL or already created */
204 #define PETSC_FORTRAN_OBJECT_CREATE(a) \
205 do { \
206 if (!(*(void **)a)) { \
207 *ierr = PetscError(PETSC_COMM_SELF, __LINE__, PETSC_FUNCTION_NAME, __FILE__, PETSC_ERR_ARG_WRONG, PETSC_ERROR_INITIAL, "Cannot create PETSC_NULL_XXX object"); \
208 *ierr = PETSC_ERR_ARG_WRONG; \
209 return; \
210 } else if (*((void **)(a)) != PETSC_FORTRAN_TYPE_INITIALIZE && *((void **)(a)) != PETSC_FORTRAN_TYPE_NULL_RETURN) { \
211 *ierr = PetscError(PETSC_COMM_SELF, __LINE__, PETSC_FUNCTION_NAME, __FILE__, PETSC_ERR_ARG_WRONG, PETSC_ERROR_INITIAL, "Cannot create already existing object"); \
212 *ierr = PETSC_ERR_ARG_WRONG; \
213 return; \
214 } \
215 } while (0)
216
217 /*
218 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()
219 If it is PETSC_NULL_XXX just return since these objects cannot be destroyed
220 */
221 #define PETSC_FORTRAN_OBJECT_F_DESTROYED_TO_C_NULL(a) \
222 do { \
223 if (!*(void **)a || *((void **)(a)) == PETSC_FORTRAN_TYPE_INITIALIZE || *((void **)(a)) == PETSC_FORTRAN_TYPE_NULL_RETURN) { \
224 *ierr = PETSC_SUCCESS; \
225 return; \
226 } \
227 } while (0)
228
229 /* After C XxxDestroy(a) is called, change a's state from NULL to destroyed, so that it can be used/destroyed again by Fortran.
230 E.g., in VecScatterCreateToAll(x,vscat,seq,ierr), if seq = PETSC_NULL_VEC, PETSc won't create seq. But if seq is a
231 destroyed object (e.g., as a result of a previous Fortran VecDestroy), PETSc will create seq.
232 */
233 #define PETSC_FORTRAN_OBJECT_C_NULL_TO_F_DESTROYED(a) \
234 do { \
235 *((void **)(a)) = PETSC_FORTRAN_TYPE_INITIALIZE; \
236 } while (0)
237
238 /*
239 Variable type where we stash PETSc object pointers in Fortran.
240 */
241 typedef PETSC_UINTPTR_T PetscFortranAddr;
242
243 /*
244 These are used to support the default viewers that are
245 created at run time, in C using the , trick.
246
247 The numbers here must match the numbers in include/petsc/finclude/petscsys.h
248 */
249 #define PETSC_VIEWER_DRAW_WORLD_FORTRAN 4
250 #define PETSC_VIEWER_DRAW_SELF_FORTRAN 5
251 #define PETSC_VIEWER_SOCKET_WORLD_FORTRAN 6
252 #define PETSC_VIEWER_SOCKET_SELF_FORTRAN 7
253 #define PETSC_VIEWER_STDOUT_WORLD_FORTRAN 8
254 #define PETSC_VIEWER_STDOUT_SELF_FORTRAN 9
255 #define PETSC_VIEWER_STDERR_WORLD_FORTRAN 10
256 #define PETSC_VIEWER_STDERR_SELF_FORTRAN 11
257 #define PETSC_VIEWER_BINARY_WORLD_FORTRAN 12
258 #define PETSC_VIEWER_BINARY_SELF_FORTRAN 13
259 #define PETSC_VIEWER_MATLAB_WORLD_FORTRAN 14
260 #define PETSC_VIEWER_MATLAB_SELF_FORTRAN 15
261
262 #include <petscviewer.h>
263
PetscPatchDefaultViewers(PetscViewer * v)264 static inline PetscViewer PetscPatchDefaultViewers(PetscViewer *v)
265 {
266 if (!v) return PETSC_NULLPTR;
267 if (!(*(void **)v)) return PETSC_NULLPTR;
268 switch (*(PetscFortranAddr *)v) {
269 case PETSC_VIEWER_DRAW_WORLD_FORTRAN:
270 return PETSC_VIEWER_DRAW_WORLD;
271 case PETSC_VIEWER_DRAW_SELF_FORTRAN:
272 return PETSC_VIEWER_DRAW_SELF;
273
274 case PETSC_VIEWER_STDOUT_WORLD_FORTRAN:
275 return PETSC_VIEWER_STDOUT_WORLD;
276 case PETSC_VIEWER_STDOUT_SELF_FORTRAN:
277 return PETSC_VIEWER_STDOUT_SELF;
278
279 case PETSC_VIEWER_STDERR_WORLD_FORTRAN:
280 return PETSC_VIEWER_STDERR_WORLD;
281 case PETSC_VIEWER_STDERR_SELF_FORTRAN:
282 return PETSC_VIEWER_STDERR_SELF;
283
284 case PETSC_VIEWER_BINARY_WORLD_FORTRAN:
285 return PETSC_VIEWER_BINARY_WORLD;
286 case PETSC_VIEWER_BINARY_SELF_FORTRAN:
287 return PETSC_VIEWER_BINARY_SELF;
288
289 #if defined(PETSC_HAVE_MATLAB)
290 case PETSC_VIEWER_MATLAB_SELF_FORTRAN:
291 return PETSC_VIEWER_MATLAB_SELF;
292 case PETSC_VIEWER_MATLAB_WORLD_FORTRAN:
293 return PETSC_VIEWER_MATLAB_WORLD;
294 #endif
295
296 #if defined(PETSC_USE_SOCKET_VIEWER)
297 case PETSC_VIEWER_SOCKET_WORLD_FORTRAN:
298 return PETSC_VIEWER_SOCKET_WORLD;
299 case PETSC_VIEWER_SOCKET_SELF_FORTRAN:
300 return PETSC_VIEWER_SOCKET_SELF;
301 #endif
302
303 default:
304 return *v;
305 }
306 }
307
308 #if defined(PETSC_USE_SOCKET_VIEWER)
309 #define PetscPatchDefaultViewers_Fortran_Socket(vin, v) \
310 } \
311 else if ((*(PetscFortranAddr *)vin) == PETSC_VIEWER_SOCKET_WORLD_FORTRAN) \
312 { \
313 v = PETSC_VIEWER_SOCKET_WORLD; \
314 } \
315 else if ((*(PetscFortranAddr *)vin) == PETSC_VIEWER_SOCKET_SELF_FORTRAN) \
316 { \
317 v = PETSC_VIEWER_SOCKET_SELF
318 #else
319 #define PetscPatchDefaultViewers_Fortran_Socket(vin, v)
320 #endif
321
322 #define PetscPatchDefaultViewers_Fortran(vin, v) \
323 do { \
324 if ((*(PetscFortranAddr *)vin) == PETSC_VIEWER_DRAW_WORLD_FORTRAN) { \
325 v = PETSC_VIEWER_DRAW_WORLD; \
326 } else if ((*(PetscFortranAddr *)vin) == PETSC_VIEWER_DRAW_SELF_FORTRAN) { \
327 v = PETSC_VIEWER_DRAW_SELF; \
328 } else if ((*(PetscFortranAddr *)vin) == PETSC_VIEWER_STDOUT_WORLD_FORTRAN) { \
329 v = PETSC_VIEWER_STDOUT_WORLD; \
330 } else if ((*(PetscFortranAddr *)vin) == PETSC_VIEWER_STDOUT_SELF_FORTRAN) { \
331 v = PETSC_VIEWER_STDOUT_SELF; \
332 } else if ((*(PetscFortranAddr *)vin) == PETSC_VIEWER_STDERR_WORLD_FORTRAN) { \
333 v = PETSC_VIEWER_STDERR_WORLD; \
334 } else if ((*(PetscFortranAddr *)vin) == PETSC_VIEWER_STDERR_SELF_FORTRAN) { \
335 v = PETSC_VIEWER_STDERR_SELF; \
336 } else if ((*(PetscFortranAddr *)vin) == PETSC_VIEWER_BINARY_WORLD_FORTRAN) { \
337 v = PETSC_VIEWER_BINARY_WORLD; \
338 } else if ((*(PetscFortranAddr *)vin) == PETSC_VIEWER_BINARY_SELF_FORTRAN) { \
339 v = PETSC_VIEWER_BINARY_SELF; \
340 } else if ((*(PetscFortranAddr *)vin) == PETSC_VIEWER_MATLAB_WORLD_FORTRAN) { \
341 v = PETSC_VIEWER_BINARY_WORLD; \
342 } else if ((*(PetscFortranAddr *)vin) == PETSC_VIEWER_MATLAB_SELF_FORTRAN) { \
343 v = PETSC_VIEWER_BINARY_SELF; \
344 PetscPatchDefaultViewers_Fortran_Socket(vin, v); \
345 } else { \
346 v = *vin; \
347 } \
348 } while (0)
349
350 /*
351 Allocates enough space to store Fortran function pointers in PETSc object
352 that are needed by the Fortran interface.
353 */
354 #define PetscObjectAllocateFortranPointers(obj, N) \
355 do { \
356 if (!((PetscObject)(obj))->fortran_func_pointers) { \
357 *ierr = PetscCalloc((N) * sizeof(PetscFortranCallbackFn *), &((PetscObject)(obj))->fortran_func_pointers); \
358 if (*ierr) return; \
359 ((PetscObject)obj)->num_fortran_func_pointers = (N); \
360 } \
361 } while (0)
362
363 #define PetscCallFortranVoidFunction(...) \
364 do { \
365 PetscErrorCode ierr = PETSC_SUCCESS; \
366 /* the function may or may not access ierr */ \
367 __VA_ARGS__; \
368 PetscCall(ierr); \
369 } while (0)
370
371 /* Entire function body, _ctx is a "special" variable that can be passed along */
372 #define PetscObjectUseFortranCallback_Private(obj, cid, types, args, cbclass) \
373 do { \
374 void(*func) types, *_ctx; \
375 PetscFunctionBegin; \
376 PetscCall(PetscObjectGetFortranCallback((PetscObject)(obj), (cbclass), (cid), (PetscFortranCallbackFn **)&func, &_ctx)); \
377 if (func) PetscCallFortranVoidFunction((*func)args); \
378 PetscFunctionReturn(PETSC_SUCCESS); \
379 } while (0)
380 #define PetscObjectUseFortranCallback(obj, cid, types, args) PetscObjectUseFortranCallback_Private(obj, cid, types, args, PETSC_FORTRAN_CALLBACK_CLASS)
381 #define PetscObjectUseFortranCallbackSubType(obj, cid, types, args) PetscObjectUseFortranCallback_Private(obj, cid, types, args, PETSC_FORTRAN_CALLBACK_SUBTYPE)
382
383 /* Disable deprecation warnings while building Fortran wrappers */
384 #undef PETSC_DEPRECATED_OBJECT
385 #define PETSC_DEPRECATED_OBJECT(...)
386 #undef PETSC_DEPRECATED_FUNCTION
387 #define PETSC_DEPRECATED_FUNCTION(...)
388 #undef PETSC_DEPRECATED_ENUM
389 #define PETSC_DEPRECATED_ENUM(...)
390 #undef PETSC_DEPRECATED_TYPEDEF
391 #define PETSC_DEPRECATED_TYPEDEF(...)
392 #undef PETSC_DEPRECATED_MACRO
393 #define PETSC_DEPRECATED_MACRO(...)
394
395 /* PGI compilers pass in f90 pointers as 2 arguments */
396 #if defined(PETSC_HAVE_F90_2PTR_ARG)
397 #define PETSC_F90_2PTR_PROTO_NOVAR , void *
398 #define PETSC_F90_2PTR_PROTO(ptr) , void *ptr
399 #define PETSC_F90_2PTR_PARAM(ptr) , ptr
400 #else
401 #define PETSC_F90_2PTR_PROTO_NOVAR
402 #define PETSC_F90_2PTR_PROTO(ptr)
403 #define PETSC_F90_2PTR_PARAM(ptr)
404 #endif
405
406 typedef struct {
407 char dummy;
408 } F90Array1d;
409 typedef struct {
410 char dummy;
411 } F90Array2d;
412 typedef struct {
413 char dummy;
414 } F90Array3d;
415 typedef struct {
416 char dummy;
417 } F90Array4d;
418
419 PETSC_EXTERN PetscErrorCode F90Array1dCreate(void *, MPI_Datatype, PetscInt, PetscInt, F90Array1d *PETSC_F90_2PTR_PROTO_NOVAR);
420 PETSC_EXTERN PetscErrorCode F90Array1dAccess(F90Array1d *, MPI_Datatype, void **PETSC_F90_2PTR_PROTO_NOVAR);
421 PETSC_EXTERN PetscErrorCode F90Array1dDestroy(F90Array1d *, MPI_Datatype PETSC_F90_2PTR_PROTO_NOVAR);
422
423 PETSC_EXTERN PetscErrorCode F90Array2dCreate(void *, MPI_Datatype, PetscInt, PetscInt, PetscInt, PetscInt, F90Array2d *PETSC_F90_2PTR_PROTO_NOVAR);
424 PETSC_EXTERN PetscErrorCode F90Array2dAccess(F90Array2d *, MPI_Datatype, void **PETSC_F90_2PTR_PROTO_NOVAR);
425 PETSC_EXTERN PetscErrorCode F90Array2dDestroy(F90Array2d *, MPI_Datatype PETSC_F90_2PTR_PROTO_NOVAR);
426
427 PETSC_EXTERN PetscErrorCode F90Array3dCreate(void *, MPI_Datatype, PetscInt, PetscInt, PetscInt, PetscInt, PetscInt, PetscInt, F90Array3d *PETSC_F90_2PTR_PROTO_NOVAR);
428 PETSC_EXTERN PetscErrorCode F90Array3dAccess(F90Array3d *, MPI_Datatype, void **PETSC_F90_2PTR_PROTO_NOVAR);
429 PETSC_EXTERN PetscErrorCode F90Array3dDestroy(F90Array3d *, MPI_Datatype PETSC_F90_2PTR_PROTO_NOVAR);
430
431 PETSC_EXTERN PetscErrorCode F90Array4dCreate(void *, MPI_Datatype, PetscInt, PetscInt, PetscInt, PetscInt, PetscInt, PetscInt, PetscInt, PetscInt, F90Array4d *PETSC_F90_2PTR_PROTO_NOVAR);
432 PETSC_EXTERN PetscErrorCode F90Array4dAccess(F90Array4d *, MPI_Datatype, void **PETSC_F90_2PTR_PROTO_NOVAR);
433 PETSC_EXTERN PetscErrorCode F90Array4dDestroy(F90Array4d *, MPI_Datatype PETSC_F90_2PTR_PROTO_NOVAR);
434
435 /*
436 F90Array1dCreate - Given a C pointer to a one dimensional
437 array and its length; this fills in the appropriate Fortran 90
438 pointer data structure.
439
440 Input Parameters:
441 + array - regular C pointer (address)
442 . type - DataType of the array
443 . start - starting index of the array
444 - len - length of array (in items)
445
446 Output Parameter:
447 . ptr - Fortran 90 pointer
448 */
449