1 #include <petsc/private/ftnimpl.h> 2 3 /*MC 4 PetscFortranAddr - a variable type in Fortran that can hold a 5 regular C pointer. 6 7 Note: 8 Used, for example, as the file argument in `PetscFOpen()` 9 10 Level: beginner 11 12 .seealso: `PetscOffset`, `PetscInt` 13 M*/ 14 /*MC 15 PetscOffset - a variable type in Fortran used with `VecGetArray()` 16 and `ISGetIndices()` 17 18 Level: beginner 19 20 .seealso: `PetscFortranAddr`, `PetscInt` 21 M*/ 22 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; 40 41 EXTERN_C_BEGIN 42 PetscFortranCallbackFn *PETSC_NULL_FUNCTION_Fortran = NULL; 43 EXTERN_C_END 44 void *PETSC_NULL_MPI_COMM_Fortran = NULL; 45 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; 51 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 69 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 } 78 79 PetscInt *PetscIntAddressFromFortran(const PetscInt *base, size_t addr) 80 { 81 return (PetscInt *)(base + addr); 82 } 83 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 91 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; 100 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 122 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; 130 131 PetscCall(PetscMalloc1(N + align, &work)); 132 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 } 140 141 /* shift work by that number of bytes */ 142 work = (PetscScalar *)(((char *)work) + shift); 143 PetscCall(PetscArraycpy(work, addr, N)); 144 145 /* store in the first location in addr how much you shift it */ 146 ((PetscInt *)addr)[0] = shift; 147 148 PetscCall(PetscContainerCreate(PETSC_COMM_SELF, &container)); 149 PetscCall(PetscContainerSetPointer(container, addr)); 150 PetscCall(PetscObjectCompose(obj, "GetArrayPtr", (PetscObject)container)); 151 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 } 174 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 180 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; 188 189 PetscFunctionBegin; 190 PetscCall(PetscObjectQuery(obj, "GetArrayPtr", (PetscObject *)&container)); 191 if (container) { 192 PetscCall(PetscContainerGetPointer(container, lx)); 193 tlx = base + addr; 194 195 shift = *(PetscInt *)*lx; 196 PetscCall(PetscArraycpy(*lx, tlx, N)); 197 tlx = (PetscScalar *)((char *)tlx - shift); 198 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 } 207 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 215 216 PETSC_EXTERN PetscBool petscisinfornanscalar_(PetscScalar *v) 217 { 218 return (PetscBool)PetscIsInfOrNanScalar(*v); 219 } 220 221 PETSC_EXTERN PetscBool petscisinfornanreal_(PetscReal *v) 222 { 223 return (PetscBool)PetscIsInfOrNanReal(*v); 224 } 225