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: void (*PETSC_NULL_FUNCTION_Fortran)(void) = 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, (void **)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: }