Actual source code: fortranimpl.h

petsc-3.9.1 2018-04-29
Report Typos and Errors

  2: /* This file contains info for the use of PETSc Fortran interface stubs */
  3: #if !defined(_FORTRANIMPL_H)
  4: #define _FORTRANIMPL_H

  6:  #include <petsc/private/petscimpl.h>

  8: /* PETSC_STDCALL is defined on some Microsoft Windows systems and is used for functions compiled by the Fortran compiler */
  9: #if !defined(PETSC_STDCALL)
 10: #define PETSC_STDCALL
 11: #endif
 12: PETSC_EXTERN PetscErrorCode PetscMPIFortranDatatypeToC(MPI_Fint,MPI_Datatype*);

 14: PETSC_EXTERN PetscErrorCode PetscScalarAddressToFortran(PetscObject,PetscInt,PetscScalar*,PetscScalar*,PetscInt,size_t*);
 15: PETSC_EXTERN PetscErrorCode PetscScalarAddressFromFortran(PetscObject,PetscScalar*,size_t,PetscInt,PetscScalar **);
 16: PETSC_EXTERN size_t         PetscIntAddressToFortran(const PetscInt*,const PetscInt*);
 17: PETSC_EXTERN PetscInt        *PetscIntAddressFromFortran(const PetscInt*,size_t);
 18: PETSC_EXTERN char   *PETSC_NULL_CHARACTER_Fortran;
 19: PETSC_EXTERN void    *PETSC_NULL_INTEGER_Fortran;
 20: PETSC_EXTERN void    *PETSC_NULL_SCALAR_Fortran;
 21: PETSC_EXTERN void    *PETSC_NULL_DOUBLE_Fortran;
 22: PETSC_EXTERN void    *PETSC_NULL_REAL_Fortran;
 23: PETSC_EXTERN void    *PETSC_NULL_BOOL_Fortran;
 24: PETSC_EXTERN void (*PETSC_NULL_FUNCTION_Fortran)(void);
 25: /*  ----------------------------------------------------------------------*/
 26: /*
 27:    PETSc object C pointers are stored directly as
 28:    Fortran integer*4 or *8 depending on the size of pointers.
 29: */


 32: /* --------------------------------------------------------------------*/
 33: /*
 34:     This lets us map the str-len argument either, immediately following
 35:     the char argument (DVF on Win32) or at the end of the argument list
 36:     (general unix compilers)
 37: */
 38: #if defined(PETSC_HAVE_FORTRAN_MIXED_STR_ARG)
 39: #define PETSC_MIXED_LEN(len) ,int len
 40: #define PETSC_END_LEN(len)
 41: #define PETSC_MIXED_LEN_CALL(len) ,len
 42: #define PETSC_END_LEN_CALL(len)
 43: #define PETSC_MIXED_LEN_PROTO ,int
 44: #define PETSC_END_LEN_PROTO
 45: #else
 46: #define PETSC_MIXED_LEN(len)
 47: #define PETSC_END_LEN(len)   ,int len
 48: #define PETSC_MIXED_LEN_CALL(len)
 49: #define PETSC_END_LEN_CALL(len)   ,len
 50: #define PETSC_MIXED_LEN_PROTO
 51: #define PETSC_END_LEN_PROTO   ,int
 52: #endif

 54: /* --------------------------------------------------------------------*/
 55: /*
 56:     Since Fortran does not null terminate strings we need to insure the string is null terminated before passing it
 57:     to C. This may require a memory allocation which is then freed with FREECHAR().
 58: */
 59: #define FIXCHAR(a,n,b) \
 60: {\
 61:   if (a == PETSC_NULL_CHARACTER_Fortran) { \
 62:     b = a = 0; \
 63:   } else { \
 64:     while((n > 0) && (a[n-1] == ' ')) n--; \
 65:     *PetscMalloc1(n+1,&b); \
 66:     if (*ierr) return; \
 67:     *PetscStrncpy(b,a,n+1); \
 68:     if (*ierr) return; \
 69:   } \
 70: }
 71: #define FREECHAR(a,b) if (a != b) *PetscFree(b);

 73: /*
 74:     Fortran expects any unneeded characters at the end of its strings to be filled with the blank character.
 75: */
 76: #define FIXRETURNCHAR(flg,a,n)               \
 77: if (flg) {                                   \
 78:   int __i;                                   \
 79:   for (__i=0; __i<n && a[__i] != 0; __i++) {};  \
 80:   for (; __i<n; __i++) a[__i] = ' ' ; \
 81: }

 83: /*
 84:     The cast through PETSC_UINTPTR_T is so that compilers that warn about casting to/from void * to void(*)(void)
 85:     will not complain about these comparisons. It is not know if this works for all compilers
 86: */
 87: #define FORTRANNULLINTEGER(a)   (((void*)(PETSC_UINTPTR_T)a) == PETSC_NULL_INTEGER_Fortran)
 88: #define FORTRANNULLSCALAR(a)    (((void*)(PETSC_UINTPTR_T)a) == PETSC_NULL_SCALAR_Fortran)
 89: #define FORTRANNULLDOUBLE(a)    (((void*)(PETSC_UINTPTR_T)a) == PETSC_NULL_DOUBLE_Fortran)
 90: #define FORTRANNULLREAL(a)      (((void*)(PETSC_UINTPTR_T)a) == PETSC_NULL_REAL_Fortran)
 91: #define FORTRANNULLBOOL(a)      (((void*)(PETSC_UINTPTR_T)a) == PETSC_NULL_BOOL_Fortran)
 92: #define FORTRANNULLCHARACTER(a) (((void*)(PETSC_UINTPTR_T)a) == PETSC_NULL_CHARACTER_Fortran)
 93: #define FORTRANNULLFUNCTION(a)  (((void(*)(void))(PETSC_UINTPTR_T)a) == PETSC_NULL_FUNCTION_Fortran)
 94: #define FORTRANNULLOBJECT(a)    (*(void**)(PETSC_UINTPTR_T)a == (void*)-1)

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

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

