1 #include <petsc/private/fortranimpl.h> 2 3 void *PETSCNULLPOINTERADDRESS = NULL; 4 5 /*MC 6 PetscFortranAddr - a variable type in Fortran that can hold a 7 regular C pointer. 8 9 Notes: Used, for example, as the file argument in PetscFOpen() 10 11 Level: beginner 12 13 .seealso: PetscOffset, PetscInt 14 M*/ 15 /*MC 16 PetscOffset - a variable type in Fortran used with VecGetArray() 17 and ISGetIndices() 18 19 Level: beginner 20 21 .seealso: PetscFortranAddr, PetscInt 22 M*/ 23 24 /* 25 This is code for translating PETSc memory addresses to integer offsets 26 for Fortran. 27 */ 28 char *PETSC_NULL_CHARACTER_Fortran = 0; 29 void *PETSC_NULL_INTEGER_Fortran = 0; 30 void *PETSC_NULL_OBJECT_Fortran = 0; 31 void *PETSC_NULL_SCALAR_Fortran = 0; 32 void *PETSC_NULL_DOUBLE_Fortran = 0; 33 void *PETSC_NULL_REAL_Fortran = 0; 34 void *PETSC_NULL_BOOL_Fortran = 0; 35 EXTERN_C_BEGIN 36 void (*PETSC_NULL_FUNCTION_Fortran)(void) = 0; 37 EXTERN_C_END 38 39 size_t PetscIntAddressToFortran(const PetscInt *base,const PetscInt *addr) 40 { 41 size_t tmp1 = (size_t) base,tmp2 = 0; 42 size_t tmp3 = (size_t) addr; 43 size_t itmp2; 44 45 #if !defined(PETSC_HAVE_CRAY90_POINTER) 46 if (tmp3 > tmp1) { 47 tmp2 = (tmp3 - tmp1)/sizeof(PetscInt); 48 itmp2 = (size_t) tmp2; 49 } else { 50 tmp2 = (tmp1 - tmp3)/sizeof(PetscInt); 51 itmp2 = -((size_t) tmp2); 52 } 53 #else 54 if (tmp3 > tmp1) { 55 tmp2 = (tmp3 - tmp1); 56 itmp2 = (size_t) tmp2; 57 } else { 58 tmp2 = (tmp1 - tmp3); 59 itmp2 = -((size_t) tmp2); 60 } 61 #endif 62 63 if (base + itmp2 != addr) { 64 (*PetscErrorPrintf)("PetscIntAddressToFortran:C and Fortran arrays are\n"); 65 (*PetscErrorPrintf)("not commonly aligned or are too far apart to be indexed \n"); 66 (*PetscErrorPrintf)("by an integer. Locations: C %uld Fortran %uld\n",tmp1,tmp3); 67 MPI_Abort(PETSC_COMM_WORLD,1); 68 } 69 return itmp2; 70 } 71 72 PetscInt *PetscIntAddressFromFortran(const PetscInt *base,size_t addr) 73 { 74 return (PetscInt *)(base + addr); 75 } 76 77 /* 78 obj - PETSc object on which request is made 79 base - Fortran array address 80 addr - C array address 81 res - will contain offset from C to Fortran 82 shift - number of bytes that prevent base and addr from being commonly aligned 83 N - size of the array 84 85 align indicates alignment relative to PetscScalar, 1 means aligned on PetscScalar, 2 means aligned on 2 PetscScalar etc 86 */ 87 PetscErrorCode PetscScalarAddressToFortran(PetscObject obj,PetscInt align,PetscScalar *base,PetscScalar *addr,PetscInt N,size_t *res) 88 { 89 size_t tmp1 = (size_t) base,tmp2; 90 size_t tmp3 = (size_t) addr; 91 size_t itmp2; 92 PetscInt shift; 93 94 #if !defined(PETSC_HAVE_CRAY90_POINTER) 95 if (tmp3 > tmp1) { /* C is bigger than Fortran */ 96 tmp2 = (tmp3 - tmp1)/sizeof(PetscScalar); 97 itmp2 = (size_t) tmp2; 98 shift = (align*sizeof(PetscScalar) - (PetscInt)((tmp3 - tmp1) % (align*sizeof(PetscScalar)))) % (align*sizeof(PetscScalar)); 99 } else { 100 tmp2 = (tmp1 - tmp3)/sizeof(PetscScalar); 101 itmp2 = -((size_t) tmp2); 102 shift = (PetscInt)((tmp1 - tmp3) % (align*sizeof(PetscScalar))); 103 } 104 #else 105 if (tmp3 > tmp1) { /* C is bigger than Fortran */ 106 tmp2 = (tmp3 - tmp1); 107 itmp2 = (size_t) tmp2; 108 } else { 109 tmp2 = (tmp1 - tmp3); 110 itmp2 = -((size_t) tmp2); 111 } 112 shift = 0; 113 #endif 114 115 if (shift) { 116 /* 117 Fortran and C not PetscScalar aligned,recover by copying values into 118 memory that is aligned with the Fortran 119 */ 120 PetscErrorCode ierr; 121 PetscScalar *work; 122 PetscContainer container; 123 124 ierr = PetscMalloc1(N+align,&work);CHKERRQ(ierr); 125 126 /* recompute shift for newly allocated space */ 127 tmp3 = (size_t) work; 128 if (tmp3 > tmp1) { /* C is bigger than Fortran */ 129 shift = (align*sizeof(PetscScalar) - (PetscInt)((tmp3 - tmp1) % (align*sizeof(PetscScalar)))) % (align*sizeof(PetscScalar)); 130 } else { 131 shift = (PetscInt)((tmp1 - tmp3) % (align*sizeof(PetscScalar))); 132 } 133 134 /* shift work by that number of bytes */ 135 work = (PetscScalar*)(((char*)work) + shift); 136 ierr = PetscMemcpy(work,addr,N*sizeof(PetscScalar));CHKERRQ(ierr); 137 138 /* store in the first location in addr how much you shift it */ 139 ((PetscInt*)addr)[0] = shift; 140 141 ierr = PetscContainerCreate(PETSC_COMM_SELF,&container);CHKERRQ(ierr); 142 ierr = PetscContainerSetPointer(container,addr);CHKERRQ(ierr); 143 ierr = PetscObjectCompose(obj,"GetArrayPtr",(PetscObject)container);CHKERRQ(ierr); 144 145 tmp3 = (size_t) work; 146 if (tmp3 > tmp1) { /* C is bigger than Fortran */ 147 tmp2 = (tmp3 - tmp1)/sizeof(PetscScalar); 148 itmp2 = (size_t) tmp2; 149 shift = (align*sizeof(PetscScalar) - (PetscInt)((tmp3 - tmp1) % (align*sizeof(PetscScalar)))) % (align*sizeof(PetscScalar)); 150 } else { 151 tmp2 = (tmp1 - tmp3)/sizeof(PetscScalar); 152 itmp2 = -((size_t) tmp2); 153 shift = (PetscInt)((tmp1 - tmp3) % (align*sizeof(PetscScalar))); 154 } 155 if (shift) { 156 (*PetscErrorPrintf)("PetscScalarAddressToFortran:C and Fortran arrays are\n"); 157 (*PetscErrorPrintf)("not commonly aligned.\n"); 158 (*PetscErrorPrintf)("Locations/sizeof(PetscScalar): C %f Fortran %f\n",((PetscReal)tmp3)/(PetscReal)sizeof(PetscScalar),((PetscReal)tmp1)/(PetscReal)sizeof(PetscScalar)); 159 MPI_Abort(PETSC_COMM_WORLD,1); 160 } 161 ierr = PetscInfo(obj,"Efficiency warning, copying array in XXXGetArray() due\n\ 162 to alignment differences between C and Fortran\n");CHKERRQ(ierr); 163 } 164 *res = itmp2; 165 return 0; 166 } 167 168 /* 169 obj - the PETSc object where the scalar pointer came from 170 base - the Fortran array address 171 addr - the Fortran offset from base 172 N - the amount of data 173 174 lx - the array space that is to be passed to XXXXRestoreArray() 175 */ 176 PetscErrorCode PetscScalarAddressFromFortran(PetscObject obj,PetscScalar *base,size_t addr,PetscInt N,PetscScalar **lx) 177 { 178 PetscErrorCode ierr; 179 PetscInt shift; 180 PetscContainer container; 181 PetscScalar *tlx; 182 183 ierr = PetscObjectQuery(obj,"GetArrayPtr",(PetscObject*)&container);CHKERRQ(ierr); 184 if (container) { 185 ierr = PetscContainerGetPointer(container,(void**)lx);CHKERRQ(ierr); 186 tlx = base + addr; 187 188 shift = *(PetscInt*)*lx; 189 ierr = PetscMemcpy(*lx,tlx,N*sizeof(PetscScalar));CHKERRQ(ierr); 190 tlx = (PetscScalar*)(((char*)tlx) - shift); 191 192 ierr = PetscFree(tlx);CHKERRQ(ierr); 193 ierr = PetscContainerDestroy(&container);CHKERRQ(ierr); 194 ierr = PetscObjectCompose(obj,"GetArrayPtr",0);CHKERRQ(ierr); 195 } else { 196 *lx = base + addr; 197 } 198 return 0; 199 } 200 201 #if defined(PETSC_HAVE_FORTRAN_CAPS) 202 #define petscisinfornanscalar_ PETSCISINFORNANSCALAR 203 #define petscisinfornanreal_ PETSCISINFORNANREAL 204 #elif !defined(PETSC_HAVE_FORTRAN_UNDERSCORE) 205 #define petscisinfornanscalar_ petscisinfornanscalar 206 #define petscisinfornanreal_ petscisinfornanreal 207 #endif 208 209 PETSC_EXTERN PetscBool PETSC_STDCALL petscisinfornanscalar_(PetscScalar *v) 210 { 211 return (PetscBool) PetscIsInfOrNanScalar(*v); 212 } 213 214 PETSC_EXTERN PetscBool PETSC_STDCALL petscisinfornanreal_(PetscReal *v) 215 { 216 return (PetscBool) PetscIsInfOrNanReal(*v); 217 } 218 219 220 221