Actual source code: fortranimpl.h
petsc-3.11.4 2019-09-28
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>
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: #ifndef PETSC_FORTRAN_CHARLEN_T
34: # define PETSC_FORTRAN_CHARLEN_T int
35: #endif
36: /*
37: This lets us map the str-len argument either, immediately following
38: the char argument (DVF on Win32) or at the end of the argument list
39: (general unix compilers)
40: */
41: #if defined(PETSC_HAVE_FORTRAN_MIXED_STR_ARG)
42: #define PETSC_MIXED_LEN(len) ,PETSC_FORTRAN_CHARLEN_T len
43: #define PETSC_END_LEN(len)
44: #define PETSC_MIXED_LEN_CALL(len) ,((PETSC_FORTRAN_CHARLEN_T)(len))
45: #define PETSC_END_LEN_CALL(len)
46: #define PETSC_MIXED_LEN_PROTO ,PETSC_FORTRAN_CHARLEN_T
47: #define PETSC_END_LEN_PROTO
48: #else
49: #define PETSC_MIXED_LEN(len)
50: #define PETSC_END_LEN(len) ,PETSC_FORTRAN_CHARLEN_T len
51: #define PETSC_MIXED_LEN_CALL(len)
52: #define PETSC_END_LEN_CALL(len) ,((PETSC_FORTRAN_CHARLEN_T)(len))
53: #define PETSC_MIXED_LEN_PROTO
54: #define PETSC_END_LEN_PROTO ,PETSC_FORTRAN_CHARLEN_T
55: #endif
57: /* --------------------------------------------------------------------*/
58: /*
59: Since Fortran does not null terminate strings we need to insure the string is null terminated before passing it
60: to C. This may require a memory allocation which is then freed with FREECHAR().
61: */
62: #define FIXCHAR(a,n,b) \
63: {\
64: if (a == PETSC_NULL_CHARACTER_Fortran) { \
65: b = a = 0; \
66: } else { \
67: while((n > 0) && (a[n-1] == ' ')) n--; \
68: *PetscMalloc1(n+1,&b); \
69: if (*ierr) return; \
70: *PetscStrncpy(b,a,n+1); \
71: if (*ierr) return; \
72: } \
73: }
74: #define FREECHAR(a,b) if (a != b) *PetscFree(b);
76: /*
77: Fortran expects any unneeded characters at the end of its strings to be filled with the blank character.
78: */
79: #define FIXRETURNCHAR(flg,a,n) \
80: if (flg) { \
81: PETSC_FORTRAN_CHARLEN_T __i; \
82: for (__i=0; __i<n && a[__i] != 0; __i++) {}; \
83: for (; __i<n; __i++) a[__i] = ' ' ; \
84: }
86: /*
87: The cast through PETSC_UINTPTR_T is so that compilers that warn about casting to/from void * to void(*)(void)
88: will not complain about these comparisons. It is not know if this works for all compilers
89: */
90: #define FORTRANNULLINTEGER(a) (((void*)(PETSC_UINTPTR_T)a) == PETSC_NULL_INTEGER_Fortran)
91: #define FORTRANNULLSCALAR(a) (((void*)(PETSC_UINTPTR_T)a) == PETSC_NULL_SCALAR_Fortran)
92: #define FORTRANNULLDOUBLE(a) (((void*)(PETSC_UINTPTR_T)a) == PETSC_NULL_DOUBLE_Fortran)
93: #define FORTRANNULLREAL(a) (((void*)(PETSC_UINTPTR_T)a) == PETSC_NULL_REAL_Fortran)
94: #define FORTRANNULLBOOL(a) (((void*)(PETSC_UINTPTR_T)a) == PETSC_NULL_BOOL_Fortran)
95: #define FORTRANNULLCHARACTER(a) (((void*)(PETSC_UINTPTR_T)a) == PETSC_NULL_CHARACTER_Fortran)
96: #define FORTRANNULLFUNCTION(a) (((void(*)(void))(PETSC_UINTPTR_T)a) == PETSC_NULL_FUNCTION_Fortran)
97: #define FORTRANNULLOBJECT(a) (*(void**)(PETSC_UINTPTR_T)a == (void*)0)
99: #define CHKFORTRANNULLINTEGER(a) \
100: if (FORTRANNULLDOUBLE(a) || FORTRANNULLSCALAR(a) || FORTRANNULLREAL(a) || FORTRANNULLBOOL(a) || FORTRANNULLFUNCTION(a) || FORTRANNULLCHARACTER(a)) { \
101: PetscError(PETSC_COMM_SELF,__LINE__,"fortran_interface_unknown_file",__FILE__,PETSC_ERR_ARG_WRONG,PETSC_ERROR_INITIAL, \
102: "Use PETSC_NULL_INTEGER"); *1; return; } \
103: else if (FORTRANNULLINTEGER(a)) { a = NULL; }
105: #define CHKFORTRANNULLSCALAR(a) \
106: if (FORTRANNULLINTEGER(a) || FORTRANNULLDOUBLE(a) || FORTRANNULLREAL(a) || FORTRANNULLBOOL(a) || FORTRANNULLFUNCTION(a) || FORTRANNULLCHARACTER(a)) { \
107: PetscError(PETSC_COMM_SELF,__LINE__,"fortran_interface_unknown_file",__FILE__,PETSC_ERR_ARG_WRONG,PETSC_ERROR_INITIAL, \
108: "Use PETSC_NULL_SCALAR"); *1; return; } \
109: else if (FORTRANNULLSCALAR(a)) { a = NULL; }
111: #define CHKFORTRANNULLDOUBLE(a) \
112: if (FORTRANNULLINTEGER(a) || FORTRANNULLSCALAR(a) || FORTRANNULLREAL(a) || FORTRANNULLBOOL(a) || FORTRANNULLFUNCTION(a) || FORTRANNULLCHARACTER(a)) { \
113: PetscError(PETSC_COMM_SELF,__LINE__,"fortran_interface_unknown_file",__FILE__,PETSC_ERR_ARG_WRONG,PETSC_ERROR_INITIAL, \
114: "Use PETSC_NULL_DOUBLE"); *1; return; } \
115: else if (FORTRANNULLDOUBLE(a)) { a = NULL; }
117: #define CHKFORTRANNULLREAL(a) \
118: if (FORTRANNULLINTEGER(a) || FORTRANNULLDOUBLE(a) || FORTRANNULLSCALAR(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_REAL"); *1; return; } \
121: else if (FORTRANNULLREAL(a)) { a = NULL; }
123: #define CHKFORTRANNULLOBJECT(a) \
124: if (FORTRANNULLINTEGER(a) || FORTRANNULLDOUBLE(a) || FORTRANNULLSCALAR(a) || FORTRANNULLREAL(a) || FORTRANNULLBOOL(a) || FORTRANNULLFUNCTION(a) || FORTRANNULLCHARACTER(a)) { \
125: PetscError(PETSC_COMM_SELF,__LINE__,"fortran_interface_unknown_file",__FILE__,PETSC_ERR_ARG_WRONG,PETSC_ERROR_INITIAL, \
126: "Use PETSC_NULL_XXX where XXX is the name of a particular object class"); *1; return; } \
127: else if (*(void**)a == (void*)0) { a = NULL; }
129: #define CHKFORTRANNULLBOOL(a) \
130: if (FORTRANNULLSCALAR(a) || FORTRANNULLINTEGER(a) || FORTRANNULLDOUBLE(a) || FORTRANNULLSCALAR(a) || FORTRANNULLREAL(a) || FORTRANNULLFUNCTION(a) || FORTRANNULLCHARACTER(a)) { \
131: PetscError(PETSC_COMM_SELF,__LINE__,"fortran_interface_unknown_file",__FILE__,PETSC_ERR_ARG_WRONG,PETSC_ERROR_INITIAL, \
132: "Use PETSC_NULL_BOOL"); *1; return; } \
133: else if (FORTRANNULLBOOL(a)) { a = NULL; }
135: #define CHKFORTRANNULLFUNCTION(a) \
136: if (FORTRANNULLOBJECT(a) || FORTRANNULLSCALAR(a) || FORTRANNULLDOUBLE(a) || FORTRANNULLREAL(a) || FORTRANNULLINTEGER(a) || FORTRANNULLBOOL(a) || FORTRANNULLCHARACTER(a)) { \
137: PetscError(PETSC_COMM_SELF,__LINE__,"fortran_interface_unknown_file",__FILE__,PETSC_ERR_ARG_WRONG,PETSC_ERROR_INITIAL, \
138: "Use PETSC_NULL_FUNCTION"); *1; return; } \
139: else if (FORTRANNULLFUNCTION(a)) { a = NULL; }
143: /*
144: Variable type where we stash PETSc object pointers in Fortran.
145: */
146: typedef PETSC_UINTPTR_T PetscFortranAddr;
148: /*
149: These are used to support the default viewers that are
150: created at run time, in C using the , trick.
152: The numbers here must match the numbers in include/petsc/finclude/petscsys.h
153: */
154: #define PETSC_VIEWER_DRAW_WORLD_FORTRAN 4
155: #define PETSC_VIEWER_DRAW_SELF_FORTRAN 5
156: #define PETSC_VIEWER_SOCKET_WORLD_FORTRAN 6
157: #define PETSC_VIEWER_SOCKET_SELF_FORTRAN 7
158: #define PETSC_VIEWER_STDOUT_WORLD_FORTRAN 8
159: #define PETSC_VIEWER_STDOUT_SELF_FORTRAN 9
160: #define PETSC_VIEWER_STDERR_WORLD_FORTRAN 10
161: #define PETSC_VIEWER_STDERR_SELF_FORTRAN 11
162: #define PETSC_VIEWER_BINARY_WORLD_FORTRAN 12
163: #define PETSC_VIEWER_BINARY_SELF_FORTRAN 13
164: #define PETSC_VIEWER_MATLAB_WORLD_FORTRAN 14
165: #define PETSC_VIEWER_MATLAB_SELF_FORTRAN 15
167: #if defined (PETSC_USE_SOCKET_VIEWER)
168: #define PetscPatchDefaultViewers_Fortran_Socket(vin,v) \
169: } else if ((*(PetscFortranAddr*)vin) == PETSC_VIEWER_SOCKET_WORLD_FORTRAN) { \
170: v = PETSC_VIEWER_SOCKET_WORLD; \
171: } else if ((*(PetscFortranAddr*)vin) == PETSC_VIEWER_SOCKET_SELF_FORTRAN) { \
172: v = PETSC_VIEWER_SOCKET_SELF
173: #else
174: #define PetscPatchDefaultViewers_Fortran_Socket(vin,v)
175: #endif
177: #define PetscPatchDefaultViewers_Fortran(vin,v) \
178: { \
179: if ((*(PetscFortranAddr*)vin) == PETSC_VIEWER_DRAW_WORLD_FORTRAN) { \
180: v = PETSC_VIEWER_DRAW_WORLD; \
181: } else if ((*(PetscFortranAddr*)vin) == PETSC_VIEWER_DRAW_SELF_FORTRAN) { \
182: v = PETSC_VIEWER_DRAW_SELF; \
183: } else if ((*(PetscFortranAddr*)vin) == PETSC_VIEWER_STDOUT_WORLD_FORTRAN) { \
184: v = PETSC_VIEWER_STDOUT_WORLD; \
185: } else if ((*(PetscFortranAddr*)vin) == PETSC_VIEWER_STDOUT_SELF_FORTRAN) { \
186: v = PETSC_VIEWER_STDOUT_SELF; \
187: } else if ((*(PetscFortranAddr*)vin) == PETSC_VIEWER_STDERR_WORLD_FORTRAN) { \
188: v = PETSC_VIEWER_STDERR_WORLD; \
189: } else if ((*(PetscFortranAddr*)vin) == PETSC_VIEWER_STDERR_SELF_FORTRAN) { \
190: v = PETSC_VIEWER_STDERR_SELF; \
191: } else if ((*(PetscFortranAddr*)vin) == PETSC_VIEWER_BINARY_WORLD_FORTRAN) { \
192: v = PETSC_VIEWER_BINARY_WORLD; \
193: } else if ((*(PetscFortranAddr*)vin) == PETSC_VIEWER_BINARY_SELF_FORTRAN) { \
194: v = PETSC_VIEWER_BINARY_SELF; \
195: } else if ((*(PetscFortranAddr*)vin) == PETSC_VIEWER_MATLAB_WORLD_FORTRAN) { \
196: v = PETSC_VIEWER_BINARY_WORLD; \
197: } else if ((*(PetscFortranAddr*)vin) == PETSC_VIEWER_MATLAB_SELF_FORTRAN) { \
198: v = PETSC_VIEWER_BINARY_SELF; \
199: PetscPatchDefaultViewers_Fortran_Socket(vin,v); \
200: } else { \
201: v = *vin; \
202: } \
203: }
205: /*
206: Allocates enough space to store Fortran function pointers in PETSc object
207: that are needed by the Fortran interface.
208: */
209: #define PetscObjectAllocateFortranPointers(obj,N) do { \
210: if (!((PetscObject)(obj))->fortran_func_pointers) { \
211: *PetscMalloc((N)*sizeof(void(*)(void)),&((PetscObject)(obj))->fortran_func_pointers);if (*ierr) return; \
212: *PetscMemzero(((PetscObject)(obj))->fortran_func_pointers,(N)*sizeof(void(*)(void)));if (*ierr) return; \
213: ((PetscObject)obj)->num_fortran_func_pointers = (N); \
214: } \
215: } while (0)
217: /* Entire function body, _ctx is a "special" variable that can be passed along */
218: #define PetscObjectUseFortranCallback_Private(obj,cid,types,args,cbclass) { \
220: void (PETSC_STDCALL *func) types,*_ctx; \
222: PetscObjectGetFortranCallback((PetscObject)(obj),(cbclass),(cid),(PetscVoidFunction*)&func,&_ctx); \
223: if (func) {(*func)args;} \
224: return(0); \
225: }
226: #define PetscObjectUseFortranCallback(obj,cid,types,args) PetscObjectUseFortranCallback_Private(obj,cid,types,args,PETSC_FORTRAN_CALLBACK_CLASS)
227: #define PetscObjectUseFortranCallbackSubType(obj,cid,types,args) PetscObjectUseFortranCallback_Private(obj,cid,types,args,PETSC_FORTRAN_CALLBACK_SUBTYPE)
229: /* Disable deprecation warnings while building Fortran wrappers */
230: #undef PETSC_DEPRECATED
231: #define PETSC_DEPRECATED(arg)
233: #endif