Actual source code: fortranimpl.h


  2: /* This file contains info for the use of PETSc Fortran interface stubs */
  3: #ifndef PETSCFORTRANIMPL_H
  4: #define PETSCFORTRANIMPL_H

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

 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_FUNCTION_Fortran)(void);
 21: PETSC_EXTERN void *PETSC_NULL_MPI_COMM_Fortran;

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

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

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

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

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

 75: #define CHKFORTRANNULLINTEGER(a) \
 76:   if (FORTRANNULLINTEGER(a)) { \
 77:     a = NULL; \
 78:   } else if (FORTRANNULLDOUBLE(a) || FORTRANNULLSCALAR(a) || FORTRANNULLREAL(a) || FORTRANNULLBOOL(a) || FORTRANNULLFUNCTION(a) || FORTRANNULLCHARACTER(a) || FORTRANNULLMPICOMM(a)) { \
 79:     PetscError(PETSC_COMM_SELF, __LINE__, "fortran_interface_unknown_file", __FILE__, PETSC_ERR_ARG_WRONG, PETSC_ERROR_INITIAL, "Use PETSC_NULL_INTEGER"); \
 80:     *1; \
 81:     return; \
 82:   }

 84: #define CHKFORTRANNULLSCALAR(a) \
 85:   if (FORTRANNULLSCALAR(a)) { \
 86:     a = NULL; \
 87:   } else if (FORTRANNULLINTEGER(a) || FORTRANNULLDOUBLE(a) || FORTRANNULLREAL(a) || FORTRANNULLBOOL(a) || FORTRANNULLFUNCTION(a) || FORTRANNULLCHARACTER(a) || FORTRANNULLMPICOMM(a)) { \
 88:     PetscError(PETSC_COMM_SELF, __LINE__, "fortran_interface_unknown_file", __FILE__, PETSC_ERR_ARG_WRONG, PETSC_ERROR_INITIAL, "Use PETSC_NULL_SCALAR"); \
 89:     *1; \
 90:     return; \
 91:   }

 93: #define CHKFORTRANNULLDOUBLE(a) \
 94:   if (FORTRANNULLDOUBLE(a)) { \
 95:     a = NULL; \
 96:   } else if (FORTRANNULLINTEGER(a) || FORTRANNULLSCALAR(a) || FORTRANNULLREAL(a) || FORTRANNULLBOOL(a) || FORTRANNULLFUNCTION(a) || FORTRANNULLCHARACTER(a) || FORTRANNULLMPICOMM(a)) { \
 97:     PetscError(PETSC_COMM_SELF, __LINE__, "fortran_interface_unknown_file", __FILE__, PETSC_ERR_ARG_WRONG, PETSC_ERROR_INITIAL, "Use PETSC_NULL_DOUBLE"); \
 98:     *1; \
 99:     return; \
100:   }

102: #define CHKFORTRANNULLREAL(a) \
103:   if (FORTRANNULLREAL(a)) { \
104:     a = NULL; \
105:   } else if (FORTRANNULLINTEGER(a) || FORTRANNULLDOUBLE(a) || FORTRANNULLSCALAR(a) || FORTRANNULLBOOL(a) || FORTRANNULLFUNCTION(a) || FORTRANNULLCHARACTER(a) || FORTRANNULLMPICOMM(a)) { \
106:     PetscError(PETSC_COMM_SELF, __LINE__, "fortran_interface_unknown_file", __FILE__, PETSC_ERR_ARG_WRONG, PETSC_ERROR_INITIAL, "Use PETSC_NULL_REAL"); \
107:     *1; \
108:     return; \
109:   }

