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>

      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;
     22: /*  ----------------------------------------------------------------------*/
     23: /*
     24:    PETSc object C pointers are stored directly as
     25:    Fortran integer*4 or *8 depending on the size of pointers.
     26: */

     28: /* --------------------------------------------------------------------*/
     29: /*
     30:     Since Fortran does not null terminate strings we need to insure the string is null terminated before passing it
     31:     to C. This may require a memory allocation which is then freed with FREECHAR().
     32: */
     33: #define FIXCHAR(a,n,b) \
     34: {\
     35:   if (a == PETSC_NULL_CHARACTER_Fortran) { \
     36:     b = a = NULL; \
     37:   } else { \
     38:     while ((n > 0) && (a[n-1] == ' ')) n--; \
     39:     *PetscMalloc1(n+1,&b); \
     40:     if (*ierr) return; \
     41:     *PetscStrncpy(b,a,n+1); \
     42:     if (*ierr) return; \
     43:   } \
     44: }
     45: #define FREECHAR(a,b) if (a != b) *PetscFree(b);

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

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

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

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

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

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

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

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

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

    113: #define CHKFORTRANNULLMPICOMM(a)  \
    114:   if (FORTRANNULLMPICOMM(a)) { a = NULL; } \
    115:   else if (FORTRANNULLINTEGER(a) || FORTRANNULLDOUBLE(a) || FORTRANNULLSCALAR(a) || FORTRANNULLREAL(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_MPI_COMM"); *1; return; }

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

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

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

    132: /*
    133:     Variable type where we stash PETSc object pointers in Fortran.
    134: */
    135: typedef PETSC_UINTPTR_T PetscFortranAddr;

    137: /*
    138:     These are used to support the default viewers that are
    139:   created at run time, in C using the , trick.

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

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

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

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

    206: /* Entire function body, _ctx is a "special" variable that can be passed along */
    207: #define PetscObjectUseFortranCallback_Private(obj,cid,types,args,cbclass) { \
    209:     void (*func) types,*_ctx;                             \
    211:     PetscObjectGetFortranCallback((PetscObject)(obj),(cbclass),(cid),(PetscVoidFunction*)&func,&_ctx); \
    212:     if (func) {(*func)args;}                              \
    213:     return(0);                                             \
    214:   }
    215: #define PetscObjectUseFortranCallback(obj,cid,types,args) PetscObjectUseFortranCallback_Private(obj,cid,types,args,PETSC_FORTRAN_CALLBACK_CLASS)
    216: #define PetscObjectUseFortranCallbackSubType(obj,cid,types,args) PetscObjectUseFortranCallback_Private(obj,cid,types,args,PETSC_FORTRAN_CALLBACK_SUBTYPE)

    218: /* Disable deprecation warnings while building Fortran wrappers */
    219: #undef  PETSC_DEPRECATED_FUNCTION
    220: #define PETSC_DEPRECATED_FUNCTION(arg)

    222: #endif