Actual source code: fortranimpl.h


  2: /* This file contains info for the use of PETSc Fortran interface stubs */
  3: #if !defined(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) if (a != b) *PetscFree(b);

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

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

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

 80: #define CHKFORTRANNULLSCALAR(a)   \
 81:   if (FORTRANNULLSCALAR(a)) { a = NULL; } \
 82:   else if (FORTRANNULLINTEGER(a) || FORTRANNULLDOUBLE(a) || FORTRANNULLREAL(a)  || FORTRANNULLBOOL(a) || FORTRANNULLFUNCTION(a) || FORTRANNULLCHARACTER(a) || FORTRANNULLMPICOMM(a)) { \
 83:     PetscError(PETSC_COMM_SELF,__LINE__,"fortran_interface_unknown_file",__FILE__,PETSC_ERR_ARG_WRONG,PETSC_ERROR_INITIAL, \
 84:     "Use PETSC_NULL_SCALAR"); *1; return; }

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

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

 98: #define CHKFORTRANNULLOBJECT(a)  \
 99:   if (*(void**)a == (void*)0) { a = NULL; } \
100:   else if (FORTRANNULLINTEGER(a) || FORTRANNULLDOUBLE(a) || FORTRANNULLSCALAR(a) || FORTRANNULLREAL(a) || FORTRANNULLBOOL(a) || FORTRANNULLFUNCTION(a) || FORTRANNULLCHARACTER(a) || FORTRANNULLMPICOMM(a)) { \
101:     PetscError(PETSC_COMM_SELF,__LINE__,"fortran_interface_unknown_file",__FILE__,PETSC_ERR_ARG_WRONG,PETSC_ERROR_INITIAL, \
102:     "Use PETSC_NULL_XXX where XXX is the name of a particular object class"); *1; return; }

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

110: #define CHKFORTRANNULLFUNCTION(a)  \
111:   if (FORTRANNULLFUNCTION(a)) { a = NULL; } \
112:   else if (FORTRANNULLOBJECT(a) || FORTRANNULLSCALAR(a) || FORTRANNULLDOUBLE(a) || FORTRANNULLREAL(a) || FORTRANNULLINTEGER(a) || FORTRANNULLBOOL(a) || FORTRANNULLCHARACTER(a) || FORTRANNULLMPICOMM(a)) { \
113:     PetscError(PETSC_COMM_SELF,__LINE__,"fortran_interface_unknown_file",__FILE__,PETSC_ERR_ARG_WRONG,PETSC_ERROR_INITIAL, \
114:     "Use PETSC_NULL_FUNCTION"); *1; return; }

116: #define CHKFORTRANNULLMPICOMM(a)  \
117:   if (FORTRANNULLMPICOMM(a)) { a = NULL; } \
118:   else if (FORTRANNULLINTEGER(a) || FORTRANNULLDOUBLE(a) || FORTRANNULLSCALAR(a) || FORTRANNULLREAL(a)  || FORTRANNULLBOOL(a) || FORTRANNULLFUNCTION(a) || FORTRANNULLCHARACTER(a)) { \
119:     PetscError(PETSC_COMM_SELF,__LINE__,"fortran_interface_unknown_file",__FILE__,PETSC_ERR_ARG_WRONG,PETSC_ERROR_INITIAL, \
120:     "Use PETSC_NULL_MPI_COMM"); *1; return; }

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

126: /* 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() */
127: #define PETSC_FORTRAN_OBJECT_F_DESTROYED_TO_C_NULL(a) do {if (*((void**)(a)) == (void*)-2) *(a) = NULL;} while (0)

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

135: /*
136:     Variable type where we stash PETSc object pointers in Fortran.
137: */
138: typedef PETSC_UINTPTR_T PetscFortranAddr;

140: /*
141:     These are used to support the default viewers that are
142:   created at run time, in C using the , trick.

144:     The numbers here must match the numbers in include/petsc/finclude/petscsys.h
145: */
146: #define PETSC_VIEWER_DRAW_WORLD_FORTRAN     4
147: #define PETSC_VIEWER_DRAW_SELF_FORTRAN      5
148: #define PETSC_VIEWER_SOCKET_WORLD_FORTRAN   6
149: #define PETSC_VIEWER_SOCKET_SELF_FORTRAN    7
150: #define PETSC_VIEWER_STDOUT_WORLD_FORTRAN   8
151: #define PETSC_VIEWER_STDOUT_SELF_FORTRAN    9
152: #define PETSC_VIEWER_STDERR_WORLD_FORTRAN   10
153: #define PETSC_VIEWER_STDERR_SELF_FORTRAN    11
154: #define PETSC_VIEWER_BINARY_WORLD_FORTRAN   12
155: #define PETSC_VIEWER_BINARY_SELF_FORTRAN    13
156: #define PETSC_VIEWER_MATLAB_WORLD_FORTRAN   14
157: #define PETSC_VIEWER_MATLAB_SELF_FORTRAN    15

