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