108: #define CHKFORTRANNULLDOUBLE(a)  \
109:   if (FORTRANNULLINTEGER(a) || FORTRANNULLSCALAR(a) || FORTRANNULLREAL(a)  || FORTRANNULLBOOL(a) || FORTRANNULLFUNCTION(a) || FORTRANNULLCHARACTER(a)) { \
110:     PetscError(PETSC_COMM_SELF,__LINE__,"fortran_interface_unknown_file",__FILE__,PETSC_ERR_ARG_WRONG,PETSC_ERROR_INITIAL, \
111:     "Use PETSC_NULL_DOUBLE"); *1; return; } \
112:   else if (FORTRANNULLDOUBLE(a)) { a = NULL; }

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

120: /*
121:    The next two macros can generate false positives for Valgrind if the object passed
122:    in has never been set before because the location (void**)a has never had a value
123:    set to it. To prevent the false positive in the Fortran code one can initialize the
124:    object with a = tXXX(0); for example a = tVec(0)
125: */
126: #define CHKFORTRANNULLOBJECT(a)  \
127:   if (FORTRANNULLINTEGER(a) || FORTRANNULLDOUBLE(a) || FORTRANNULLSCALAR(a) || FORTRANNULLREAL(a) || FORTRANNULLBOOL(a) || FORTRANNULLFUNCTION(a) || FORTRANNULLCHARACTER(a)) { \
128:     PetscError(PETSC_COMM_SELF,__LINE__,"fortran_interface_unknown_file",__FILE__,PETSC_ERR_ARG_WRONG,PETSC_ERROR_INITIAL, \
129:     "Use PETSC_NULL_XXX where XXX is the name of a particular object class"); *1; return; } \
130:   else if (*(void**)a == (void*)-1) { a = NULL; }

132: PETSC_EXTERN void  *PETSCNULLPOINTERADDRESS;

