Actual source code: ftnimpl.h

      1: #pragma once

      3: #include <petsc/private/petscimpl.h>
      4: PETSC_INTERN PetscErrorCode PETScParseFortranArgs_Private(int *, char ***);
      5: PETSC_EXTERN PetscErrorCode PetscMPIFortranDatatypeToC(MPI_Fint, MPI_Datatype *);

      7: PETSC_EXTERN PetscErrorCode          PetscScalarAddressToFortran(PetscObject, PetscInt, PetscScalar *, PetscScalar *, PetscInt, size_t *);
      8: PETSC_EXTERN PetscErrorCode          PetscScalarAddressFromFortran(PetscObject, PetscScalar *, size_t, PetscInt, PetscScalar **);
      9: PETSC_EXTERN size_t                  PetscIntAddressToFortran(const PetscInt *, const PetscInt *);
     10: PETSC_EXTERN PetscInt               *PetscIntAddressFromFortran(const PetscInt *, size_t);
     11: PETSC_EXTERN char                   *PETSC_NULL_CHARACTER_Fortran;
     12: PETSC_EXTERN void                   *PETSC_NULL_INTEGER_Fortran;
     13: PETSC_EXTERN void                   *PETSC_NULL_SCALAR_Fortran;
     14: PETSC_EXTERN void                   *PETSC_NULL_DOUBLE_Fortran;
     15: PETSC_EXTERN void                   *PETSC_NULL_REAL_Fortran;
     16: PETSC_EXTERN void                   *PETSC_NULL_BOOL_Fortran;
     17: PETSC_EXTERN void                   *PETSC_NULL_ENUM_Fortran;
     18: PETSC_EXTERN void                   *PETSC_NULL_INTEGER_ARRAY_Fortran;
     19: PETSC_EXTERN void                   *PETSC_NULL_SCALAR_ARRAY_Fortran;
     20: PETSC_EXTERN void                   *PETSC_NULL_REAL_ARRAY_Fortran;
     21: PETSC_EXTERN void                   *PETSC_NULL_MPI_COMM_Fortran;
     22: PETSC_EXTERN void                   *PETSC_NULL_INTEGER_POINTER_Fortran;
     23: PETSC_EXTERN void                   *PETSC_NULL_SCALAR_POINTER_Fortran;
     24: PETSC_EXTERN void                   *PETSC_NULL_REAL_POINTER_Fortran;
     25: PETSC_EXTERN PetscFortranCallbackFn *PETSC_NULL_FUNCTION_Fortran;

     27: PETSC_INTERN PetscErrorCode PetscInitFortran_Private(const char *, PetscInt);

     29: /*  ----------------------------------------------------------------------*/
     30: /*
     31:    PETSc object C pointers are stored directly as
     32:    Fortran integer*4 or *8 depending on the size of pointers.
     33: */

     35: /* --------------------------------------------------------------------*/
     36: /*
     37:     Since Fortran does not null terminate strings we need to insure the string is null terminated before passing it
     38:     to C. This may require a memory allocation which is then freed with FREECHAR().
     39: */
     40: #define FIXCHAR(a, n, b) \
     41:   do { \
     42:     if ((a) == PETSC_NULL_CHARACTER_Fortran) { \
     43:       (b) = PETSC_NULLPTR; \
     44:       (a) = PETSC_NULLPTR; \
     45:     } else { \
     46:       while (((n) > 0) && ((a)[(n) - 1] == ' ')) (n)--; \
     47:       *ierr = PetscMalloc1((n) + 1, &(b)); \
     48:       if (*ierr) return; \
     49:       *ierr  = PetscMemcpy((b), (a), (n)); \
     50:       (b)[n] = '\0'; \
     51:       if (*ierr) return; \
     52:     } \
     53:   } while (0)
     54: #define FREECHAR(a, b) \
     55:   do { \
     56:     if (a != b) *ierr = PetscFree(b); \
     57:   } while (0)

     59: /*
     60:     Fortran expects any unneeded characters at the end of its strings to be filled with the blank character.
     61: */
     62: #define FIXRETURNCHAR(flg, a, n) \
     63:   do { \
     64:     if (flg) { \
     65:       PETSC_FORTRAN_CHARLEN_T __i; \
     66:       for (__i = 0; __i < n && a[__i] != 0; __i++) { }; \
     67:       for (; __i < n; __i++) a[__i] = ' '; \
     68:     } \
     69:   } while (0)

     71: /*
     72:     The cast through PETSC_UINTPTR_T is so that compilers that warn about casting to/from void * to void(*)(void)
     73:     will not complain about these comparisons. It is not know if this works for all compilers
     74: */
     75: #define FORTRANNULLINTEGERPOINTER(a) (((void *)(PETSC_UINTPTR_T)a) == PETSC_NULL_INTEGER_POINTER_Fortran)
     76: #define FORTRANNULLSCALARPOINTER(a)  (((void *)(PETSC_UINTPTR_T)a) == PETSC_NULL_SCALAR_POINTER_Fortran)
     77: #define FORTRANNULLREALPOINTER(a)    (((void *)(PETSC_UINTPTR_T)a) == PETSC_NULL_REAL_POINTER_Fortran)
     78: #define FORTRANNULLINTEGER(a)        (((void *)(PETSC_UINTPTR_T)a) == PETSC_NULL_INTEGER_Fortran || ((void *)(PETSC_UINTPTR_T)a) == PETSC_NULL_INTEGER_ARRAY_Fortran)
     79: #define FORTRANNULLSCALAR(a)         (((void *)(PETSC_UINTPTR_T)a) == PETSC_NULL_SCALAR_Fortran || ((void *)(PETSC_UINTPTR_T)a) == PETSC_NULL_SCALAR_ARRAY_Fortran)
     80: #define FORTRANNULLREAL(a)           (((void *)(PETSC_UINTPTR_T)a) == PETSC_NULL_REAL_Fortran || ((void *)(PETSC_UINTPTR_T)a) == PETSC_NULL_REAL_ARRAY_Fortran)
     81: #define FORTRANNULLDOUBLE(a)         (((void *)(PETSC_UINTPTR_T)a) == PETSC_NULL_DOUBLE_Fortran)
     82: #define FORTRANNULLBOOL(a)           (((void *)(PETSC_UINTPTR_T)a) == PETSC_NULL_BOOL_Fortran)
     83: #define FORTRANNULLENUM(a)           ((((void *)(PETSC_UINTPTR_T)a) == PETSC_NULL_ENUM_Fortran) || (((void *)(PETSC_UINTPTR_T)a) == (void *)-50))
     84: #define FORTRANNULLCHARACTER(a)      (((void *)(PETSC_UINTPTR_T)a) == PETSC_NULL_CHARACTER_Fortran)
     85: #define FORTRANNULLFUNCTION(a)       (((PetscFortranCallbackFn *)(PETSC_UINTPTR_T)a) == PETSC_NULL_FUNCTION_Fortran)
     86: #define FORTRANNULLOBJECT(a)         (*(void **)(PETSC_UINTPTR_T)a == (void *)0)
     87: #define FORTRANNULLMPICOMM(a)        (((void *)(PETSC_UINTPTR_T)a) == PETSC_NULL_MPI_COMM_Fortran)

     89: /*
     90:     A Fortran object with a value of (void*) 0 is indicated in Fortran by PETSC_NULL_XXXX, it is passed to routines to indicate the argument value is not requested or provided
     91:     similar to how NULL is used with PETSc objects in C

     93:     A Fortran object with a value of (void*) PETSC_FORTRAN_TYPE_INITIALIZE is an object that was never created or was destroyed (see checkFortranTypeInitialize()).

     95:     A Fortran object with a value of (void*) PETSC_FORTRAN_TYPE_NULL_RETURN happens when a PETSc routine returns in one of its arguments a NULL object
     96:     (it cannot return a value of (void*) PETSC_FORTRAN_TYPE_NULL because if later the returned variable is passed to a creation routine, it would think one has passed in a PETSC_NULL_XXX and error).

     98:     These three values are used because Fortran always uses pass by reference so one cannot pass a NULL address, only an address with special
     99:     values at the location.

    101:     PETSC_FORTRAN_TYPE_INITIALIZE  is also defined in include/petsc/finclude/petscsysbase.h
    102: */
    103: #define PETSC_FORTRAN_TYPE_INITIALIZE  (void *)-2
    104: #define PETSC_FORTRAN_TYPE_NULL_RETURN (void *)-3

    106: #define CHKFORTRANNULL(a) \
    107:   do { \
    108:     if (FORTRANNULLINTEGER(a) || FORTRANNULLENUM(a) || FORTRANNULLDOUBLE(a) || FORTRANNULLSCALAR(a) || FORTRANNULLREAL(a) || FORTRANNULLBOOL(a) || FORTRANNULLFUNCTION(a) || FORTRANNULLCHARACTER(a) || FORTRANNULLMPICOMM(a)) a = PETSC_NULLPTR; \
    109:   } while (0)

    111: #define CHKFORTRANNULLENUM(a) \
    112:   do { \
    113:     if (FORTRANNULLENUM(a)) a = PETSC_NULLPTR; \
    114:   } while (0)

    116: #define CHKFORTRANNULLINTEGER(a) \
    117:   do { \
    118:     if (FORTRANNULLINTEGER(a) || FORTRANNULLENUM(a)) a = PETSC_NULLPTR; \
    119:     else if (FORTRANNULLDOUBLE(a) || FORTRANNULLSCALAR(a) || FORTRANNULLREAL(a) || FORTRANNULLBOOL(a) || FORTRANNULLFUNCTION(a) || FORTRANNULLCHARACTER(a) || FORTRANNULLMPICOMM(a)) { \
    120:       *ierr = PetscError(PETSC_COMM_SELF, __LINE__, PETSC_FUNCTION_NAME, __FILE__, PETSC_ERR_ARG_WRONG, PETSC_ERROR_INITIAL, "Use PETSC_NULL_INTEGER"); \
    121:       *ierr = PETSC_ERR_ARG_BADPTR; \
    122:       return; \
    123:     } \
    124:   } while (0)

    126: #define CHKFORTRANNULLSCALAR(a) \
    127:   do { \
    128:     if (FORTRANNULLSCALAR(a)) { \
    129:       a = PETSC_NULLPTR; \
    130:     } else if (FORTRANNULLINTEGER(a) || FORTRANNULLDOUBLE(a) || FORTRANNULLREAL(a) || FORTRANNULLBOOL(a) || FORTRANNULLFUNCTION(a) || FORTRANNULLCHARACTER(a) || FORTRANNULLMPICOMM(a)) { \
    131:       *ierr = PetscError(PETSC_COMM_SELF, __LINE__, PETSC_FUNCTION_NAME, __FILE__, PETSC_ERR_ARG_WRONG, PETSC_ERROR_INITIAL, "Use PETSC_NULL_SCALAR"); \
    132:       *ierr = PETSC_ERR_ARG_BADPTR; \
    133:       return; \
    134:     } \
    135:   } while (0)

    137: #define CHKFORTRANNULLDOUBLE(a) \
    138:   do { \
    139:     if (FORTRANNULLDOUBLE(a)) { \
    140:       a = PETSC_NULLPTR; \
    141:     } else if (FORTRANNULLINTEGER(a) || FORTRANNULLSCALAR(a) || FORTRANNULLREAL(a) || FORTRANNULLBOOL(a) || FORTRANNULLFUNCTION(a) || FORTRANNULLCHARACTER(a) || FORTRANNULLMPICOMM(a)) { \
    142:       *ierr = PetscError(PETSC_COMM_SELF, __LINE__, PETSC_FUNCTION_NAME, __FILE__, PETSC_ERR_ARG_WRONG, PETSC_ERROR_INITIAL, "Use PETSC_NULL_DOUBLE"); \
    143:       *ierr = PETSC_ERR_ARG_BADPTR; \
    144:       return; \
    145:     } \
    146:   } while (0)

    148: #define CHKFORTRANNULLREAL(a) \
    149:   do { \
    150:     if (FORTRANNULLREAL(a)) { \
    151:       a = PETSC_NULLPTR; \
    152:     } else if (FORTRANNULLINTEGER(a) || FORTRANNULLDOUBLE(a) || FORTRANNULLSCALAR(a) || FORTRANNULLBOOL(a) || FORTRANNULLFUNCTION(a) || FORTRANNULLCHARACTER(a) || FORTRANNULLMPICOMM(a)) { \
    153:       *ierr = PetscError(PETSC_COMM_SELF, __LINE__, PETSC_FUNCTION_NAME, __FILE__, PETSC_ERR_ARG_WRONG, PETSC_ERROR_INITIAL, "Use PETSC_NULL_REAL"); \
    154:       *ierr = PETSC_ERR_ARG_BADPTR; \
    155:       return; \
    156:     } \
    157:   } while (0)

    159: #define CHKFORTRANNULLOBJECT(a) \
    160:   do { \
    161:     if (!(*(void **)a)) { \
    162:       a = PETSC_NULLPTR; \
    163:     } else if (FORTRANNULLINTEGER(a) || FORTRANNULLDOUBLE(a) || FORTRANNULLSCALAR(a) || FORTRANNULLREAL(a) || FORTRANNULLBOOL(a) || FORTRANNULLFUNCTION(a) || FORTRANNULLCHARACTER(a) || FORTRANNULLMPICOMM(a)) { \
    164:       *ierr = PetscError(PETSC_COMM_SELF, __LINE__, PETSC_FUNCTION_NAME, __FILE__, PETSC_ERR_ARG_WRONG, PETSC_ERROR_INITIAL, "Use PETSC_NULL_XXX where XXX is the name of a particular object class"); \
    165:       *ierr = PETSC_ERR_ARG_BADPTR; \
    166:       return; \
    167:     } \
    168:   } while (0)

    170: #define CHKFORTRANNULLBOOL(a) \
    171:   do { \
    172:     if (FORTRANNULLBOOL(a)) { \
    173:       a = PETSC_NULLPTR; \
    174:     } else if (FORTRANNULLSCALAR(a) || FORTRANNULLINTEGER(a) || FORTRANNULLDOUBLE(a) || FORTRANNULLSCALAR(a) || FORTRANNULLREAL(a) || FORTRANNULLFUNCTION(a) || FORTRANNULLCHARACTER(a) || FORTRANNULLMPICOMM(a)) { \
    175:       *ierr = PetscError(PETSC_COMM_SELF, __LINE__, PETSC_FUNCTION_NAME, __FILE__, PETSC_ERR_ARG_WRONG, PETSC_ERROR_INITIAL, "Use PETSC_NULL_BOOL"); \
    176:       *ierr = PETSC_ERR_ARG_BADPTR; \
    177:       return; \
    178:     } \
    179:   } while (0)

    181: #define CHKFORTRANNULLFUNCTION(a) \
    182:   do { \
    183:     if (FORTRANNULLFUNCTION(a)) { \
    184:       a = PETSC_NULLPTR; \
    185:     } else if (FORTRANNULLOBJECT(a) || FORTRANNULLSCALAR(a) || FORTRANNULLDOUBLE(a) || FORTRANNULLREAL(a) || FORTRANNULLINTEGER(a) || FORTRANNULLBOOL(a) || FORTRANNULLCHARACTER(a) || FORTRANNULLMPICOMM(a)) { \
    186:       *ierr = PetscError(PETSC_COMM_SELF, __LINE__, PETSC_FUNCTION_NAME, __FILE__, PETSC_ERR_ARG_WRONG, PETSC_ERROR_INITIAL, "Use PETSC_NULL_FUNCTION"); \
    187:       *ierr = PETSC_ERR_ARG_BADPTR; \
    188:       return; \
    189:     } \
    190:   } while (0)

    192: #define CHKFORTRANNULLMPICOMM(a) \
    193:   do { \
    194:     if (FORTRANNULLMPICOMM(a)) { \
    195:       a = PETSC_NULLPTR; \
    196:     } else if (FORTRANNULLINTEGER(a) || FORTRANNULLDOUBLE(a) || FORTRANNULLSCALAR(a) || FORTRANNULLREAL(a) || FORTRANNULLBOOL(a) || FORTRANNULLFUNCTION(a) || FORTRANNULLCHARACTER(a)) { \
    197:       *ierr = PetscError(PETSC_COMM_SELF, __LINE__, PETSC_FUNCTION_NAME, __FILE__, PETSC_ERR_ARG_WRONG, PETSC_ERROR_INITIAL, "Use PETSC_NULL_MPI_COMM"); \
    198:       *ierr = PETSC_ERR_ARG_BADPTR; \
    199:       return; \
    200:     } \
    201:   } while (0)

    203: /* In the beginning of Fortran XxxCreate() ensure object is not NULL or already created */
    204: #define PETSC_FORTRAN_OBJECT_CREATE(a) \
    205:   do { \
    206:     if (!(*(void **)a)) { \
    207:       *ierr = PetscError(PETSC_COMM_SELF, __LINE__, PETSC_FUNCTION_NAME, __FILE__, PETSC_ERR_ARG_WRONG, PETSC_ERROR_INITIAL, "Cannot create PETSC_NULL_XXX object"); \
    208:       *ierr = PETSC_ERR_ARG_WRONG; \
    209:       return; \
    210:     } else if (*((void **)(a)) != PETSC_FORTRAN_TYPE_INITIALIZE && *((void **)(a)) != PETSC_FORTRAN_TYPE_NULL_RETURN) { \
    211:       *ierr = PetscError(PETSC_COMM_SELF, __LINE__, PETSC_FUNCTION_NAME, __FILE__, PETSC_ERR_ARG_WRONG, PETSC_ERROR_INITIAL, "Cannot create already existing object"); \
    212:       *ierr = PETSC_ERR_ARG_WRONG; \
    213:       return; \
    214:     } \
    215:   } while (0)

    217: /*
    218:   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()
    219:   If it is PETSC_NULL_XXX just return since these objects cannot be destroyed
    220: */
    221: #define PETSC_FORTRAN_OBJECT_F_DESTROYED_TO_C_NULL(a) \
    222:   do { \
    223:     if (!*(void **)a || *((void **)(a)) == PETSC_FORTRAN_TYPE_INITIALIZE || *((void **)(a)) == PETSC_FORTRAN_TYPE_NULL_RETURN) { \
    224:       *ierr = PETSC_SUCCESS; \
    225:       return; \
    226:     } \
    227:   } while (0)

    229: /* After C XxxDestroy(a) is called, change a's state from NULL to destroyed, so that it can be used/destroyed again by Fortran.
    230:    E.g., in VecScatterCreateToAll(x,vscat,seq,ierr), if seq = PETSC_NULL_VEC, PETSc won't create seq. But if seq is a
    231:    destroyed object (e.g., as a result of a previous Fortran VecDestroy), PETSc will create seq.
    232: */
    233: #define PETSC_FORTRAN_OBJECT_C_NULL_TO_F_DESTROYED(a) \
    234:   do { \
    235:     *((void **)(a)) = PETSC_FORTRAN_TYPE_INITIALIZE; \
    236:   } while (0)

    238: /*
    239:     Variable type where we stash PETSc object pointers in Fortran.
    240: */
    241: typedef PETSC_UINTPTR_T PetscFortranAddr;

    243: /*
    244:     These are used to support the default viewers that are
    245:   created at run time, in C using the , trick.

    247:     The numbers here must match the numbers in include/petsc/finclude/petscsys.h
    248: */
    249: #define PETSC_VIEWER_DRAW_WORLD_FORTRAN   4
    250: #define PETSC_VIEWER_DRAW_SELF_FORTRAN    5
    251: #define PETSC_VIEWER_SOCKET_WORLD_FORTRAN 6
    252: #define PETSC_VIEWER_SOCKET_SELF_FORTRAN  7
    253: #define PETSC_VIEWER_STDOUT_WORLD_FORTRAN 8
    254: #define PETSC_VIEWER_STDOUT_SELF_FORTRAN  9
    255: #define PETSC_VIEWER_STDERR_WORLD_FORTRAN 10
    256: #define PETSC_VIEWER_STDERR_SELF_FORTRAN  11
    257: #define PETSC_VIEWER_BINARY_WORLD_FORTRAN 12
    258: #define PETSC_VIEWER_BINARY_SELF_FORTRAN  13
    259: #define PETSC_VIEWER_MATLAB_WORLD_FORTRAN 14
    260: #define PETSC_VIEWER_MATLAB_SELF_FORTRAN  15

    262: #include <petscviewer.h>

    264: static inline PetscViewer PetscPatchDefaultViewers(PetscViewer *v)
    265: {
    266:   if (!v) return PETSC_NULLPTR;
    267:   if (!(*(void **)v)) return PETSC_NULLPTR;
    268:   switch (*(PetscFortranAddr *)v) {
    269:   case PETSC_VIEWER_DRAW_WORLD_FORTRAN:
    270:     return PETSC_VIEWER_DRAW_WORLD;
    271:   case PETSC_VIEWER_DRAW_SELF_FORTRAN:
    272:     return PETSC_VIEWER_DRAW_SELF;

    274:   case PETSC_VIEWER_STDOUT_WORLD_FORTRAN:
    275:     return PETSC_VIEWER_STDOUT_WORLD;
    276:   case PETSC_VIEWER_STDOUT_SELF_FORTRAN:
    277:     return PETSC_VIEWER_STDOUT_SELF;

    279:   case PETSC_VIEWER_STDERR_WORLD_FORTRAN:
    280:     return PETSC_VIEWER_STDERR_WORLD;
    281:   case PETSC_VIEWER_STDERR_SELF_FORTRAN:
    282:     return PETSC_VIEWER_STDERR_SELF;

    284:   case PETSC_VIEWER_BINARY_WORLD_FORTRAN:
    285:     return PETSC_VIEWER_BINARY_WORLD;
    286:   case PETSC_VIEWER_BINARY_SELF_FORTRAN:
    287:     return PETSC_VIEWER_BINARY_SELF;

    289: #if defined(PETSC_HAVE_MATLAB)
    290:   case PETSC_VIEWER_MATLAB_SELF_FORTRAN:
    291:     return PETSC_VIEWER_MATLAB_SELF;
    292:   case PETSC_VIEWER_MATLAB_WORLD_FORTRAN:
    293:     return PETSC_VIEWER_MATLAB_WORLD;
    294: #endif

    296: #if defined(PETSC_USE_SOCKET_VIEWER)
    297:   case PETSC_VIEWER_SOCKET_WORLD_FORTRAN:
    298:     return PETSC_VIEWER_SOCKET_WORLD;
    299:   case PETSC_VIEWER_SOCKET_SELF_FORTRAN:
    300:     return PETSC_VIEWER_SOCKET_SELF;
    301: #endif

    303:   default:
    304:     return *v;
    305:   }
    306: }

    308: #if defined(PETSC_USE_SOCKET_VIEWER)
    309:   #define PetscPatchDefaultViewers_Fortran_Socket(vin, v) \
    310:     } \
    311:     else if ((*(PetscFortranAddr *)vin) == PETSC_VIEWER_SOCKET_WORLD_FORTRAN) \
    312:     { \
    313:       v = PETSC_VIEWER_SOCKET_WORLD; \
    314:     } \
    315:     else if ((*(PetscFortranAddr *)vin) == PETSC_VIEWER_SOCKET_SELF_FORTRAN) \
    316:     { \
    317:       v = PETSC_VIEWER_SOCKET_SELF
    318: #else
    319:   #define PetscPatchDefaultViewers_Fortran_Socket(vin, v)
    320: #endif

    322: #define PetscPatchDefaultViewers_Fortran(vin, v) \
    323:   do { \
    324:     if ((*(PetscFortranAddr *)vin) == PETSC_VIEWER_DRAW_WORLD_FORTRAN) { \
    325:       v = PETSC_VIEWER_DRAW_WORLD; \
    326:     } else if ((*(PetscFortranAddr *)vin) == PETSC_VIEWER_DRAW_SELF_FORTRAN) { \
    327:       v = PETSC_VIEWER_DRAW_SELF; \
    328:     } else if ((*(PetscFortranAddr *)vin) == PETSC_VIEWER_STDOUT_WORLD_FORTRAN) { \
    329:       v = PETSC_VIEWER_STDOUT_WORLD; \
    330:     } else if ((*(PetscFortranAddr *)vin) == PETSC_VIEWER_STDOUT_SELF_FORTRAN) { \
    331:       v = PETSC_VIEWER_STDOUT_SELF; \
    332:     } else if ((*(PetscFortranAddr *)vin) == PETSC_VIEWER_STDERR_WORLD_FORTRAN) { \
    333:       v = PETSC_VIEWER_STDERR_WORLD; \
    334:     } else if ((*(PetscFortranAddr *)vin) == PETSC_VIEWER_STDERR_SELF_FORTRAN) { \
    335:       v = PETSC_VIEWER_STDERR_SELF; \
    336:     } else if ((*(PetscFortranAddr *)vin) == PETSC_VIEWER_BINARY_WORLD_FORTRAN) { \
    337:       v = PETSC_VIEWER_BINARY_WORLD; \
    338:     } else if ((*(PetscFortranAddr *)vin) == PETSC_VIEWER_BINARY_SELF_FORTRAN) { \
    339:       v = PETSC_VIEWER_BINARY_SELF; \
    340:     } else if ((*(PetscFortranAddr *)vin) == PETSC_VIEWER_MATLAB_WORLD_FORTRAN) { \
    341:       v = PETSC_VIEWER_BINARY_WORLD; \
    342:     } else if ((*(PetscFortranAddr *)vin) == PETSC_VIEWER_MATLAB_SELF_FORTRAN) { \
    343:       v = PETSC_VIEWER_BINARY_SELF; \
    344:       PetscPatchDefaultViewers_Fortran_Socket(vin, v); \
    345:     } else { \
    346:       v = *vin; \
    347:     } \
    348:   } while (0)

    350: /*
    351:       Allocates enough space to store Fortran function pointers in PETSc object
    352:    that are needed by the Fortran interface.
    353: */
    354: #define PetscObjectAllocateFortranPointers(obj, N) \
    355:   do { \
    356:     if (!((PetscObject)(obj))->fortran_func_pointers) { \
    357:       *ierr = PetscCalloc((N) * sizeof(PetscFortranCallbackFn *), &((PetscObject)(obj))->fortran_func_pointers); \
    358:       if (*ierr) return; \
    359:       ((PetscObject)obj)->num_fortran_func_pointers = (N); \
    360:     } \
    361:   } while (0)

    363: #define PetscCallFortranVoidFunction(...) \
    364:   do { \
    365:     PetscErrorCode ierr = PETSC_SUCCESS; \
    366:     /* the function may or may not access ierr */ \
    367:     __VA_ARGS__; \
    368:     PetscCall(ierr); \
    369:   } while (0)

    371: /* Entire function body, _ctx is a "special" variable that can be passed along */
    372: #define PetscObjectUseFortranCallback_Private(obj, cid, types, args, cbclass) \
    373:   do { \
    374:     void(*func) types, *_ctx; \
    375:     PetscFunctionBegin; \
    376:     PetscCall(PetscObjectGetFortranCallback((PetscObject)(obj), (cbclass), (cid), (PetscFortranCallbackFn **)&func, &_ctx)); \
    377:     if (func) PetscCallFortranVoidFunction((*func)args); \
    378:     PetscFunctionReturn(PETSC_SUCCESS); \
    379:   } while (0)
    380: #define PetscObjectUseFortranCallback(obj, cid, types, args)        PetscObjectUseFortranCallback_Private(obj, cid, types, args, PETSC_FORTRAN_CALLBACK_CLASS)
    381: #define PetscObjectUseFortranCallbackSubType(obj, cid, types, args) PetscObjectUseFortranCallback_Private(obj, cid, types, args, PETSC_FORTRAN_CALLBACK_SUBTYPE)

    383: /* Disable deprecation warnings while building Fortran wrappers */
    384: #undef PETSC_DEPRECATED_OBJECT
    385: #define PETSC_DEPRECATED_OBJECT(...)
    386: #undef PETSC_DEPRECATED_FUNCTION
    387: #define PETSC_DEPRECATED_FUNCTION(...)
    388: #undef PETSC_DEPRECATED_ENUM
    389: #define PETSC_DEPRECATED_ENUM(...)
    390: #undef PETSC_DEPRECATED_TYPEDEF
    391: #define PETSC_DEPRECATED_TYPEDEF(...)
    392: #undef PETSC_DEPRECATED_MACRO
    393: #define PETSC_DEPRECATED_MACRO(...)

    395: /* PGI compilers pass in f90 pointers as 2 arguments */
    396: #if defined(PETSC_HAVE_F90_2PTR_ARG)
    397:   #define PETSC_F90_2PTR_PROTO_NOVAR , void *
    398:   #define PETSC_F90_2PTR_PROTO(ptr)  , void *ptr
    399:   #define PETSC_F90_2PTR_PARAM(ptr)  , ptr
    400: #else
    401:   #define PETSC_F90_2PTR_PROTO_NOVAR
    402:   #define PETSC_F90_2PTR_PROTO(ptr)
    403:   #define PETSC_F90_2PTR_PARAM(ptr)
    404: #endif

    406: typedef struct {
    407:   char dummy;
    408: } F90Array1d;
    409: typedef struct {
    410:   char dummy;
    411: } F90Array2d;
    412: typedef struct {
    413:   char dummy;
    414: } F90Array3d;
    415: typedef struct {
    416:   char dummy;
    417: } F90Array4d;

    419: PETSC_EXTERN PetscErrorCode F90Array1dCreate(void *, MPI_Datatype, PetscInt, PetscInt, F90Array1d *PETSC_F90_2PTR_PROTO_NOVAR);
    420: PETSC_EXTERN PetscErrorCode F90Array1dAccess(F90Array1d *, MPI_Datatype, void **PETSC_F90_2PTR_PROTO_NOVAR);
    421: PETSC_EXTERN PetscErrorCode F90Array1dDestroy(F90Array1d *, MPI_Datatype PETSC_F90_2PTR_PROTO_NOVAR);

    423: PETSC_EXTERN PetscErrorCode F90Array2dCreate(void *, MPI_Datatype, PetscInt, PetscInt, PetscInt, PetscInt, F90Array2d *PETSC_F90_2PTR_PROTO_NOVAR);
    424: PETSC_EXTERN PetscErrorCode F90Array2dAccess(F90Array2d *, MPI_Datatype, void **PETSC_F90_2PTR_PROTO_NOVAR);
    425: PETSC_EXTERN PetscErrorCode F90Array2dDestroy(F90Array2d *, MPI_Datatype PETSC_F90_2PTR_PROTO_NOVAR);

    427: PETSC_EXTERN PetscErrorCode F90Array3dCreate(void *, MPI_Datatype, PetscInt, PetscInt, PetscInt, PetscInt, PetscInt, PetscInt, F90Array3d *PETSC_F90_2PTR_PROTO_NOVAR);
    428: PETSC_EXTERN PetscErrorCode F90Array3dAccess(F90Array3d *, MPI_Datatype, void **PETSC_F90_2PTR_PROTO_NOVAR);
    429: PETSC_EXTERN PetscErrorCode F90Array3dDestroy(F90Array3d *, MPI_Datatype PETSC_F90_2PTR_PROTO_NOVAR);

    431: PETSC_EXTERN PetscErrorCode F90Array4dCreate(void *, MPI_Datatype, PetscInt, PetscInt, PetscInt, PetscInt, PetscInt, PetscInt, PetscInt, PetscInt, F90Array4d *PETSC_F90_2PTR_PROTO_NOVAR);
    432: PETSC_EXTERN PetscErrorCode F90Array4dAccess(F90Array4d *, MPI_Datatype, void **PETSC_F90_2PTR_PROTO_NOVAR);
    433: PETSC_EXTERN PetscErrorCode F90Array4dDestroy(F90Array4d *, MPI_Datatype PETSC_F90_2PTR_PROTO_NOVAR);

    435: /*
    436:   F90Array1dCreate - Given a C pointer to a one dimensional
    437:   array and its length; this fills in the appropriate Fortran 90
    438:   pointer data structure.

    440:   Input Parameters:
    441: +   array - regular C pointer (address)
    442: .   type  - DataType of the array
    443: .   start - starting index of the array
    444: -   len   - length of array (in items)

    446:   Output Parameter:
    447: .   ptr - Fortran 90 pointer
    448: */