159: #if defined (PETSC_USE_SOCKET_VIEWER)
160: #define PetscPatchDefaultViewers_Fortran_Socket(vin,v) \
161:     } else if ((*(PetscFortranAddr*)vin) == PETSC_VIEWER_SOCKET_WORLD_FORTRAN) { \
162:       v = PETSC_VIEWER_SOCKET_WORLD; \
163:     } else if ((*(PetscFortranAddr*)vin) == PETSC_VIEWER_SOCKET_SELF_FORTRAN) { \
164:       v = PETSC_VIEWER_SOCKET_SELF
165: #else
166: #define PetscPatchDefaultViewers_Fortran_Socket(vin,v)
167: #endif

169: #define PetscPatchDefaultViewers_Fortran(vin,v) \
170: { \
171:     if ((*(PetscFortranAddr*)vin) == PETSC_VIEWER_DRAW_WORLD_FORTRAN) { \
172:       v = PETSC_VIEWER_DRAW_WORLD; \
173:     } else if ((*(PetscFortranAddr*)vin) == PETSC_VIEWER_DRAW_SELF_FORTRAN) { \
174:       v = PETSC_VIEWER_DRAW_SELF; \
175:     } else if ((*(PetscFortranAddr*)vin) == PETSC_VIEWER_STDOUT_WORLD_FORTRAN) { \
176:       v = PETSC_VIEWER_STDOUT_WORLD; \
177:     } else if ((*(PetscFortranAddr*)vin) == PETSC_VIEWER_STDOUT_SELF_FORTRAN) { \
178:       v = PETSC_VIEWER_STDOUT_SELF; \
179:     } else if ((*(PetscFortranAddr*)vin) == PETSC_VIEWER_STDERR_WORLD_FORTRAN) { \
180:       v = PETSC_VIEWER_STDERR_WORLD; \
181:     } else if ((*(PetscFortranAddr*)vin) == PETSC_VIEWER_STDERR_SELF_FORTRAN) { \
182:       v = PETSC_VIEWER_STDERR_SELF; \
183:     } else if ((*(PetscFortranAddr*)vin) == PETSC_VIEWER_BINARY_WORLD_FORTRAN) { \
184:       v = PETSC_VIEWER_BINARY_WORLD; \
185:     } else if ((*(PetscFortranAddr*)vin) == PETSC_VIEWER_BINARY_SELF_FORTRAN) { \
186:       v = PETSC_VIEWER_BINARY_SELF; \
187:     } else if ((*(PetscFortranAddr*)vin) == PETSC_VIEWER_MATLAB_WORLD_FORTRAN) { \
188:       v = PETSC_VIEWER_BINARY_WORLD; \
189:     } else if ((*(PetscFortranAddr*)vin) == PETSC_VIEWER_MATLAB_SELF_FORTRAN) { \
190:       v = PETSC_VIEWER_BINARY_SELF; \
191:     PetscPatchDefaultViewers_Fortran_Socket(vin,v); \
192:     } else { \
193:       v = *vin; \
194:     } \
195: }

197: /*
198:       Allocates enough space to store Fortran function pointers in PETSc object
199:    that are needed by the Fortran interface.
200: */
201: #define PetscObjectAllocateFortranPointers(obj,N) do {                  \
202:     if (!((PetscObject)(obj))->fortran_func_pointers) {                 \
203:       *(N)*sizeof(void(*)(void)),&((PetscObject)(obj))->fortran_func_pointers;if (*ierr) return; \
204:       ((PetscObject)obj)->num_fortran_func_pointers = (N);              \
205:     }                                                                   \
206:   } while (0)

208: #define PetscCallFortranVoidFunction(...) do {          \
209:     PetscErrorCode 0;                            \
210:     /* the function may or may not access ierr */       \
211:     __VA_ARGS__;                                        \
212:     ierr;                                    \
213:   } while (0)

215: /* Entire function body, _ctx is a "special" variable that can be passed along */
216: #define PetscObjectUseFortranCallback_Private(obj,cid,types,args,cbclass) {                    \
217:     void (*func) types,*_ctx;                                                                  \
218:     PetscObjectGetFortranCallback((PetscObject)(obj),(cbclass),(cid),(PetscVoidFunction*)&func,&_ctx); \
219:     if (func) (*func)args;                                       \
220:     return 0;                                                                    \
221:   }
222: #define PetscObjectUseFortranCallback(obj,cid,types,args) PetscObjectUseFortranCallback_Private(obj,cid,types,args,PETSC_FORTRAN_CALLBACK_CLASS)
223: #define PetscObjectUseFortranCallbackSubType(obj,cid,types,args) PetscObjectUseFortranCallback_Private(obj,cid,types,args,PETSC_FORTRAN_CALLBACK_SUBTYPE)

225: /* Disable deprecation warnings while building Fortran wrappers */
226: #undef  PETSC_DEPRECATED_FUNCTION
227: #define PETSC_DEPRECATED_FUNCTION(arg)

229: #endif