134: #define CHKFORTRANNULLOBJECTDEREFERENCE(a)  \
135:   if (FORTRANNULLSCALAR(a) || FORTRANNULLDOUBLE(a) || FORTRANNULLREAL(a) || FORTRANNULLINTEGER(a) || FORTRANNULLBOOL(a) || FORTRANNULLFUNCTION(a) || FORTRANNULLCHARACTER(a)) { \
136:     PetscError(PETSC_COMM_SELF,__LINE__,"fortran_interface_unknown_file",__FILE__,PETSC_ERR_ARG_WRONG,PETSC_ERROR_INITIAL, \
137:     "Use PETSC_NULL_XXX where XXX is the name of a particular object class"); *1; return; } \
138:   else if (*(void**)a == (void*)-1) { *((void***)&a) = &PETSCNULLPOINTERADDRESS; }


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

147: #define CHKFORTRANNULLFUNCTION(a)  \
148:   if (FORTRANNULLOBJECT(a) || FORTRANNULLSCALAR(a) || FORTRANNULLDOUBLE(a) || FORTRANNULLREAL(a) || FORTRANNULLINTEGER(a) || FORTRANNULLBOOL(a) || FORTRANNULLCHARACTER(a)) { \
149:     PetscError(PETSC_COMM_SELF,__LINE__,"fortran_interface_unknown_file",__FILE__,PETSC_ERR_ARG_WRONG,PETSC_ERROR_INITIAL, \
150:     "Use PETSC_NULL_FUNCTION"); *1; return; } \
151:   else if (FORTRANNULLFUNCTION(a)) { a = NULL; }



155: /*
156:     Variable type where we stash PETSc object pointers in Fortran.
157: */
158: typedef PETSC_UINTPTR_T PetscFortranAddr;

160: /*
161:     These are used to support the default viewers that are
162:   created at run time, in C using the , trick.

164:     The numbers here must match the numbers in include/petsc/finclude/petscsys.h
165: */
166: #define PETSC_VIEWER_DRAW_WORLD_FORTRAN     4
167: #define PETSC_VIEWER_DRAW_SELF_FORTRAN      5
168: #define PETSC_VIEWER_SOCKET_WORLD_FORTRAN   6
169: #define PETSC_VIEWER_SOCKET_SELF_FORTRAN    7
170: #define PETSC_VIEWER_STDOUT_WORLD_FORTRAN   8
171: #define PETSC_VIEWER_STDOUT_SELF_FORTRAN    9
172: #define PETSC_VIEWER_STDERR_WORLD_FORTRAN   10
173: #define PETSC_VIEWER_STDERR_SELF_FORTRAN    11
174: #define PETSC_VIEWER_BINARY_WORLD_FORTRAN   12
175: #define PETSC_VIEWER_BINARY_SELF_FORTRAN    13
176: #define PETSC_VIEWER_MATLAB_WORLD_FORTRAN   14
177: #define PETSC_VIEWER_MATLAB_SELF_FORTRAN    15

