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_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: /* ----------------------------------------------------------------------*/
22: /*
23: PETSc object C pointers are stored directly as
24: Fortran integer*4 or *8 depending on the size of pointers.
25: */
27: /* --------------------------------------------------------------------*/
28: /*
29: Since Fortran does not null terminate strings we need to insure the string is null terminated before passing it
30: to C. This may require a memory allocation which is then freed with FREECHAR().
31: */
32: #define FIXCHAR(a,n,b) \ 33: {\ 34: if (a == PETSC_NULL_CHARACTER_Fortran) { \ 35: b = a = NULL; \ 36: } else { \ 37: while ((n > 0) && (a[n-1] == ' ')) n--; \ 38: *PetscMalloc1(n+1,&b); \ 39: if (*ierr) return; \ 40: *PetscStrncpy(b,a,n+1); \ 41: if (*ierr) return; \ 42: } \ 43: } 44: #define FREECHAR(a,b) if (a != b) *PetscFree(b); 46: /*
47: Fortran expects any unneeded characters at the end of its strings to be filled with the blank character.
48: */
49: #define FIXRETURNCHAR(flg,a,n) \ 50: if (flg) { \ 51: PETSC_FORTRAN_CHARLEN_T __i; \ 52: for (__i=0; __i<n && a[__i] != 0; __i++) {}; \ 53: for (; __i<n; __i++) a[__i] = ' ' ; \ 54: } 56: /*
57: The cast through PETSC_UINTPTR_T is so that compilers that warn about casting to/from void * to void(*)(void)
58: will not complain about these comparisons. It is not know if this works for all compilers
59: */
60: #define FORTRANNULLINTEGER(a) (((void*)(PETSC_UINTPTR_T)a) == PETSC_NULL_INTEGER_Fortran) 61: #define FORTRANNULLSCALAR(a) (((void*)(PETSC_UINTPTR_T)a) == PETSC_NULL_SCALAR_Fortran) 62: #define FORTRANNULLDOUBLE(a) (((void*)(PETSC_UINTPTR_T)a) == PETSC_NULL_DOUBLE_Fortran) 63: #define FORTRANNULLREAL(a) (((void*)(PETSC_UINTPTR_T)a) == PETSC_NULL_REAL_Fortran) 64: #define FORTRANNULLBOOL(a) (((void*)(PETSC_UINTPTR_T)a) == PETSC_NULL_BOOL_Fortran) 65: #define FORTRANNULLCHARACTER(a) (((void*)(PETSC_UINTPTR_T)a) == PETSC_NULL_CHARACTER_Fortran) 66: #define FORTRANNULLFUNCTION(a) (((void(*)(void))(PETSC_UINTPTR_T)a) == PETSC_NULL_FUNCTION_Fortran) 67: #define FORTRANNULLOBJECT(a) (*(void**)(PETSC_UINTPTR_T)a == (void*)0) 69: #define CHKFORTRANNULLINTEGER(a) \ 70: if (FORTRANNULLDOUBLE(a) || FORTRANNULLSCALAR(a) || FORTRANNULLREAL(a) || FORTRANNULLBOOL(a) || FORTRANNULLFUNCTION(a) || FORTRANNULLCHARACTER(a)) { \ 71: PetscError(PETSC_COMM_SELF,__LINE__,"fortran_interface_unknown_file",__FILE__,PETSC_ERR_ARG_WRONG,PETSC_ERROR_INITIAL, \ 72: "Use PETSC_NULL_INTEGER"); *1; return; } \ 73: else if (FORTRANNULLINTEGER(a)) { a = NULL; } 75: #define CHKFORTRANNULLSCALAR(a) \ 76: if (FORTRANNULLINTEGER(a) || FORTRANNULLDOUBLE(a) || FORTRANNULLREAL(a) || FORTRANNULLBOOL(a) || FORTRANNULLFUNCTION(a) || FORTRANNULLCHARACTER(a)) { \ 77: PetscError(PETSC_COMM_SELF,__LINE__,"fortran_interface_unknown_file",__FILE__,PETSC_ERR_ARG_WRONG,PETSC_ERROR_INITIAL, \ 78: "Use PETSC_NULL_SCALAR"); *1; return; } \ 79: else if (FORTRANNULLSCALAR(a)) { a = NULL; } 81: #define CHKFORTRANNULLDOUBLE(a) \ 82: if (FORTRANNULLINTEGER(a) || FORTRANNULLSCALAR(a) || FORTRANNULLREAL(a) || FORTRANNULLBOOL(a) || FORTRANNULLFUNCTION(a) || FORTRANNULLCHARACTER(a)) { \ 83: PetscError(PETSC_COMM_SELF,__LINE__,"fortran_interface_unknown_file",__FILE__,PETSC_ERR_ARG_WRONG,PETSC_ERROR_INITIAL, \ 84: "Use PETSC_NULL_DOUBLE"); *1; return; } \ 85: else if (FORTRANNULLDOUBLE(a)) { a = NULL; } 87: #define CHKFORTRANNULLREAL(a) \ 88: if (FORTRANNULLINTEGER(a) || FORTRANNULLDOUBLE(a) || FORTRANNULLSCALAR(a) || FORTRANNULLBOOL(a) || FORTRANNULLFUNCTION(a) || FORTRANNULLCHARACTER(a)) { \ 89: PetscError(PETSC_COMM_SELF,__LINE__,"fortran_interface_unknown_file",__FILE__,PETSC_ERR_ARG_WRONG,PETSC_ERROR_INITIAL, \ 90: "Use PETSC_NULL_REAL"); *1; return; } \ 91: else if (FORTRANNULLREAL(a)) { a = NULL; } 93: #define CHKFORTRANNULLOBJECT(a) \ 94: if (FORTRANNULLINTEGER(a) || FORTRANNULLDOUBLE(a) || FORTRANNULLSCALAR(a) || FORTRANNULLREAL(a) || FORTRANNULLBOOL(a) || FORTRANNULLFUNCTION(a) || FORTRANNULLCHARACTER(a)) { \ 95: PetscError(PETSC_COMM_SELF,__LINE__,"fortran_interface_unknown_file",__FILE__,PETSC_ERR_ARG_WRONG,PETSC_ERROR_INITIAL, \ 96: "Use PETSC_NULL_XXX where XXX is the name of a particular object class"); *1; return; } \ 97: else if (*(void**)a == (void*)0) { a = NULL; } 99: #define CHKFORTRANNULLBOOL(a) \100: if (FORTRANNULLSCALAR(a) || FORTRANNULLINTEGER(a) || FORTRANNULLDOUBLE(a) || FORTRANNULLSCALAR(a) || FORTRANNULLREAL(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_BOOL"); *1; return; } \103: else if (FORTRANNULLBOOL(a)) { a = NULL; }105: #define CHKFORTRANNULLFUNCTION(a) \106: if (FORTRANNULLOBJECT(a) || FORTRANNULLSCALAR(a) || FORTRANNULLDOUBLE(a) || FORTRANNULLREAL(a) || FORTRANNULLINTEGER(a) || FORTRANNULLBOOL(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_FUNCTION"); *1; return; } \109: else if (FORTRANNULLFUNCTION(a)) { a = NULL; }111: /* The two macros are used at the begining and end of PETSc object Fortran destroy routines XxxDestroy(). -2 is in consistent with
112: the one used in checkFortranTypeInitialize() at compilersFortran.py.
113: */
115: /* In the begining 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() */
116: #define PETSC_FORTRAN_OBJECT_F_DESTROYED_TO_C_NULL(a) do {if (*((void**)(a)) == (void*)-2) *(a) = NULL;} while (0)118: /* After C XxxDestroy(a) is called, change a's state from NULL to destroyed, so that it can be used/destroyed again by Fortran.
119: E.g., in VecScatterCreateToAll(x,vscat,seq,ierr), if seq = PETSC_NULL_VEC, petsc won't create seq. But if seq is a
120: destroyed object (e.g., as a result of a previous Fortran VecDestroy), petsc will create seq.
121: */
122: #define PETSC_FORTRAN_OBJECT_C_NULL_TO_F_DESTROYED(a) do {*((void**)(a)) = (void*)-2;} while (0)124: /*
125: Variable type where we stash PETSc object pointers in Fortran.
126: */
127: typedef PETSC_UINTPTR_T PetscFortranAddr;
129: /*
130: These are used to support the default viewers that are
131: created at run time, in C using the , trick.
133: The numbers here must match the numbers in include/petsc/finclude/petscsys.h
134: */
135: #define PETSC_VIEWER_DRAW_WORLD_FORTRAN 4136: #define PETSC_VIEWER_DRAW_SELF_FORTRAN 5137: #define PETSC_VIEWER_SOCKET_WORLD_FORTRAN 6138: #define PETSC_VIEWER_SOCKET_SELF_FORTRAN 7139: #define PETSC_VIEWER_STDOUT_WORLD_FORTRAN 8140: #define PETSC_VIEWER_STDOUT_SELF_FORTRAN 9141: #define PETSC_VIEWER_STDERR_WORLD_FORTRAN 10142: #define PETSC_VIEWER_STDERR_SELF_FORTRAN 11143: #define PETSC_VIEWER_BINARY_WORLD_FORTRAN 12144: #define PETSC_VIEWER_BINARY_SELF_FORTRAN 13145: #define PETSC_VIEWER_MATLAB_WORLD_FORTRAN 14146: #define PETSC_VIEWER_MATLAB_SELF_FORTRAN 15148: #if defined (PETSC_USE_SOCKET_VIEWER)
149: #define PetscPatchDefaultViewers_Fortran_Socket(vin,v) \150: } else if ((*(PetscFortranAddr*)vin) == PETSC_VIEWER_SOCKET_WORLD_FORTRAN) { \151: v = PETSC_VIEWER_SOCKET_WORLD; \152: } else if ((*(PetscFortranAddr*)vin) == PETSC_VIEWER_SOCKET_SELF_FORTRAN) { \153: v = PETSC_VIEWER_SOCKET_SELF154: #else
155: #define PetscPatchDefaultViewers_Fortran_Socket(vin,v)156: #endif
158: #define PetscPatchDefaultViewers_Fortran(vin,v) \159: { \160: if ((*(PetscFortranAddr*)vin) == PETSC_VIEWER_DRAW_WORLD_FORTRAN) { \161: v = PETSC_VIEWER_DRAW_WORLD; \162: } else if ((*(PetscFortranAddr*)vin) == PETSC_VIEWER_DRAW_SELF_FORTRAN) { \163: v = PETSC_VIEWER_DRAW_SELF; \164: } else if ((*(PetscFortranAddr*)vin) == PETSC_VIEWER_STDOUT_WORLD_FORTRAN) { \165: v = PETSC_VIEWER_STDOUT_WORLD; \166: } else if ((*(PetscFortranAddr*)vin) == PETSC_VIEWER_STDOUT_SELF_FORTRAN) { \167: v = PETSC_VIEWER_STDOUT_SELF; \168: } else if ((*(PetscFortranAddr*)vin) == PETSC_VIEWER_STDERR_WORLD_FORTRAN) { \169: v = PETSC_VIEWER_STDERR_WORLD; \170: } else if ((*(PetscFortranAddr*)vin) == PETSC_VIEWER_STDERR_SELF_FORTRAN) { \171: v = PETSC_VIEWER_STDERR_SELF; \172: } else if ((*(PetscFortranAddr*)vin) == PETSC_VIEWER_BINARY_WORLD_FORTRAN) { \173: v = PETSC_VIEWER_BINARY_WORLD; \174: } else if ((*(PetscFortranAddr*)vin) == PETSC_VIEWER_BINARY_SELF_FORTRAN) { \175: v = PETSC_VIEWER_BINARY_SELF; \176: } else if ((*(PetscFortranAddr*)vin) == PETSC_VIEWER_MATLAB_WORLD_FORTRAN) { \177: v = PETSC_VIEWER_BINARY_WORLD; \178: } else if ((*(PetscFortranAddr*)vin) == PETSC_VIEWER_MATLAB_SELF_FORTRAN) { \179: v = PETSC_VIEWER_BINARY_SELF; \180: PetscPatchDefaultViewers_Fortran_Socket(vin,v); \181: } else { \182: v = *vin; \183: } \184: }186: /*
187: Allocates enough space to store Fortran function pointers in PETSc object
188: that are needed by the Fortran interface.
189: */
190: #define PetscObjectAllocateFortranPointers(obj,N) do { \191: if (!((PetscObject)(obj))->fortran_func_pointers) { \192: *PetscMalloc((N)*sizeof(void(*)(void)),&((PetscObject)(obj))->fortran_func_pointers);if (*ierr) return; \193: *PetscMemzero(((PetscObject)(obj))->fortran_func_pointers,(N)*sizeof(void(*)(void)));if (*ierr) return; \194: ((PetscObject)obj)->num_fortran_func_pointers = (N); \195: } \196: } while (0)198: /* Entire function body, _ctx is a "special" variable that can be passed along */
199: #define PetscObjectUseFortranCallback_Private(obj,cid,types,args,cbclass) { \201: void (*func) types,*_ctx; \203: PetscObjectGetFortranCallback((PetscObject)(obj),(cbclass),(cid),(PetscVoidFunction*)&func,&_ctx); \204: if (func) {(*func)args;} \205: return(0); \206: }207: #define PetscObjectUseFortranCallback(obj,cid,types,args) PetscObjectUseFortranCallback_Private(obj,cid,types,args,PETSC_FORTRAN_CALLBACK_CLASS)208: #define PetscObjectUseFortranCallbackSubType(obj,cid,types,args) PetscObjectUseFortranCallback_Private(obj,cid,types,args,PETSC_FORTRAN_CALLBACK_SUBTYPE)210: /* Disable deprecation warnings while building Fortran wrappers */
211: #undef PETSC_DEPRECATED_FUNCTION212: #define PETSC_DEPRECATED_FUNCTION(arg)214: #endif