Actual source code: zutils.c

      1: #include <petsc/private/ftnimpl.h>

      3: /*MC
      4:    PetscFortranAddr - a variable type in Fortran that can hold a
      5:      regular C pointer.

      7:    Note:
      8:     Used, for example, as the file argument in `PetscFOpen()`

     10:    Level: beginner

     12: .seealso:  `PetscOffset`, `PetscInt`
     13: M*/
     14: /*MC
     15:    PetscOffset - a variable type in Fortran used with `VecGetArray()`
     16:      and `ISGetIndices()`

     18:    Level: beginner

     20: .seealso:  `PetscFortranAddr`, `PetscInt`
     21: M*/

     23: /*
     24:     This is code for translating PETSc memory addresses to integer offsets
     25:     for Fortran.
     26: */
     27: char *PETSC_NULL_CHARACTER_Fortran       = NULL;
     28: void *PETSC_NULL_INTEGER_Fortran         = NULL;
     29: void *PETSC_NULL_SCALAR_Fortran          = NULL;
     30: void *PETSC_NULL_DOUBLE_Fortran          = NULL;
     31: void *PETSC_NULL_REAL_Fortran            = NULL;
     32: void *PETSC_NULL_BOOL_Fortran            = NULL;
     33: void *PETSC_NULL_ENUM_Fortran            = NULL;
     34: void *PETSC_NULL_INTEGER_ARRAY_Fortran   = NULL;
     35: void *PETSC_NULL_SCALAR_ARRAY_Fortran    = NULL;
     36: void *PETSC_NULL_REAL_ARRAY_Fortran      = NULL;
     37: void *PETSC_NULL_INTEGER_POINTER_Fortran = NULL;
     38: void *PETSC_NULL_SCALAR_POINTER_Fortran  = NULL;
     39: void *PETSC_NULL_REAL_POINTER_Fortran    = NULL;

     41: EXTERN_C_BEGIN
     42: PetscFortranCallbackFn *PETSC_NULL_FUNCTION_Fortran = NULL;
     43: EXTERN_C_END
     44: void *PETSC_NULL_MPI_COMM_Fortran = NULL;

     46: size_t PetscIntAddressToFortran(const PetscInt *base, const PetscInt *addr)
     47: {
     48:   size_t tmp1 = (size_t)base, tmp2 = 0;
     49:   size_t tmp3 = (size_t)addr;
     50:   size_t itmp2;

     52: #if !defined(PETSC_HAVE_CRAY90_POINTER)
     53:   if (tmp3 > tmp1) {
     54:     tmp2  = (tmp3 - tmp1) / sizeof(PetscInt);
     55:     itmp2 = (size_t)tmp2;
     56:   } else {
     57:     tmp2  = (tmp1 - tmp3) / sizeof(PetscInt);
     58:     itmp2 = -((size_t)tmp2);
     59:   }
     60: #else
     61:   if (tmp3 > tmp1) {
     62:     tmp2  = (tmp3 - tmp1);
     63:     itmp2 = (size_t)tmp2;
     64:   } else {
     65:     tmp2  = (tmp1 - tmp3);
     66:     itmp2 = -((size_t)tmp2);
     67:   }
     68: #endif

     70:   if (base + itmp2 != addr) {
     71:     PetscCallAbort(PETSC_COMM_SELF, (*PetscErrorPrintf)("PetscIntAddressToFortran:C and Fortran arrays are\n"));
     72:     PetscCallAbort(PETSC_COMM_SELF, (*PetscErrorPrintf)("not commonly aligned or are too far apart to be indexed \n"));
     73:     PetscCallAbort(PETSC_COMM_SELF, (*PetscErrorPrintf)("by an integer. Locations: C %zu Fortran %zu\n", tmp1, tmp3));
     74:     PETSCABORT(PETSC_COMM_WORLD, PETSC_ERR_PLIB);
     75:   }
     76:   return itmp2;
     77: }

     79: PetscInt *PetscIntAddressFromFortran(const PetscInt *base, size_t addr)
     80: {
     81:   return (PetscInt *)(base + addr);
     82: }

     84: /*
     85:        obj - PETSc object on which request is made
     86:        base - Fortran array address
     87:        addr - C array address
     88:        res  - will contain offset from C to Fortran
     89:        shift - number of bytes that prevent base and addr from being commonly aligned
     90:        N - size of the array

     92:        align indicates alignment relative to PetscScalar, 1 means aligned on PetscScalar, 2 means aligned on 2 PetscScalar etc
     93: */
     94: PetscErrorCode PetscScalarAddressToFortran(PetscObject obj, PetscInt align, PetscScalar *base, PetscScalar *addr, PetscInt N, size_t *res)
     95: {
     96:   size_t   tmp1 = (size_t)base, tmp2;
     97:   size_t   tmp3 = (size_t)addr;
     98:   size_t   itmp2;
     99:   PetscInt shift;

    101:   PetscFunctionBegin;
    102: #if !defined(PETSC_HAVE_CRAY90_POINTER)
    103:   if (tmp3 > tmp1) { /* C is bigger than Fortran */
    104:     tmp2  = (tmp3 - tmp1) / sizeof(PetscScalar);
    105:     itmp2 = (size_t)tmp2;
    106:     shift = (align * sizeof(PetscScalar) - (PetscInt)((tmp3 - tmp1) % (align * sizeof(PetscScalar)))) % (align * sizeof(PetscScalar));
    107:   } else {
    108:     tmp2  = (tmp1 - tmp3) / sizeof(PetscScalar);
    109:     itmp2 = -((size_t)tmp2);
    110:     shift = (PetscInt)((tmp1 - tmp3) % (align * sizeof(PetscScalar)));
    111:   }
    112: #else
    113:   if (tmp3 > tmp1) { /* C is bigger than Fortran */
    114:     tmp2  = (tmp3 - tmp1);
    115:     itmp2 = (size_t)tmp2;
    116:   } else {
    117:     tmp2  = (tmp1 - tmp3);
    118:     itmp2 = -((size_t)tmp2);
    119:   }
    120:   shift = 0;
    121: #endif

    123:   if (shift) {
    124:     /*
    125:         Fortran and C not PetscScalar aligned,recover by copying values into
    126:         memory that is aligned with the Fortran
    127:     */
    128:     PetscScalar   *work;
    129:     PetscContainer container;

    131:     PetscCall(PetscMalloc1(N + align, &work));

    133:     /* recompute shift for newly allocated space */
    134:     tmp3 = (size_t)work;
    135:     if (tmp3 > tmp1) { /* C is bigger than Fortran */
    136:       shift = (align * sizeof(PetscScalar) - (PetscInt)((tmp3 - tmp1) % (align * sizeof(PetscScalar)))) % (align * sizeof(PetscScalar));
    137:     } else {
    138:       shift = (PetscInt)((tmp1 - tmp3) % (align * sizeof(PetscScalar)));
    139:     }

    141:     /* shift work by that number of bytes */
    142:     work = (PetscScalar *)(((char *)work) + shift);
    143:     PetscCall(PetscArraycpy(work, addr, N));

    145:     /* store in the first location in addr how much you shift it */
    146:     ((PetscInt *)addr)[0] = shift;

    148:     PetscCall(PetscContainerCreate(PETSC_COMM_SELF, &container));
    149:     PetscCall(PetscContainerSetPointer(container, addr));
    150:     PetscCall(PetscObjectCompose(obj, "GetArrayPtr", (PetscObject)container));

    152:     tmp3 = (size_t)work;
    153:     if (tmp3 > tmp1) { /* C is bigger than Fortran */
    154:       tmp2  = (tmp3 - tmp1) / sizeof(PetscScalar);
    155:       itmp2 = (size_t)tmp2;
    156:       shift = (align * sizeof(PetscScalar) - (PetscInt)((tmp3 - tmp1) % (align * sizeof(PetscScalar)))) % (align * sizeof(PetscScalar));
    157:     } else {
    158:       tmp2  = (tmp1 - tmp3) / sizeof(PetscScalar);
    159:       itmp2 = -((size_t)tmp2);
    160:       shift = (PetscInt)((tmp1 - tmp3) % (align * sizeof(PetscScalar)));
    161:     }
    162:     if (shift) {
    163:       PetscCall((*PetscErrorPrintf)("PetscScalarAddressToFortran:C and Fortran arrays are\n"));
    164:       PetscCall((*PetscErrorPrintf)("not commonly aligned.\n"));
    165:       PetscCall((*PetscErrorPrintf)("Locations/sizeof(PetscScalar): C %g Fortran %g\n", (double)(((PetscReal)tmp3) / (PetscReal)sizeof(PetscScalar)), (double)(((PetscReal)tmp1) / (PetscReal)sizeof(PetscScalar))));
    166:       PETSCABORT(PETSC_COMM_WORLD, PETSC_ERR_PLIB);
    167:     }
    168:     PetscCall(PetscInfo(obj, "Efficiency warning, copying array in XXXGetArray() due\n\
    169:     to alignment differences between C and Fortran\n"));
    170:   }
    171:   *res = itmp2;
    172:   PetscFunctionReturn(PETSC_SUCCESS);
    173: }

    175: /*
    176:     obj - the PETSc object where the scalar pointer came from
    177:     base - the Fortran array address
    178:     addr - the Fortran offset from base
    179:     N    - the amount of data

    181:     lx   - the array space that is to be passed to XXXXRestoreArray()
    182: */
    183: PetscErrorCode PetscScalarAddressFromFortran(PetscObject obj, PetscScalar *base, size_t addr, PetscInt N, PetscScalar **lx)
    184: {
    185:   PetscInt       shift;
    186:   PetscContainer container;
    187:   PetscScalar   *tlx;

    189:   PetscFunctionBegin;
    190:   PetscCall(PetscObjectQuery(obj, "GetArrayPtr", (PetscObject *)&container));
    191:   if (container) {
    192:     PetscCall(PetscContainerGetPointer(container, lx));
    193:     tlx = base + addr;

    195:     shift = *(PetscInt *)*lx;
    196:     PetscCall(PetscArraycpy(*lx, tlx, N));
    197:     tlx = (PetscScalar *)((char *)tlx - shift);

    199:     PetscCall(PetscFree(tlx));
    200:     PetscCall(PetscContainerDestroy(&container));
    201:     PetscCall(PetscObjectCompose(obj, "GetArrayPtr", NULL));
    202:   } else {
    203:     *lx = base + addr;
    204:   }
    205:   PetscFunctionReturn(PETSC_SUCCESS);
    206: }

    208: #if defined(PETSC_HAVE_FORTRAN_CAPS)
    209:   #define petscisinfornanscalar_ PETSCISINFORNANSCALAR
    210:   #define petscisinfornanreal_   PETSCISINFORNANREAL
    211: #elif !defined(PETSC_HAVE_FORTRAN_UNDERSCORE)
    212:   #define petscisinfornanscalar_ petscisinfornanscalar
    213:   #define petscisinfornanreal_   petscisinfornanreal
    214: #endif

    216: PETSC_EXTERN PetscBool petscisinfornanscalar_(PetscScalar *v)
    217: {
    218:   return (PetscBool)PetscIsInfOrNanScalar(*v);
    219: }

    221: PETSC_EXTERN PetscBool petscisinfornanreal_(PetscReal *v)
    222: {
    223:   return (PetscBool)PetscIsInfOrNanReal(*v);
    224: }