Actual source code: fortranimpl.h

  1: /* This file contains info for the use of PETSc Fortran interface stubs */
  2: #pragma once

  4: #include <petsc/private/petscimpl.h>
  5: PETSC_INTERN PetscErrorCode PETScParseFortranArgs_Private(int *, char ***);
  6: PETSC_EXTERN PetscErrorCode PetscMPIFortranDatatypeToC(MPI_Fint, MPI_Datatype *);

  8: PETSC_EXTERN PetscErrorCode PetscScalarAddressToFortran(PetscObject, PetscInt, PetscScalar *, PetscScalar *, PetscInt, size_t *);
  9: PETSC_EXTERN PetscErrorCode PetscScalarAddressFromFortran(PetscObject, PetscScalar *, size_t, PetscInt, PetscScalar **);
 10: PETSC_EXTERN size_t         PetscIntAddressToFortran(const PetscInt *, const PetscInt *);
 11: PETSC_EXTERN PetscInt      *PetscIntAddressFromFortran(const PetscInt *, size_t);
 12: PETSC_EXTERN char          *PETSC_NULL_CHARACTER_Fortran;
 13: PETSC_EXTERN void          *PETSC_NULL_INTEGER_Fortran;
 14: PETSC_EXTERN void          *PETSC_NULL_SCALAR_Fortran;
 15: PETSC_EXTERN void          *PETSC_NULL_DOUBLE_Fortran;
 16: PETSC_EXTERN void          *PETSC_NULL_REAL_Fortran;
 17: PETSC_EXTERN void          *PETSC_NULL_BOOL_Fortran;
 18: PETSC_EXTERN void (*PETSC_NULL_FUNCTION_Fortran)(void);
 19: PETSC_EXTERN void *PETSC_NULL_MPI_COMM_Fortran;

 21: PETSC_INTERN PetscErrorCode PetscInitFortran_Private(PetscBool, const char *, PetscInt);

 23: /*  ----------------------------------------------------------------------*/
 24: /*
 25:    PETSc object C pointers are stored directly as
 26:    Fortran integer*4 or *8 depending on the size of pointers.
 27: */

 29: /* --------------------------------------------------------------------*/
 30: /*
 31:     Since Fortran does not null terminate strings we need to insure the string is null terminated before passing it
 32:     to C. This may require a memory allocation which is then freed with FREECHAR().
 33: */
 34: #define FIXCHAR(a, n, b) \
 35:   do { \
 36:     if ((a) == PETSC_NULL_CHARACTER_Fortran) { \
 37:       (b) = (a) = NULL; \
 38:     } else { \
 39:       while (((n) > 0) && ((a)[(n)-1] == ' ')) (n)--; \
 40:       *ierr = PetscMalloc1((n) + 1, &(b)); \
 41:       if (*ierr) return; \
 42:       *ierr  = PetscMemcpy((b), (a), (n)); \
 43:       (b)[n] = '\0'; \
 44:       if (*ierr) return; \
 45:     } \
 46:   } while (0)
 47: #define FREECHAR(a, b) \
 48:   do { \
 49:     if (a != b) *ierr = PetscFree(b); \
 50:   } while (0)

 52: /*
 53:     Fortran expects any unneeded characters at the end of its strings to be filled with the blank character.
 54: */
 55: #define FIXRETURNCHAR(flg, a, n) \
 56:   do { \
 57:     if (flg) { \
 58:       PETSC_FORTRAN_CHARLEN_T __i; \
 59:       for (__i = 0; __i < n && a[__i] != 0; __i++) { }; \
 60:       for (; __i < n; __i++) a[__i] = ' '; \
 61:     } \
 62:   } while (0)

 64: /*
 65:     The cast through PETSC_UINTPTR_T is so that compilers that warn about casting to/from void * to void(*)(void)
 66:     will not complain about these comparisons. It is not know if this works for all compilers
 67: */
 68: #define FORTRANNULLINTEGER(a)   (((void *)(PETSC_UINTPTR_T)a) == PETSC_NULL_INTEGER_Fortran)
 69: #define FORTRANNULLSCALAR(a)    (((void *)(PETSC_UINTPTR_T)a) == PETSC_NULL_SCALAR_Fortran)
 70: #define FORTRANNULLDOUBLE(a)    (((void *)(PETSC_UINTPTR_T)a) == PETSC_NULL_DOUBLE_Fortran)
 71: #define FORTRANNULLREAL(a)      (((void *)(PETSC_UINTPTR_T)a) == PETSC_NULL_REAL_Fortran)
 72: #define FORTRANNULLBOOL(a)      (((void *)(PETSC_UINTPTR_T)a) == PETSC_NULL_BOOL_Fortran)
 73: #define FORTRANNULLCHARACTER(a) (((void *)(PETSC_UINTPTR_T)a) == PETSC_NULL_CHARACTER_Fortran)
 74: #define FORTRANNULLFUNCTION(a)  (((void (*)(void))(PETSC_UINTPTR_T)a) == PETSC_NULL_FUNCTION_Fortran)
 75: #define FORTRANNULLOBJECT(a)    (*(void **)(PETSC_UINTPTR_T)a == (void *)0)
 76: #define FORTRANNULLMPICOMM(a)   (((void *)(PETSC_UINTPTR_T)a) == PETSC_NULL_MPI_COMM_Fortran)

 78: #define CHKFORTRANNULLINTEGER(a) \
 79:   do { \
 80:     if (FORTRANNULLINTEGER(a)) { \
 81:       a = NULL; \
 82:     } else if (FORTRANNULLDOUBLE(a) || FORTRANNULLSCALAR(a) || FORTRANNULLREAL(a) || FORTRANNULLBOOL(a) || FORTRANNULLFUNCTION(a) || FORTRANNULLCHARACTER(a) || FORTRANNULLMPICOMM(a)) { \
 83:       *ierr = PetscError(PETSC_COMM_SELF, __LINE__, "fortran_interface_unknown_file", __FILE__, PETSC_ERR_ARG_WRONG, PETSC_ERROR_INITIAL, "Use PETSC_NULL_INTEGER"); \
 84:       *ierr = PETSC_ERR_ARG_BADPTR; \
 85:       return; \
 86:     } \
 87:   } while (0)

 89: #define CHKFORTRANNULLSCALAR(a) \
 90:   do { \
 91:     if (FORTRANNULLSCALAR(a)) { \
 92:       a = NULL; \
 93:     } else if (FORTRANNULLINTEGER(a) || FORTRANNULLDOUBLE(a) || FORTRANNULLREAL(a) || FORTRANNULLBOOL(a) || FORTRANNULLFUNCTION(a) || FORTRANNULLCHARACTER(a) || FORTRANNULLMPICOMM(a)) { \
 94:       *ierr = PetscError(PETSC_COMM_SELF, __LINE__, "fortran_interface_unknown_file", __FILE__, PETSC_ERR_ARG_WRONG, PETSC_ERROR_INITIAL, "Use PETSC_NULL_SCALAR"); \
 95:       *ierr = PETSC_ERR_ARG_BADPTR; \
 96:       return; \
 97:     } \
 98:   } while (0)

