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
PetscIntAddressToFortran(const PetscInt * base,const PetscInt * addr)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
PetscIntAddressFromFortran(const PetscInt * base,size_t addr)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 */
PetscScalarAddressToFortran(PetscObject obj,PetscInt align,PetscScalar * base,PetscScalar * addr,PetscInt N,size_t * res)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 */
PetscScalarAddressFromFortran(PetscObject obj,PetscScalar * base,size_t addr,PetscInt N,PetscScalar ** lx)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
petscisinfornanscalar_(PetscScalar * v)216 PETSC_EXTERN PetscBool petscisinfornanscalar_(PetscScalar *v)
217 {
218 return (PetscBool)PetscIsInfOrNanScalar(*v);
219 }
220
petscisinfornanreal_(PetscReal * v)221 PETSC_EXTERN PetscBool petscisinfornanreal_(PetscReal *v)
222 {
223 return (PetscBool)PetscIsInfOrNanReal(*v);
224 }
225