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: }