100: #define CHKFORTRANNULLDOUBLE(a) \
101:   do { \
102:     if (FORTRANNULLDOUBLE(a)) { \
103:       a = NULL; \
104:     } else if (FORTRANNULLINTEGER(a) || FORTRANNULLSCALAR(a) || FORTRANNULLREAL(a) || FORTRANNULLBOOL(a) || FORTRANNULLFUNCTION(a) || FORTRANNULLCHARACTER(a) || FORTRANNULLMPICOMM(a)) { \
105:       *ierr = PetscError(PETSC_COMM_SELF, __LINE__, "fortran_interface_unknown_file", __FILE__, PETSC_ERR_ARG_WRONG, PETSC_ERROR_INITIAL, "Use PETSC_NULL_DOUBLE"); \
106:       *ierr = PETSC_ERR_ARG_BADPTR; \
107:       return; \
108:     } \
109:   } while (0)

111: #define CHKFORTRANNULLREAL(a) \
112:   do { \
113:     if (FORTRANNULLREAL(a)) { \
114:       a = NULL; \
115:     } else if (FORTRANNULLINTEGER(a) || FORTRANNULLDOUBLE(a) || FORTRANNULLSCALAR(a) || FORTRANNULLBOOL(a) || FORTRANNULLFUNCTION(a) || FORTRANNULLCHARACTER(a) || FORTRANNULLMPICOMM(a)) { \
116:       *ierr = PetscError(PETSC_COMM_SELF, __LINE__, "fortran_interface_unknown_file", __FILE__, PETSC_ERR_ARG_WRONG, PETSC_ERROR_INITIAL, "Use PETSC_NULL_REAL"); \
117:       *ierr = PETSC_ERR_ARG_BADPTR; \
118:       return; \
119:     } \
120:   } while (0)

