Actual source code: fortranimpl.h
petsc-3.12.4 2020-02-04
Report Typos and Errors

      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_FUNCTION
    231: #define PETSC_DEPRECATED_FUNCTION(arg)

    233: #endif