1 #pragma once 2 3 #include <petsc/private/petscimpl.h> 4 PETSC_INTERN PetscErrorCode PETScParseFortranArgs_Private(int *, char ***); 5 PETSC_EXTERN PetscErrorCode PetscMPIFortranDatatypeToC(MPI_Fint, MPI_Datatype *); 6 7 PETSC_EXTERN PetscErrorCode PetscScalarAddressToFortran(PetscObject, PetscInt, PetscScalar *, PetscScalar *, PetscInt, size_t *); 8 PETSC_EXTERN PetscErrorCode PetscScalarAddressFromFortran(PetscObject, PetscScalar *, size_t, PetscInt, PetscScalar **); 9 PETSC_EXTERN size_t PetscIntAddressToFortran(const PetscInt *, const PetscInt *); 10 PETSC_EXTERN PetscInt *PetscIntAddressFromFortran(const PetscInt *, size_t); 11 PETSC_EXTERN char *PETSC_NULL_CHARACTER_Fortran; 12 PETSC_EXTERN void *PETSC_NULL_INTEGER_Fortran; 13 PETSC_EXTERN void *PETSC_NULL_SCALAR_Fortran; 14 PETSC_EXTERN void *PETSC_NULL_DOUBLE_Fortran; 15 PETSC_EXTERN void *PETSC_NULL_REAL_Fortran; 16 PETSC_EXTERN void *PETSC_NULL_BOOL_Fortran; 17 PETSC_EXTERN void *PETSC_NULL_ENUM_Fortran; 18 PETSC_EXTERN void *PETSC_NULL_INTEGER_ARRAY_Fortran; 19 PETSC_EXTERN void *PETSC_NULL_SCALAR_ARRAY_Fortran; 20 PETSC_EXTERN void *PETSC_NULL_REAL_ARRAY_Fortran; 21 PETSC_EXTERN void *PETSC_NULL_MPI_COMM_Fortran; 22 PETSC_EXTERN void *PETSC_NULL_INTEGER_POINTER_Fortran; 23 PETSC_EXTERN void *PETSC_NULL_SCALAR_POINTER_Fortran; 24 PETSC_EXTERN void *PETSC_NULL_REAL_POINTER_Fortran; 25 PETSC_EXTERN PetscFortranCallbackFn *PETSC_NULL_FUNCTION_Fortran; 26 27 PETSC_INTERN PetscErrorCode PetscInitFortran_Private(const char *, PetscInt); 28 29 /* ----------------------------------------------------------------------*/ 30 /* 31 PETSc object C pointers are stored directly as 32 Fortran integer*4 or *8 depending on the size of pointers. 33 */ 34 35 /* --------------------------------------------------------------------*/ 36 /* 37 Since Fortran does not null terminate strings we need to insure the string is null terminated before passing it 38 to C. This may require a memory allocation which is then freed with FREECHAR(). 39 */ 40 #define FIXCHAR(a, n, b) \ 41 do { \ 42 if ((a) == PETSC_NULL_CHARACTER_Fortran) { \ 43 (b) = PETSC_NULLPTR; \ 44 (a) = PETSC_NULLPTR; \ 45 } else { \ 46 while (((n) > 0) && ((a)[(n) - 1] == ' ')) (n)--; \ 47 *ierr = PetscMalloc1((n) + 1, &(b)); \ 48 if (*ierr) return; \ 49 *ierr = PetscMemcpy((b), (a), (n)); \ 50 (b)[n] = '\0'; \ 51 if (*ierr) return; \ 52 } \ 53 } while (0) 54 #define FREECHAR(a, b) \ 55 do { \ 56 if (a != b) *ierr = PetscFree(b); \ 57 } while (0) 58 59 /* 60 Fortran expects any unneeded characters at the end of its strings to be filled with the blank character. 61 */ 62 #define FIXRETURNCHAR(flg, a, n) \ 63 do { \ 64 if (flg) { \ 65 PETSC_FORTRAN_CHARLEN_T __i; \ 66 for (__i = 0; __i < n && a[__i] != 0; __i++) { }; \ 67 for (; __i < n; __i++) a[__i] = ' '; \ 68 } \ 69 } while (0) 70 71 /* 72 The cast through PETSC_UINTPTR_T is so that compilers that warn about casting to/from void * to void(*)(void) 73 will not complain about these comparisons. It is not know if this works for all compilers 74 */ 75 #define FORTRANNULLINTEGERPOINTER(a) (((void *)(PETSC_UINTPTR_T)a) == PETSC_NULL_INTEGER_POINTER_Fortran) 76 #define FORTRANNULLSCALARPOINTER(a) (((void *)(PETSC_UINTPTR_T)a) == PETSC_NULL_SCALAR_POINTER_Fortran) 77 #define FORTRANNULLREALPOINTER(a) (((void *)(PETSC_UINTPTR_T)a) == PETSC_NULL_REAL_POINTER_Fortran) 78 #define FORTRANNULLINTEGER(a) (((void *)(PETSC_UINTPTR_T)a) == PETSC_NULL_INTEGER_Fortran || ((void *)(PETSC_UINTPTR_T)a) == PETSC_NULL_INTEGER_ARRAY_Fortran) 79 #define FORTRANNULLSCALAR(a) (((void *)(PETSC_UINTPTR_T)a) == PETSC_NULL_SCALAR_Fortran || ((void *)(PETSC_UINTPTR_T)a) == PETSC_NULL_SCALAR_ARRAY_Fortran) 80 #define FORTRANNULLREAL(a) (((void *)(PETSC_UINTPTR_T)a) == PETSC_NULL_REAL_Fortran || ((void *)(PETSC_UINTPTR_T)a) == PETSC_NULL_REAL_ARRAY_Fortran) 81 #define FORTRANNULLDOUBLE(a) (((void *)(PETSC_UINTPTR_T)a) == PETSC_NULL_DOUBLE_Fortran) 82 #define FORTRANNULLBOOL(a) (((void *)(PETSC_UINTPTR_T)a) == PETSC_NULL_BOOL_Fortran) 83 #define FORTRANNULLENUM(a) ((((void *)(PETSC_UINTPTR_T)a) == PETSC_NULL_ENUM_Fortran) || (((void *)(PETSC_UINTPTR_T)a) == (void *)-50)) 84 #define FORTRANNULLCHARACTER(a) (((void *)(PETSC_UINTPTR_T)a) == PETSC_NULL_CHARACTER_Fortran) 85 #define FORTRANNULLFUNCTION(a) (((PetscFortranCallbackFn *)(PETSC_UINTPTR_T)a) == PETSC_NULL_FUNCTION_Fortran) 86 #define FORTRANNULLOBJECT(a) (*(void **)(PETSC_UINTPTR_T)a == (void *)0) 87 #define FORTRANNULLMPICOMM(a) (((void *)(PETSC_UINTPTR_T)a) == PETSC_NULL_MPI_COMM_Fortran) 88 89 /* 90 A Fortran object with a value of (void*) 0 is indicated in Fortran by PETSC_NULL_XXXX, it is passed to routines to indicate the argument value is not requested or provided 91 similar to how NULL is used with PETSc objects in C 92 93 A Fortran object with a value of (void*) PETSC_FORTRAN_TYPE_INITIALIZE is an object that was never created or was destroyed (see checkFortranTypeInitialize()). 94 95 A Fortran object with a value of (void*) PETSC_FORTRAN_TYPE_NULL_RETURN happens when a PETSc routine returns in one of its arguments a NULL object 96 (it cannot return a value of (void*) PETSC_FORTRAN_TYPE_NULL because if later the returned variable is passed to a creation routine, it would think one has passed in a PETSC_NULL_XXX and error). 97 98 These three values are used because Fortran always uses pass by reference so one cannot pass a NULL address, only an address with special 99 values at the location. 100 101 PETSC_FORTRAN_TYPE_INITIALIZE is also defined in include/petsc/finclude/petscsysbase.h 102 */ 103 #define PETSC_FORTRAN_TYPE_INITIALIZE (void *)-2 104 #define PETSC_FORTRAN_TYPE_NULL_RETURN (void *)-3 105 106 #define CHKFORTRANNULL(a) \ 107 do { \ 108 if (FORTRANNULLINTEGER(a) || FORTRANNULLENUM(a) || FORTRANNULLDOUBLE(a) || FORTRANNULLSCALAR(a) || FORTRANNULLREAL(a) || FORTRANNULLBOOL(a) || FORTRANNULLFUNCTION(a) || FORTRANNULLCHARACTER(a) || FORTRANNULLMPICOMM(a)) a = PETSC_NULLPTR; \ 109 } while (0) 110 111 #define CHKFORTRANNULLENUM(a) \ 112 do { \ 113 if (FORTRANNULLENUM(a)) a = PETSC_NULLPTR; \ 114 } while (0) 115 116 #define CHKFORTRANNULLINTEGER(a) \ 117 do { \ 118 if (FORTRANNULLINTEGER(a) || FORTRANNULLENUM(a)) a = PETSC_NULLPTR; \ 119 else if (FORTRANNULLDOUBLE(a) || FORTRANNULLSCALAR(a) || FORTRANNULLREAL(a) || FORTRANNULLBOOL(a) || FORTRANNULLFUNCTION(a) || FORTRANNULLCHARACTER(a) || FORTRANNULLMPICOMM(a)) { \ 120 *ierr = PetscError(PETSC_COMM_SELF, __LINE__, PETSC_FUNCTION_NAME, __FILE__, PETSC_ERR_ARG_WRONG, PETSC_ERROR_INITIAL, "Use PETSC_NULL_INTEGER"); \ 121 *ierr = PETSC_ERR_ARG_BADPTR; \ 122 return; \ 123 } \ 124 } while (0) 125 126 #define CHKFORTRANNULLSCALAR(a) \ 127 do { \ 128 if (FORTRANNULLSCALAR(a)) { \ 129 a = PETSC_NULLPTR; \ 130 } else if (FORTRANNULLINTEGER(a) || FORTRANNULLDOUBLE(a) || FORTRANNULLREAL(a) || FORTRANNULLBOOL(a) || FORTRANNULLFUNCTION(a) || FORTRANNULLCHARACTER(a) || FORTRANNULLMPICOMM(a)) { \ 131 *ierr = PetscError(PETSC_COMM_SELF, __LINE__, PETSC_FUNCTION_NAME, __FILE__, PETSC_ERR_ARG_WRONG, PETSC_ERROR_INITIAL, "Use PETSC_NULL_SCALAR"); \ 132 *ierr = PETSC_ERR_ARG_BADPTR; \ 133 return; \ 134 } \ 135 } while (0) 136 137 #define CHKFORTRANNULLDOUBLE(a) \ 138 do { \ 139 if (FORTRANNULLDOUBLE(a)) { \ 140 a = PETSC_NULLPTR; \ 141 } else if (FORTRANNULLINTEGER(a) || FORTRANNULLSCALAR(a) || FORTRANNULLREAL(a) || FORTRANNULLBOOL(a) || FORTRANNULLFUNCTION(a) || FORTRANNULLCHARACTER(a) || FORTRANNULLMPICOMM(a)) { \ 142 *ierr = PetscError(PETSC_COMM_SELF, __LINE__, PETSC_FUNCTION_NAME, __FILE__, PETSC_ERR_ARG_WRONG, PETSC_ERROR_INITIAL, "Use PETSC_NULL_DOUBLE"); \ 143 *ierr = PETSC_ERR_ARG_BADPTR; \ 144 return; \ 145 } \ 146 } while (0) 147 148 #define CHKFORTRANNULLREAL(a) \ 149 do { \ 150 if (FORTRANNULLREAL(a)) { \ 151 a = PETSC_NULLPTR; \ 152 } else if (FORTRANNULLINTEGER(a) || FORTRANNULLDOUBLE(a) || FORTRANNULLSCALAR(a) || FORTRANNULLBOOL(a) || FORTRANNULLFUNCTION(a) || FORTRANNULLCHARACTER(a) || FORTRANNULLMPICOMM(a)) { \ 153 *ierr = PetscError(PETSC_COMM_SELF, __LINE__, PETSC_FUNCTION_NAME, __FILE__, PETSC_ERR_ARG_WRONG, PETSC_ERROR_INITIAL, "Use PETSC_NULL_REAL"); \ 154 *ierr = PETSC_ERR_ARG_BADPTR; \ 155 return; \ 156 } \ 157 } while (0) 158 159 #define CHKFORTRANNULLOBJECT(a) \ 160 do { \ 161 if (!(*(void **)a)) { \ 162 a = PETSC_NULLPTR; \ 163 } else if (FORTRANNULLINTEGER(a) || FORTRANNULLDOUBLE(a) || FORTRANNULLSCALAR(a) || FORTRANNULLREAL(a) || FORTRANNULLBOOL(a) || FORTRANNULLFUNCTION(a) || FORTRANNULLCHARACTER(a) || FORTRANNULLMPICOMM(a)) { \ 164 *ierr = PetscError(PETSC_COMM_SELF, __LINE__, PETSC_FUNCTION_NAME, __FILE__, PETSC_ERR_ARG_WRONG, PETSC_ERROR_INITIAL, "Use PETSC_NULL_XXX where XXX is the name of a particular object class"); \ 165 *ierr = PETSC_ERR_ARG_BADPTR; \ 166 return; \ 167 } \ 168 } while (0) 169 170 #define CHKFORTRANNULLBOOL(a) \ 171 do { \ 172 if (FORTRANNULLBOOL(a)) { \ 173 a = PETSC_NULLPTR; \ 174 } else if (FORTRANNULLSCALAR(a) || FORTRANNULLINTEGER(a) || FORTRANNULLDOUBLE(a) || FORTRANNULLSCALAR(a) || FORTRANNULLREAL(a) || FORTRANNULLFUNCTION(a) || FORTRANNULLCHARACTER(a) || FORTRANNULLMPICOMM(a)) { \ 175 *ierr = PetscError(PETSC_COMM_SELF, __LINE__, PETSC_FUNCTION_NAME, __FILE__, PETSC_ERR_ARG_WRONG, PETSC_ERROR_INITIAL, "Use PETSC_NULL_BOOL"); \ 176 *ierr = PETSC_ERR_ARG_BADPTR; \ 177 return; \ 178 } \ 179 } while (0) 180 181 #define CHKFORTRANNULLFUNCTION(a) \ 182 do { \ 183 if (FORTRANNULLFUNCTION(a)) { \ 184 a = PETSC_NULLPTR; \ 185 } else if (FORTRANNULLOBJECT(a) || FORTRANNULLSCALAR(a) || FORTRANNULLDOUBLE(a) || FORTRANNULLREAL(a) || FORTRANNULLINTEGER(a) || FORTRANNULLBOOL(a) || FORTRANNULLCHARACTER(a) || FORTRANNULLMPICOMM(a)) { \ 186 *ierr = PetscError(PETSC_COMM_SELF, __LINE__, PETSC_FUNCTION_NAME, __FILE__, PETSC_ERR_ARG_WRONG, PETSC_ERROR_INITIAL, "Use PETSC_NULL_FUNCTION"); \ 187 *ierr = PETSC_ERR_ARG_BADPTR; \ 188 return; \ 189 } \ 190 } while (0) 191 192 #define CHKFORTRANNULLMPICOMM(a) \ 193 do { \ 194 if (FORTRANNULLMPICOMM(a)) { \ 195 a = PETSC_NULLPTR; \ 196 } else if (FORTRANNULLINTEGER(a) || FORTRANNULLDOUBLE(a) || FORTRANNULLSCALAR(a) || FORTRANNULLREAL(a) || FORTRANNULLBOOL(a) || FORTRANNULLFUNCTION(a) || FORTRANNULLCHARACTER(a)) { \ 197 *ierr = PetscError(PETSC_COMM_SELF, __LINE__, PETSC_FUNCTION_NAME, __FILE__, PETSC_ERR_ARG_WRONG, PETSC_ERROR_INITIAL, "Use PETSC_NULL_MPI_COMM"); \ 198 *ierr = PETSC_ERR_ARG_BADPTR; \ 199 return; \ 200 } \ 201 } while (0) 202 203 /* In the beginning of Fortran XxxCreate() ensure object is not NULL or already created */ 204 #define PETSC_FORTRAN_OBJECT_CREATE(a) \ 205 do { \ 206 if (!(*(void **)a)) { \ 207 *ierr = PetscError(PETSC_COMM_SELF, __LINE__, PETSC_FUNCTION_NAME, __FILE__, PETSC_ERR_ARG_WRONG, PETSC_ERROR_INITIAL, "Cannot create PETSC_NULL_XXX object"); \ 208 *ierr = PETSC_ERR_ARG_WRONG; \ 209 return; \ 210 } else if (*((void **)(a)) != PETSC_FORTRAN_TYPE_INITIALIZE && *((void **)(a)) != PETSC_FORTRAN_TYPE_NULL_RETURN) { \ 211 *ierr = PetscError(PETSC_COMM_SELF, __LINE__, PETSC_FUNCTION_NAME, __FILE__, PETSC_ERR_ARG_WRONG, PETSC_ERROR_INITIAL, "Cannot create already existing object"); \ 212 *ierr = PETSC_ERR_ARG_WRONG; \ 213 return; \ 214 } \ 215 } while (0) 216 217 /* 218 In the beginning of Fortran XxxDestroy(a), if the input object was destroyed, change it to a PETSc C NULL object so that it won't crash C XxxDestory() 219 If it is PETSC_NULL_XXX just return since these objects cannot be destroyed 220 */ 221 #define PETSC_FORTRAN_OBJECT_F_DESTROYED_TO_C_NULL(a) \ 222 do { \ 223 if (!*(void **)a || *((void **)(a)) == PETSC_FORTRAN_TYPE_INITIALIZE || *((void **)(a)) == PETSC_FORTRAN_TYPE_NULL_RETURN) { \ 224 *ierr = PETSC_SUCCESS; \ 225 return; \ 226 } \ 227 } while (0) 228 229 /* After C XxxDestroy(a) is called, change a's state from NULL to destroyed, so that it can be used/destroyed again by Fortran. 230 E.g., in VecScatterCreateToAll(x,vscat,seq,ierr), if seq = PETSC_NULL_VEC, PETSc won't create seq. But if seq is a 231 destroyed object (e.g., as a result of a previous Fortran VecDestroy), PETSc will create seq. 232 */ 233 #define PETSC_FORTRAN_OBJECT_C_NULL_TO_F_DESTROYED(a) \ 234 do { \ 235 *((void **)(a)) = PETSC_FORTRAN_TYPE_INITIALIZE; \ 236 } while (0) 237 238 /* 239 Variable type where we stash PETSc object pointers in Fortran. 240 */ 241 typedef PETSC_UINTPTR_T PetscFortranAddr; 242 243 /* 244 These are used to support the default viewers that are 245 created at run time, in C using the , trick. 246 247 The numbers here must match the numbers in include/petsc/finclude/petscsys.h 248 */ 249 #define PETSC_VIEWER_DRAW_WORLD_FORTRAN 4 250 #define PETSC_VIEWER_DRAW_SELF_FORTRAN 5 251 #define PETSC_VIEWER_SOCKET_WORLD_FORTRAN 6 252 #define PETSC_VIEWER_SOCKET_SELF_FORTRAN 7 253 #define PETSC_VIEWER_STDOUT_WORLD_FORTRAN 8 254 #define PETSC_VIEWER_STDOUT_SELF_FORTRAN 9 255 #define PETSC_VIEWER_STDERR_WORLD_FORTRAN 10 256 #define PETSC_VIEWER_STDERR_SELF_FORTRAN 11 257 #define PETSC_VIEWER_BINARY_WORLD_FORTRAN 12 258 #define PETSC_VIEWER_BINARY_SELF_FORTRAN 13 259 #define PETSC_VIEWER_MATLAB_WORLD_FORTRAN 14 260 #define PETSC_VIEWER_MATLAB_SELF_FORTRAN 15 261 262 #include <petscviewer.h> 263 264 static inline PetscViewer PetscPatchDefaultViewers(PetscViewer *v) 265 { 266 if (!v) return PETSC_NULLPTR; 267 if (!(*(void **)v)) return PETSC_NULLPTR; 268 switch (*(PetscFortranAddr *)v) { 269 case PETSC_VIEWER_DRAW_WORLD_FORTRAN: 270 return PETSC_VIEWER_DRAW_WORLD; 271 case PETSC_VIEWER_DRAW_SELF_FORTRAN: 272 return PETSC_VIEWER_DRAW_SELF; 273 274 case PETSC_VIEWER_STDOUT_WORLD_FORTRAN: 275 return PETSC_VIEWER_STDOUT_WORLD; 276 case PETSC_VIEWER_STDOUT_SELF_FORTRAN: 277 return PETSC_VIEWER_STDOUT_SELF; 278 279 case PETSC_VIEWER_STDERR_WORLD_FORTRAN: 280 return PETSC_VIEWER_STDERR_WORLD; 281 case PETSC_VIEWER_STDERR_SELF_FORTRAN: 282 return PETSC_VIEWER_STDERR_SELF; 283 284 case PETSC_VIEWER_BINARY_WORLD_FORTRAN: 285 return PETSC_VIEWER_BINARY_WORLD; 286 case PETSC_VIEWER_BINARY_SELF_FORTRAN: 287 return PETSC_VIEWER_BINARY_SELF; 288 289 #if defined(PETSC_HAVE_MATLAB) 290 case PETSC_VIEWER_MATLAB_SELF_FORTRAN: 291 return PETSC_VIEWER_MATLAB_SELF; 292 case PETSC_VIEWER_MATLAB_WORLD_FORTRAN: 293 return PETSC_VIEWER_MATLAB_WORLD; 294 #endif 295 296 #if defined(PETSC_USE_SOCKET_VIEWER) 297 case PETSC_VIEWER_SOCKET_WORLD_FORTRAN: 298 return PETSC_VIEWER_SOCKET_WORLD; 299 case PETSC_VIEWER_SOCKET_SELF_FORTRAN: 300 return PETSC_VIEWER_SOCKET_SELF; 301 #endif 302 303 default: 304 return *v; 305 } 306 } 307 308 #if defined(PETSC_USE_SOCKET_VIEWER) 309 #define PetscPatchDefaultViewers_Fortran_Socket(vin, v) \ 310 } \ 311 else if ((*(PetscFortranAddr *)vin) == PETSC_VIEWER_SOCKET_WORLD_FORTRAN) \ 312 { \ 313 v = PETSC_VIEWER_SOCKET_WORLD; \ 314 } \ 315 else if ((*(PetscFortranAddr *)vin) == PETSC_VIEWER_SOCKET_SELF_FORTRAN) \ 316 { \ 317 v = PETSC_VIEWER_SOCKET_SELF 318 #else 319 #define PetscPatchDefaultViewers_Fortran_Socket(vin, v) 320 #endif 321 322 #define PetscPatchDefaultViewers_Fortran(vin, v) \ 323 do { \ 324 if ((*(PetscFortranAddr *)vin) == PETSC_VIEWER_DRAW_WORLD_FORTRAN) { \ 325 v = PETSC_VIEWER_DRAW_WORLD; \ 326 } else if ((*(PetscFortranAddr *)vin) == PETSC_VIEWER_DRAW_SELF_FORTRAN) { \ 327 v = PETSC_VIEWER_DRAW_SELF; \ 328 } else if ((*(PetscFortranAddr *)vin) == PETSC_VIEWER_STDOUT_WORLD_FORTRAN) { \ 329 v = PETSC_VIEWER_STDOUT_WORLD; \ 330 } else if ((*(PetscFortranAddr *)vin) == PETSC_VIEWER_STDOUT_SELF_FORTRAN) { \ 331 v = PETSC_VIEWER_STDOUT_SELF; \ 332 } else if ((*(PetscFortranAddr *)vin) == PETSC_VIEWER_STDERR_WORLD_FORTRAN) { \ 333 v = PETSC_VIEWER_STDERR_WORLD; \ 334 } else if ((*(PetscFortranAddr *)vin) == PETSC_VIEWER_STDERR_SELF_FORTRAN) { \ 335 v = PETSC_VIEWER_STDERR_SELF; \ 336 } else if ((*(PetscFortranAddr *)vin) == PETSC_VIEWER_BINARY_WORLD_FORTRAN) { \ 337 v = PETSC_VIEWER_BINARY_WORLD; \ 338 } else if ((*(PetscFortranAddr *)vin) == PETSC_VIEWER_BINARY_SELF_FORTRAN) { \ 339 v = PETSC_VIEWER_BINARY_SELF; \ 340 } else if ((*(PetscFortranAddr *)vin) == PETSC_VIEWER_MATLAB_WORLD_FORTRAN) { \ 341 v = PETSC_VIEWER_BINARY_WORLD; \ 342 } else if ((*(PetscFortranAddr *)vin) == PETSC_VIEWER_MATLAB_SELF_FORTRAN) { \ 343 v = PETSC_VIEWER_BINARY_SELF; \ 344 PetscPatchDefaultViewers_Fortran_Socket(vin, v); \ 345 } else { \ 346 v = *vin; \ 347 } \ 348 } while (0) 349 350 /* 351 Allocates enough space to store Fortran function pointers in PETSc object 352 that are needed by the Fortran interface. 353 */ 354 #define PetscObjectAllocateFortranPointers(obj, N) \ 355 do { \ 356 if (!((PetscObject)(obj))->fortran_func_pointers) { \ 357 *ierr = PetscCalloc((N) * sizeof(PetscFortranCallbackFn *), &((PetscObject)(obj))->fortran_func_pointers); \ 358 if (*ierr) return; \ 359 ((PetscObject)obj)->num_fortran_func_pointers = (N); \ 360 } \ 361 } while (0) 362 363 #define PetscCallFortranVoidFunction(...) \ 364 do { \ 365 PetscErrorCode ierr = PETSC_SUCCESS; \ 366 /* the function may or may not access ierr */ \ 367 __VA_ARGS__; \ 368 PetscCall(ierr); \ 369 } while (0) 370 371 /* Entire function body, _ctx is a "special" variable that can be passed along */ 372 #define PetscObjectUseFortranCallback_Private(obj, cid, types, args, cbclass) \ 373 do { \ 374 void(*func) types, *_ctx; \ 375 PetscFunctionBegin; \ 376 PetscCall(PetscObjectGetFortranCallback((PetscObject)(obj), (cbclass), (cid), (PetscFortranCallbackFn **)&func, &_ctx)); \ 377 if (func) PetscCallFortranVoidFunction((*func)args); \ 378 PetscFunctionReturn(PETSC_SUCCESS); \ 379 } while (0) 380 #define PetscObjectUseFortranCallback(obj, cid, types, args) PetscObjectUseFortranCallback_Private(obj, cid, types, args, PETSC_FORTRAN_CALLBACK_CLASS) 381 #define PetscObjectUseFortranCallbackSubType(obj, cid, types, args) PetscObjectUseFortranCallback_Private(obj, cid, types, args, PETSC_FORTRAN_CALLBACK_SUBTYPE) 382 383 /* Disable deprecation warnings while building Fortran wrappers */ 384 #undef PETSC_DEPRECATED_OBJECT 385 #define PETSC_DEPRECATED_OBJECT(...) 386 #undef PETSC_DEPRECATED_FUNCTION 387 #define PETSC_DEPRECATED_FUNCTION(...) 388 #undef PETSC_DEPRECATED_ENUM 389 #define PETSC_DEPRECATED_ENUM(...) 390 #undef PETSC_DEPRECATED_TYPEDEF 391 #define PETSC_DEPRECATED_TYPEDEF(...) 392 #undef PETSC_DEPRECATED_MACRO 393 #define PETSC_DEPRECATED_MACRO(...) 394 395 /* PGI compilers pass in f90 pointers as 2 arguments */ 396 #if defined(PETSC_HAVE_F90_2PTR_ARG) 397 #define PETSC_F90_2PTR_PROTO_NOVAR , void * 398 #define PETSC_F90_2PTR_PROTO(ptr) , void *ptr 399 #define PETSC_F90_2PTR_PARAM(ptr) , ptr 400 #else 401 #define PETSC_F90_2PTR_PROTO_NOVAR 402 #define PETSC_F90_2PTR_PROTO(ptr) 403 #define PETSC_F90_2PTR_PARAM(ptr) 404 #endif 405 406 typedef struct { 407 char dummy; 408 } F90Array1d; 409 typedef struct { 410 char dummy; 411 } F90Array2d; 412 typedef struct { 413 char dummy; 414 } F90Array3d; 415 typedef struct { 416 char dummy; 417 } F90Array4d; 418 419 PETSC_EXTERN PetscErrorCode F90Array1dCreate(void *, MPI_Datatype, PetscInt, PetscInt, F90Array1d *PETSC_F90_2PTR_PROTO_NOVAR); 420 PETSC_EXTERN PetscErrorCode F90Array1dAccess(F90Array1d *, MPI_Datatype, void **PETSC_F90_2PTR_PROTO_NOVAR); 421 PETSC_EXTERN PetscErrorCode F90Array1dDestroy(F90Array1d *, MPI_Datatype PETSC_F90_2PTR_PROTO_NOVAR); 422 423 PETSC_EXTERN PetscErrorCode F90Array2dCreate(void *, MPI_Datatype, PetscInt, PetscInt, PetscInt, PetscInt, F90Array2d *PETSC_F90_2PTR_PROTO_NOVAR); 424 PETSC_EXTERN PetscErrorCode F90Array2dAccess(F90Array2d *, MPI_Datatype, void **PETSC_F90_2PTR_PROTO_NOVAR); 425 PETSC_EXTERN PetscErrorCode F90Array2dDestroy(F90Array2d *, MPI_Datatype PETSC_F90_2PTR_PROTO_NOVAR); 426 427 PETSC_EXTERN PetscErrorCode F90Array3dCreate(void *, MPI_Datatype, PetscInt, PetscInt, PetscInt, PetscInt, PetscInt, PetscInt, F90Array3d *PETSC_F90_2PTR_PROTO_NOVAR); 428 PETSC_EXTERN PetscErrorCode F90Array3dAccess(F90Array3d *, MPI_Datatype, void **PETSC_F90_2PTR_PROTO_NOVAR); 429 PETSC_EXTERN PetscErrorCode F90Array3dDestroy(F90Array3d *, MPI_Datatype PETSC_F90_2PTR_PROTO_NOVAR); 430 431 PETSC_EXTERN PetscErrorCode F90Array4dCreate(void *, MPI_Datatype, PetscInt, PetscInt, PetscInt, PetscInt, PetscInt, PetscInt, PetscInt, PetscInt, F90Array4d *PETSC_F90_2PTR_PROTO_NOVAR); 432 PETSC_EXTERN PetscErrorCode F90Array4dAccess(F90Array4d *, MPI_Datatype, void **PETSC_F90_2PTR_PROTO_NOVAR); 433 PETSC_EXTERN PetscErrorCode F90Array4dDestroy(F90Array4d *, MPI_Datatype PETSC_F90_2PTR_PROTO_NOVAR); 434 435 /* 436 F90Array1dCreate - Given a C pointer to a one dimensional 437 array and its length; this fills in the appropriate Fortran 90 438 pointer data structure. 439 440 Input Parameters: 441 + array - regular C pointer (address) 442 . type - DataType of the array 443 . start - starting index of the array 444 - len - length of array (in items) 445 446 Output Parameter: 447 . ptr - Fortran 90 pointer 448 */ 449