122: #define CHKFORTRANNULLOBJECT(a) \
123:   do { \
124:     if (*(void **)a == (void *)0) { \
125:       a = NULL; \
126:     } else if (FORTRANNULLINTEGER(a) || FORTRANNULLDOUBLE(a) || FORTRANNULLSCALAR(a) || FORTRANNULLREAL(a) || FORTRANNULLBOOL(a) || FORTRANNULLFUNCTION(a) || FORTRANNULLCHARACTER(a) || FORTRANNULLMPICOMM(a)) { \
127:       *ierr = PetscError(PETSC_COMM_SELF, __LINE__, "fortran_interface_unknown_file", __FILE__, PETSC_ERR_ARG_WRONG, PETSC_ERROR_INITIAL, "Use PETSC_NULL_XXX where XXX is the name of a particular object class"); \
128:       *ierr = PETSC_ERR_ARG_BADPTR; \
129:       return; \
130:     } \
131:   } while (0)

133: #define CHKFORTRANNULLBOOL(a) \
134:   do { \
135:     if (FORTRANNULLBOOL(a)) { \
136:       a = NULL; \
137:     } else if (FORTRANNULLSCALAR(a) || FORTRANNULLINTEGER(a) || FORTRANNULLDOUBLE(a) || FORTRANNULLSCALAR(a) || FORTRANNULLREAL(a) || FORTRANNULLFUNCTION(a) || FORTRANNULLCHARACTER(a) || FORTRANNULLMPICOMM(a)) { \
138:       *ierr = PetscError(PETSC_COMM_SELF, __LINE__, "fortran_interface_unknown_file", __FILE__, PETSC_ERR_ARG_WRONG, PETSC_ERROR_INITIAL, "Use PETSC_NULL_BOOL"); \
139:       *ierr = PETSC_ERR_ARG_BADPTR; \
140:       return; \
141:     } \
142:   } while (0)

144: #define CHKFORTRANNULLFUNCTION(a) \
145:   do { \
146:     if (FORTRANNULLFUNCTION(a)) { \
147:       a = NULL; \
148:     } else if (FORTRANNULLOBJECT(a) || FORTRANNULLSCALAR(a) || FORTRANNULLDOUBLE(a) || FORTRANNULLREAL(a) || FORTRANNULLINTEGER(a) || FORTRANNULLBOOL(a) || FORTRANNULLCHARACTER(a) || FORTRANNULLMPICOMM(a)) { \
149:       *ierr = PetscError(PETSC_COMM_SELF, __LINE__, "fortran_interface_unknown_file", __FILE__, PETSC_ERR_ARG_WRONG, PETSC_ERROR_INITIAL, "Use PETSC_NULL_FUNCTION"); \
150:       *ierr = PETSC_ERR_ARG_BADPTR; \
151:       return; \
152:     } \
153:   } while (0)

155: #define CHKFORTRANNULLMPICOMM(a) \
156:   do { \
157:     if (FORTRANNULLMPICOMM(a)) { \
158:       a = NULL; \
159:     } else if (FORTRANNULLINTEGER(a) || FORTRANNULLDOUBLE(a) || FORTRANNULLSCALAR(a) || FORTRANNULLREAL(a) || FORTRANNULLBOOL(a) || FORTRANNULLFUNCTION(a) || FORTRANNULLCHARACTER(a)) { \
160:       *ierr = PetscError(PETSC_COMM_SELF, __LINE__, "fortran_interface_unknown_file", __FILE__, PETSC_ERR_ARG_WRONG, PETSC_ERROR_INITIAL, "Use PETSC_NULL_MPI_COMM"); \
161:       *ierr = PETSC_ERR_ARG_BADPTR; \
162:       return; \
163:     } \
164:   } while (0)