179: #if defined (PETSC_USE_SOCKET_VIEWER)
180: #define PetscPatchDefaultViewers_Fortran_Socket(vin,v) \
181:     } else if ((*(PetscFortranAddr*)vin) == PETSC_VIEWER_SOCKET_WORLD_FORTRAN) { \
182:       v = PETSC_VIEWER_SOCKET_WORLD; \
183:     } else if ((*(PetscFortranAddr*)vin) == PETSC_VIEWER_SOCKET_SELF_FORTRAN) { \
184:       v = PETSC_VIEWER_SOCKET_SELF
185: #else
186: #define PetscPatchDefaultViewers_Fortran_Socket(vin,v)
187: #endif

189: #define PetscPatchDefaultViewers_Fortran(vin,v) \
190: { \
191:     CHKFORTRANNULLOBJECTDEREFERENCE(vin);\
192:     if ((*(PetscFortranAddr*)vin) == PETSC_VIEWER_DRAW_WORLD_FORTRAN) { \
193:       v = PETSC_VIEWER_DRAW_WORLD; \
194:     } else if ((*(PetscFortranAddr*)vin) == PETSC_VIEWER_DRAW_SELF_FORTRAN) { \
195:       v = PETSC_VIEWER_DRAW_SELF; \
196:     } else if ((*(PetscFortranAddr*)vin) == PETSC_VIEWER_STDOUT_WORLD_FORTRAN) { \
197:       v = PETSC_VIEWER_STDOUT_WORLD; \
198:     } else if ((*(PetscFortranAddr*)vin) == PETSC_VIEWER_STDOUT_SELF_FORTRAN) { \
199:       v = PETSC_VIEWER_STDOUT_SELF; \
200:     } else if ((*(PetscFortranAddr*)vin) == PETSC_VIEWER_STDERR_WORLD_FORTRAN) { \
201:       v = PETSC_VIEWER_STDERR_WORLD; \
202:     } else if ((*(PetscFortranAddr*)vin) == PETSC_VIEWER_STDERR_SELF_FORTRAN) { \
203:       v = PETSC_VIEWER_STDERR_SELF; \
204:     } else if ((*(PetscFortranAddr*)vin) == PETSC_VIEWER_BINARY_WORLD_FORTRAN) { \
205:       v = PETSC_VIEWER_BINARY_WORLD; \
206:     } else if ((*(PetscFortranAddr*)vin) == PETSC_VIEWER_BINARY_SELF_FORTRAN) { \
207:       v = PETSC_VIEWER_BINARY_SELF; \
208:     } else if ((*(PetscFortranAddr*)vin) == PETSC_VIEWER_MATLAB_WORLD_FORTRAN) { \
209:       v = PETSC_VIEWER_BINARY_WORLD; \
210:     } else if ((*(PetscFortranAddr*)vin) == PETSC_VIEWER_MATLAB_SELF_FORTRAN) { \
211:       v = PETSC_VIEWER_BINARY_SELF; \
212:     PetscPatchDefaultViewers_Fortran_Socket(vin,v); \
213:     } else { \
214:       v = *vin; \
215:     } \
216: }

218: /*
219:       Allocates enough space to store Fortran function pointers in PETSc object
220:    that are needed by the Fortran interface.
221: */
222: #define PetscObjectAllocateFortranPointers(obj,N) do {                  \
223:     if (!((PetscObject)(obj))->fortran_func_pointers) {                 \
224:       *PetscMalloc((N)*sizeof(void(*)(void)),&((PetscObject)(obj))->fortran_func_pointers);if (*ierr) return; \
225:       *PetscMemzero(((PetscObject)(obj))->fortran_func_pointers,(N)*sizeof(void(*)(void)));if (*ierr) return; \
226:       ((PetscObject)obj)->num_fortran_func_pointers = (N);              \
227:     }                                                                   \
228:   } while (0)

230: /* Entire function body, _ctx is a "special" variable that can be passed along */
231: #define PetscObjectUseFortranCallback_Private(obj,cid,types,args,cbclass) { \
233:     void (PETSC_STDCALL *func) types,*_ctx;                             \
235:     PetscObjectGetFortranCallback((PetscObject)(obj),(cbclass),(cid),(PetscVoidFunction*)&func,&_ctx); \
236:     if (func) {(*func)args;}                              \
237:     return(0);                                             \
238:   }
239: #define PetscObjectUseFortranCallback(obj,cid,types,args) PetscObjectUseFortranCallback_Private(obj,cid,types,args,PETSC_FORTRAN_CALLBACK_CLASS)
240: #define PetscObjectUseFortranCallbackSubType(obj,cid,types,args) PetscObjectUseFortranCallback_Private(obj,cid,types,args,PETSC_FORTRAN_CALLBACK_SUBTYPE)

242: /* Disable deprecation warnings while building Fortran wrappers */
243: #undef  PETSC_DEPRECATED
244: #define PETSC_DEPRECATED(arg)

246: #endif