111: #define CHKFORTRANNULLOBJECT(a) \
112:   if (*(void **)a == (void *)0) { \
113:     a = NULL; \
114:   } else if (FORTRANNULLINTEGER(a) || FORTRANNULLDOUBLE(a) || FORTRANNULLSCALAR(a) || FORTRANNULLREAL(a) || FORTRANNULLBOOL(a) || FORTRANNULLFUNCTION(a) || FORTRANNULLCHARACTER(a) || FORTRANNULLMPICOMM(a)) { \
115:     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"); \
116:     *1; \
117:     return; \
118:   }

120: #define CHKFORTRANNULLBOOL(a) \
121:   if (FORTRANNULLBOOL(a)) { \
122:     a = NULL; \
123:   } else if (FORTRANNULLSCALAR(a) || FORTRANNULLINTEGER(a) || FORTRANNULLDOUBLE(a) || FORTRANNULLSCALAR(a) || FORTRANNULLREAL(a) || FORTRANNULLFUNCTION(a) || FORTRANNULLCHARACTER(a) || FORTRANNULLMPICOMM(a)) { \
124:     PetscError(PETSC_COMM_SELF, __LINE__, "fortran_interface_unknown_file", __FILE__, PETSC_ERR_ARG_WRONG, PETSC_ERROR_INITIAL, "Use PETSC_NULL_BOOL"); \
125:     *1; \
126:     return; \
127:   }

129: #define CHKFORTRANNULLFUNCTION(a) \
130:   if (FORTRANNULLFUNCTION(a)) { \
131:     a = NULL; \
132:   } else if (FORTRANNULLOBJECT(a) || FORTRANNULLSCALAR(a) || FORTRANNULLDOUBLE(a) || FORTRANNULLREAL(a) || FORTRANNULLINTEGER(a) || FORTRANNULLBOOL(a) || FORTRANNULLCHARACTER(a) || FORTRANNULLMPICOMM(a)) { \
133:     PetscError(PETSC_COMM_SELF, __LINE__, "fortran_interface_unknown_file", __FILE__, PETSC_ERR_ARG_WRONG, PETSC_ERROR_INITIAL, "Use PETSC_NULL_FUNCTION"); \
134:     *1; \
135:     return; \
136:   }

138: #define CHKFORTRANNULLMPICOMM(a) \
139:   if (FORTRANNULLMPICOMM(a)) { \
140:     a = NULL; \
141:   } else if (FORTRANNULLINTEGER(a) || FORTRANNULLDOUBLE(a) || FORTRANNULLSCALAR(a) || FORTRANNULLREAL(a) || FORTRANNULLBOOL(a) || FORTRANNULLFUNCTION(a) || FORTRANNULLCHARACTER(a)) { \
142:     PetscError(PETSC_COMM_SELF, __LINE__, "fortran_interface_unknown_file", __FILE__, PETSC_ERR_ARG_WRONG, PETSC_ERROR_INITIAL, "Use PETSC_NULL_MPI_COMM"); \
143:     *1; \
144:     return; \
145:   }

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

151: /* 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() */
152: #define PETSC_FORTRAN_OBJECT_F_DESTROYED_TO_C_NULL(a) \
153:   do { \
154:     if (*((void **)(a)) == (void *)-2) *(a) = NULL; \
155:   } while (0)

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

166: /*
167:     Variable type where we stash PETSc object pointers in Fortran.
168: */
169: typedef PETSC_UINTPTR_T PetscFortranAddr;

171: /*
172:     These are used to support the default viewers that are
173:   created at run time, in C using the , trick.

175:     The numbers here must match the numbers in include/petsc/finclude/petscsys.h
176: */
177: #define PETSC_VIEWER_DRAW_WORLD_FORTRAN   4
178: #define PETSC_VIEWER_DRAW_SELF_FORTRAN    5
179: #define PETSC_VIEWER_SOCKET_WORLD_FORTRAN 6
180: #define PETSC_VIEWER_SOCKET_SELF_FORTRAN  7
181: #define PETSC_VIEWER_STDOUT_WORLD_FORTRAN 8
182: #define PETSC_VIEWER_STDOUT_SELF_FORTRAN  9
183: #define PETSC_VIEWER_STDERR_WORLD_FORTRAN 10
184: #define PETSC_VIEWER_STDERR_SELF_FORTRAN  11
185: #define PETSC_VIEWER_BINARY_WORLD_FORTRAN 12
186: #define PETSC_VIEWER_BINARY_SELF_FORTRAN  13
187: #define PETSC_VIEWER_MATLAB_WORLD_FORTRAN 14
188: #define PETSC_VIEWER_MATLAB_SELF_FORTRAN  15

190: #if defined(PETSC_USE_SOCKET_VIEWER)
191:   #define PetscPatchDefaultViewers_Fortran_Socket(vin, v) \
192:     } \
193:     else if ((*(PetscFortranAddr *)vin) == PETSC_VIEWER_SOCKET_WORLD_FORTRAN) \
194:     { \
195:       v = PETSC_VIEWER_SOCKET_WORLD; \
196:     } \
197:     else if ((*(PetscFortranAddr *)vin) == PETSC_VIEWER_SOCKET_SELF_FORTRAN) \
198:     { \
199:       v = PETSC_VIEWER_SOCKET_SELF
200: #else
201:   #define PetscPatchDefaultViewers_Fortran_Socket(vin, v)
202: #endif

204: #define PetscPatchDefaultViewers_Fortran(vin, v) \
205:   { \
206:     if ((*(PetscFortranAddr *)vin) == PETSC_VIEWER_DRAW_WORLD_FORTRAN) { \
207:       v = PETSC_VIEWER_DRAW_WORLD; \
208:     } else if ((*(PetscFortranAddr *)vin) == PETSC_VIEWER_DRAW_SELF_FORTRAN) { \
209:       v = PETSC_VIEWER_DRAW_SELF; \
210:     } else if ((*(PetscFortranAddr *)vin) == PETSC_VIEWER_STDOUT_WORLD_FORTRAN) { \
211:       v = PETSC_VIEWER_STDOUT_WORLD; \
212:     } else if ((*(PetscFortranAddr *)vin) == PETSC_VIEWER_STDOUT_SELF_FORTRAN) { \
213:       v = PETSC_VIEWER_STDOUT_SELF; \
214:     } else if ((*(PetscFortranAddr *)vin) == PETSC_VIEWER_STDERR_WORLD_FORTRAN) { \
215:       v = PETSC_VIEWER_STDERR_WORLD; \
216:     } else if ((*(PetscFortranAddr *)vin) == PETSC_VIEWER_STDERR_SELF_FORTRAN) { \
217:       v = PETSC_VIEWER_STDERR_SELF; \
218:     } else if ((*(PetscFortranAddr *)vin) == PETSC_VIEWER_BINARY_WORLD_FORTRAN) { \
219:       v = PETSC_VIEWER_BINARY_WORLD; \
220:     } else if ((*(PetscFortranAddr *)vin) == PETSC_VIEWER_BINARY_SELF_FORTRAN) { \
221:       v = PETSC_VIEWER_BINARY_SELF; \
222:     } else if ((*(PetscFortranAddr *)vin) == PETSC_VIEWER_MATLAB_WORLD_FORTRAN) { \
223:       v = PETSC_VIEWER_BINARY_WORLD; \
224:     } else if ((*(PetscFortranAddr *)vin) == PETSC_VIEWER_MATLAB_SELF_FORTRAN) { \
225:       v = PETSC_VIEWER_BINARY_SELF; \
226:       PetscPatchDefaultViewers_Fortran_Socket(vin, v); \
227:     } else { \
228:       v = *vin; \
229:     } \
230:   }

232: /*
233:       Allocates enough space to store Fortran function pointers in PETSc object
234:    that are needed by the Fortran interface.
235: */
236: #define PetscObjectAllocateFortranPointers(obj, N) \
237:   do { \
238:     if (!((PetscObject)(obj))->fortran_func_pointers) { \
239:       *(N) * sizeof(void (*)(void)), &((PetscObject)(obj))->fortran_func_pointers; \
240:       if (*ierr) return; \
241:       ((PetscObject)obj)->num_fortran_func_pointers = (N); \
242:     } \
243:   } while (0)

245: #define PetscCallFortranVoidFunction(...) \
246:   do { \
247:     PetscErrorCode 0; \
248:     /* the function may or may not access ierr */ \
249:     __VA_ARGS__; \
250:     ierr; \
251:   } while (0)

253: /* Entire function body, _ctx is a "special" variable that can be passed along */
254: #define PetscObjectUseFortranCallback_Private(obj, cid, types, args, cbclass) \
255:   { \
256:     void(*func) types, *_ctx; \
257:     PetscObjectGetFortranCallback((PetscObject)(obj), (cbclass), (cid), (PetscVoidFunction *)&func, &_ctx); \
258:     if (func) (*func)args; \
259:     return 0; \
260:   }
261: #define PetscObjectUseFortranCallback(obj, cid, types, args)        PetscObjectUseFortranCallback_Private(obj, cid, types, args, PETSC_FORTRAN_CALLBACK_CLASS)
262: #define PetscObjectUseFortranCallbackSubType(obj, cid, types, args) PetscObjectUseFortranCallback_Private(obj, cid, types, args, PETSC_FORTRAN_CALLBACK_SUBTYPE)

264: /* Disable deprecation warnings while building Fortran wrappers */
265: #undef PETSC_DEPRECATED_FUNCTION
266: #define PETSC_DEPRECATED_FUNCTION(arg)

268: #endif