166: /* The two macros are used at the beginning and end of PETSc object Fortran destroy routines XxxDestroy(). -2 is in consistent with
167:    the one used in checkFortranTypeInitialize() at compilersFortran.py.
168:  */

170: /* 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() */
171: #define PETSC_FORTRAN_OBJECT_F_DESTROYED_TO_C_NULL(a) \
172:   do { \
173:     if (*((void **)(a)) == (void *)-2) *(a) = NULL; \
174:   } while (0)

176: /* After C XxxDestroy(a) is called, change a's state from NULL to destroyed, so that it can be used/destroyed again by Fortran.
177:    E.g., in VecScatterCreateToAll(x,vscat,seq,ierr), if seq = PETSC_NULL_VEC, petsc won't create seq. But if seq is a
178:    destroyed object (e.g., as a result of a previous Fortran VecDestroy), petsc will create seq.
179: */
180: #define PETSC_FORTRAN_OBJECT_C_NULL_TO_F_DESTROYED(a) \
181:   do { \
182:     *((void **)(a)) = (void *)-2; \
183:   } while (0)

185: /*
186:     Variable type where we stash PETSc object pointers in Fortran.
187: */
188: typedef PETSC_UINTPTR_T PetscFortranAddr;

190: /*
191:     These are used to support the default viewers that are
192:   created at run time, in C using the , trick.

194:     The numbers here must match the numbers in include/petsc/finclude/petscsys.h
195: */
196: #define PETSC_VIEWER_DRAW_WORLD_FORTRAN   4
197: #define PETSC_VIEWER_DRAW_SELF_FORTRAN    5
198: #define PETSC_VIEWER_SOCKET_WORLD_FORTRAN 6
199: #define PETSC_VIEWER_SOCKET_SELF_FORTRAN  7
200: #define PETSC_VIEWER_STDOUT_WORLD_FORTRAN 8
201: #define PETSC_VIEWER_STDOUT_SELF_FORTRAN  9
202: #define PETSC_VIEWER_STDERR_WORLD_FORTRAN 10
203: #define PETSC_VIEWER_STDERR_SELF_FORTRAN  11
204: #define PETSC_VIEWER_BINARY_WORLD_FORTRAN 12
205: #define PETSC_VIEWER_BINARY_SELF_FORTRAN  13
206: #define PETSC_VIEWER_MATLAB_WORLD_FORTRAN 14
207: #define PETSC_VIEWER_MATLAB_SELF_FORTRAN  15

209: #if defined(PETSC_USE_SOCKET_VIEWER)
210:   #define PetscPatchDefaultViewers_Fortran_Socket(vin, v) \
211:     } \
212:     else if ((*(PetscFortranAddr *)vin) == PETSC_VIEWER_SOCKET_WORLD_FORTRAN) \
213:     { \
214:       v = PETSC_VIEWER_SOCKET_WORLD; \
215:     } \
216:     else if ((*(PetscFortranAddr *)vin) == PETSC_VIEWER_SOCKET_SELF_FORTRAN) \
217:     { \
218:       v = PETSC_VIEWER_SOCKET_SELF
219: #else
220:   #define PetscPatchDefaultViewers_Fortran_Socket(vin, v)
221: #endif

223: #define PetscPatchDefaultViewers_Fortran(vin, v) \
224:   do { \
225:     if ((*(PetscFortranAddr *)vin) == PETSC_VIEWER_DRAW_WORLD_FORTRAN) { \
226:       v = PETSC_VIEWER_DRAW_WORLD; \
227:     } else if ((*(PetscFortranAddr *)vin) == PETSC_VIEWER_DRAW_SELF_FORTRAN) { \
228:       v = PETSC_VIEWER_DRAW_SELF; \
229:     } else if ((*(PetscFortranAddr *)vin) == PETSC_VIEWER_STDOUT_WORLD_FORTRAN) { \
230:       v = PETSC_VIEWER_STDOUT_WORLD; \
231:     } else if ((*(PetscFortranAddr *)vin) == PETSC_VIEWER_STDOUT_SELF_FORTRAN) { \
232:       v = PETSC_VIEWER_STDOUT_SELF; \
233:     } else if ((*(PetscFortranAddr *)vin) == PETSC_VIEWER_STDERR_WORLD_FORTRAN) { \
234:       v = PETSC_VIEWER_STDERR_WORLD; \
235:     } else if ((*(PetscFortranAddr *)vin) == PETSC_VIEWER_STDERR_SELF_FORTRAN) { \
236:       v = PETSC_VIEWER_STDERR_SELF; \
237:     } else if ((*(PetscFortranAddr *)vin) == PETSC_VIEWER_BINARY_WORLD_FORTRAN) { \
238:       v = PETSC_VIEWER_BINARY_WORLD; \
239:     } else if ((*(PetscFortranAddr *)vin) == PETSC_VIEWER_BINARY_SELF_FORTRAN) { \
240:       v = PETSC_VIEWER_BINARY_SELF; \
241:     } else if ((*(PetscFortranAddr *)vin) == PETSC_VIEWER_MATLAB_WORLD_FORTRAN) { \
242:       v = PETSC_VIEWER_BINARY_WORLD; \
243:     } else if ((*(PetscFortranAddr *)vin) == PETSC_VIEWER_MATLAB_SELF_FORTRAN) { \
244:       v = PETSC_VIEWER_BINARY_SELF; \
245:       PetscPatchDefaultViewers_Fortran_Socket(vin, v); \
246:     } else { \
247:       v = *vin; \
248:     } \
249:   } while (0)

251: /*
252:       Allocates enough space to store Fortran function pointers in PETSc object
253:    that are needed by the Fortran interface.
254: */
255: #define PetscObjectAllocateFortranPointers(obj, N) \
256:   do { \
257:     if (!((PetscObject)(obj))->fortran_func_pointers) { \
258:       *ierr = PetscCalloc((N) * sizeof(void (*)(void)), &((PetscObject)(obj))->fortran_func_pointers); \
259:       if (*ierr) return; \
260:       ((PetscObject)obj)->num_fortran_func_pointers = (N); \
261:     } \
262:   } while (0)

264: #define PetscCallFortranVoidFunction(...) \
265:   do { \
266:     PetscErrorCode ierr = PETSC_SUCCESS; \
267:     /* the function may or may not access ierr */ \
268:     __VA_ARGS__; \
269:     PetscCall(ierr); \
270:   } while (0)

272: /* Entire function body, _ctx is a "special" variable that can be passed along */
273: #define PetscObjectUseFortranCallback_Private(obj, cid, types, args, cbclass) \
274:   do { \
275:     void(*func) types, *_ctx; \
276:     PetscFunctionBegin; \
277:     PetscCall(PetscObjectGetFortranCallback((PetscObject)(obj), (cbclass), (cid), (PetscVoidFunction *)&func, &_ctx)); \
278:     if (func) PetscCallFortranVoidFunction((*func)args); \
279:     PetscFunctionReturn(PETSC_SUCCESS); \
280:   } while (0)
281: #define PetscObjectUseFortranCallback(obj, cid, types, args)        PetscObjectUseFortranCallback_Private(obj, cid, types, args, PETSC_FORTRAN_CALLBACK_CLASS)
282: #define PetscObjectUseFortranCallbackSubType(obj, cid, types, args) PetscObjectUseFortranCallback_Private(obj, cid, types, args, PETSC_FORTRAN_CALLBACK_SUBTYPE)

284: /* Disable deprecation warnings while building Fortran wrappers */
285: #undef PETSC_DEPRECATED_OBJECT
286: #define PETSC_DEPRECATED_OBJECT(...)
287: #undef PETSC_DEPRECATED_FUNCTION
288: #define PETSC_DEPRECATED_FUNCTION(...)
289: #undef PETSC_DEPRECATED_ENUM
290: #define PETSC_DEPRECATED_ENUM(...)
291: #undef PETSC_DEPRECATED_TYPEDEF
292: #define PETSC_DEPRECATED_TYPEDEF(...)
293: #undef PETSC_DEPRECATED_MACRO
294: #define PETSC_DEPRECATED_MACRO(...)