1 /* 2 This file contains Fortran stubs for PetscInitialize and Finalize. 3 */ 4 5 /* 6 This is to prevent the Cray T3D version of MPI (University of Edinburgh) 7 from stupidly redefining MPI_INIT(). They put this in to detect errors 8 in C code,but here I do want to be calling the Fortran version from a 9 C subroutine. 10 */ 11 #define T3DMPI_FORTRAN 12 #define T3EMPI_FORTRAN 13 14 #include <petsc/private/fortranimpl.h> 15 16 #if defined(PETSC_HAVE_FORTRAN_CAPS) 17 #define petscinitializef_ PETSCINITIALIZEF 18 #define petscfinalize_ PETSCFINALIZE 19 #define petscend_ PETSCEND 20 #define iargc_ IARGC 21 #define getarg_ GETARG 22 #define mpi_init_ MPI_INIT 23 #define petscgetcomm_ PETSCGETCOMM 24 #define petsccommandargumentcount_ PETSCCOMMANDARGUMENTCOUNT 25 #define petscgetcommandargument_ PETSCGETCOMMANDARGUMENT 26 #elif !defined(PETSC_HAVE_FORTRAN_UNDERSCORE) 27 #define petscinitializef_ petscinitializef 28 #define petscfinalize_ petscfinalize 29 #define petscend_ petscend 30 #define mpi_init_ mpi_init 31 #define iargc_ iargc 32 #define getarg_ getarg 33 #define petscgetcomm_ petscgetcomm 34 #define petsccommandargumentcount_ petsccommandargumentcount 35 #define petscgetcommandargument_ petscgetcommandargument 36 #endif 37 38 #if defined(PETSC_HAVE_NAGF90) 39 #undef iargc_ 40 #undef getarg_ 41 #define iargc_ f90_unix_MP_iargc 42 #define getarg_ f90_unix_MP_getarg 43 #endif 44 #if defined(PETSC_USE_NARGS) /* Digital Fortran */ 45 #undef iargc_ 46 #undef getarg_ 47 #define iargc_ NARGS 48 #define getarg_ GETARG 49 #elif defined(PETSC_HAVE_PXFGETARG_NEW) /* cray x1 */ 50 #undef iargc_ 51 #undef getarg_ 52 #define iargc_ ipxfargc_ 53 #define getarg_ pxfgetarg_ 54 #endif 55 56 #if defined(PETSC_HAVE_FORTRAN_GET_COMMAND_ARGUMENT) /* Fortran 2003 */ 57 #undef iargc_ 58 #undef getarg_ 59 #define iargc_ petsccommandargumentcount_ 60 #define getarg_ petscgetcommandargument_ 61 #elif defined(PETSC_HAVE_BGL_IARGC) /* bgl g77 has different external & internal name mangling */ 62 #undef iargc_ 63 #undef getarg_ 64 #define iargc iargc_ 65 #define getarg getarg_ 66 #endif 67 68 /* 69 The extra _ is because the f2c compiler puts an 70 extra _ at the end if the original routine name 71 contained any _. 72 */ 73 #if defined(PETSC_HAVE_FORTRAN_UNDERSCORE_UNDERSCORE) 74 #define mpi_init_ mpi_init__ 75 #endif 76 77 #if defined(PETSC_HAVE_MPIUNI) 78 #if defined(mpi_init_) 79 #undef mpi_init_ 80 #if defined(PETSC_HAVE_FORTRAN_CAPS) 81 #define mpi_init_ PETSC_MPI_INIT 82 #elif !defined(PETSC_HAVE_FORTRAN_UNDERSCORE) 83 #define mpi_init_ petsc_mpi_init 84 #elif defined(PETSC_HAVE_FORTRAN_UNDERSCORE_UNDERSCORE) 85 #define mpi_init_ petsc_mpi_init__ 86 #endif 87 #else /* mpi_init_ */ 88 #define mpi_init_ petsc_mpi_init_ 89 #endif /* mpi_init_ */ 90 #endif /* PETSC_HAVE_MPIUNI */ 91 92 PETSC_EXTERN void mpi_init_(int*); 93 PETSC_EXTERN void petscgetcomm_(PetscMPIInt*); 94 95 /* 96 Different Fortran compilers handle command lines in different ways 97 */ 98 #if defined(PETSC_HAVE_FORTRAN_GET_COMMAND_ARGUMENT) /* Fortran 2003 - same as 'else' case */ 99 PETSC_EXTERN int iargc_(void); 100 PETSC_EXTERN void getarg_(int*,char*,int); 101 #elif defined(PETSC_USE_NARGS) 102 PETSC_EXTERN short __stdcall NARGS(void); 103 PETSC_EXTERN void __stdcall GETARG(short*,char*,int,short *); 104 105 #elif defined(PETSC_HAVE_PXFGETARG_NEW) 106 PETSC_EXTERN int iargc_(void); 107 PETSC_EXTERN void getarg_(int*,char*,int*,int*,int); 108 109 #else 110 PETSC_EXTERN int iargc_(void); 111 PETSC_EXTERN void getarg_(int*,char*,int); 112 /* 113 The Cray T3D/T3E use the PXFGETARG() function 114 */ 115 #if defined(PETSC_HAVE_PXFGETARG) 116 PETSC_EXTERN void PXFGETARG(int*,_fcd,int*,int*); 117 #endif 118 #endif 119 120 PETSC_EXTERN PetscErrorCode PetscMallocAlign(size_t,PetscBool,int,const char[],const char[],void**); 121 PETSC_EXTERN PetscErrorCode PetscFreeAlign(void*,int,const char[],const char[]); 122 PETSC_INTERN int PetscGlobalArgc; 123 PETSC_INTERN char **PetscGlobalArgs; 124 125 /* 126 Reads in Fortran command line arguments and sends them to 127 all processors. 128 */ 129 130 PetscErrorCode PETScParseFortranArgs_Private(int *argc, char ***argv) 131 { 132 #if defined(PETSC_USE_NARGS) 133 short i, flg; 134 #else 135 int i; 136 #endif 137 int warg = 256; 138 PetscMPIInt rank; 139 char *p; 140 141 PetscCallMPI(MPI_Comm_rank(PETSC_COMM_WORLD, &rank)); 142 if (rank == 0) { 143 #if defined(PETSC_HAVE_IARG_COUNT_PROGNAME) 144 *argc = iargc_(); 145 #else 146 /* most compilers do not count the program name for argv[0] */ 147 *argc = 1 + iargc_(); 148 #endif 149 } 150 PetscCallMPI(MPI_Bcast(argc, 1, MPI_INT, 0, PETSC_COMM_WORLD)); 151 152 /* PetscTrMalloc() not yet set, so don't use PetscMalloc() */ 153 PetscCall(PetscMallocAlign((*argc + 1) * (warg * sizeof(char) + sizeof(char *)), PETSC_FALSE, 0, 0, 0, (void **)argv)); 154 (*argv)[0] = (char *)(*argv + *argc + 1); 155 156 if (rank == 0) { 157 PetscCall(PetscMemzero((*argv)[0], (*argc) * warg * sizeof(char))); 158 for (i = 0; i < *argc; i++) { 159 (*argv)[i + 1] = (*argv)[i] + warg; 160 #if defined(PETSC_HAVE_FORTRAN_GET_COMMAND_ARGUMENT) /* same as 'else' case */ 161 getarg_(&i, (*argv)[i], warg); 162 #elif defined(PETSC_HAVE_PXFGETARG_NEW) 163 { 164 char *tmp = (*argv)[i]; 165 int ilen; 166 PetscCallFortranVoidFunction(getarg_(&i, tmp, &ilen, &ierr, warg)); 167 tmp[ilen] = 0; 168 } 169 #elif defined(PETSC_USE_NARGS) 170 GETARG(&i, (*argv)[i], warg, &flg); 171 #else 172 getarg_(&i, (*argv)[i], warg); 173 #endif 174 /* zero out garbage at end of each argument */ 175 p = (*argv)[i] + warg - 1; 176 while (p > (*argv)[i]) { 177 if (*p == ' ') *p = 0; 178 p--; 179 } 180 } 181 } 182 PetscCallMPI(MPI_Bcast((*argv)[0], *argc * warg, MPI_CHAR, 0, PETSC_COMM_WORLD)); 183 if (rank) { 184 for (i = 0; i < *argc; i++) (*argv)[i + 1] = (*argv)[i] + warg; 185 } 186 return PETSC_SUCCESS; 187 } 188 189 /* -----------------------------------------------------------------------------------------------*/ 190 191 PETSC_INTERN PetscErrorCode PetscPreMPIInit_Private(void); 192 193 PETSC_INTERN PetscErrorCode PetscInitFortran_Private(PetscBool readarguments,const char *filename,PetscInt len) 194 { 195 char *tmp = NULL; 196 197 PetscFunctionBegin; 198 PetscCall(PetscInitializeFortran()); 199 if (readarguments) { 200 PetscCall(PETScParseFortranArgs_Private(&PetscGlobalArgc,&PetscGlobalArgs)); 201 if (filename != PETSC_NULL_CHARACTER_Fortran) { /* FIXCHAR */ 202 while ((len > 0) && (filename[len-1] == ' ')) len--; 203 PetscCall(PetscMalloc1(len+1,&tmp)); 204 PetscCall(PetscStrncpy(tmp,filename,len+1)); 205 } 206 PetscCall(PetscOptionsInsert(NULL,&PetscGlobalArgc,&PetscGlobalArgs,tmp)); 207 PetscCall(PetscFree(tmp)); /* FREECHAR */ 208 } 209 PetscFunctionReturn(PETSC_SUCCESS); 210 } 211 212 /* 213 petscinitialize - Version called from Fortran. 214 215 Note: 216 Since this is called from Fortran it does not return error codes 217 218 */ 219 PETSC_EXTERN void petscinitializef_(char *filename, char *help, PetscBool *readarguments, PetscErrorCode *ierr, PETSC_FORTRAN_CHARLEN_T len, PETSC_FORTRAN_CHARLEN_T helplen) 220 { 221 int j, i; 222 #if defined(PETSC_USE_NARGS) 223 short flg; 224 #endif 225 int flag; 226 char name[256] = {0}; 227 PetscMPIInt f_petsc_comm_world; 228 229 *ierr = PETSC_SUCCESS; 230 if (PetscInitializeCalled) return; 231 i = 0; 232 #if defined(PETSC_HAVE_FORTRAN_GET_COMMAND_ARGUMENT) /* same as 'else' case */ 233 getarg_(&i, name, sizeof(name)); 234 #elif defined(PETSC_HAVE_PXFGETARG_NEW) 235 { 236 int ilen, sierr; 237 getarg_(&i, name, &ilen, &sierr, 256); 238 if (sierr) { 239 *ierr = PetscStrncpy(name, "Unknown Name", 256); 240 if (*ierr) return; 241 } else name[ilen] = 0; 242 } 243 #elif defined(PETSC_USE_NARGS) 244 GETARG(&i, name, 256, &flg); 245 #else 246 getarg_(&i, name, 256); 247 #endif 248 /* Eliminate spaces at the end of the string */ 249 for (j = sizeof(name) - 2; j >= 0; j--) { 250 if (name[j] != ' ') { 251 name[j + 1] = 0; 252 break; 253 } 254 } 255 if (j < 0) { 256 *ierr = PetscStrncpy(name, "Unknown Name", 256); 257 if (*ierr) return; 258 } 259 260 /* check if PETSC_COMM_WORLD is initialized by the user in fortran */ 261 petscgetcomm_(&f_petsc_comm_world); 262 MPI_Initialized(&flag); 263 if (!flag) { 264 PetscMPIInt mierr; 265 266 if (f_petsc_comm_world) { 267 *ierr = (*PetscErrorPrintf)("You cannot set PETSC_COMM_WORLD if you have not initialized MPI first\n"); 268 return; 269 } 270 271 *ierr = PetscPreMPIInit_Private(); 272 if (*ierr) return; 273 mpi_init_(&mierr); 274 if (mierr) { 275 *ierr = (*PetscErrorPrintf)("PetscInitialize: Calling Fortran MPI_Init()\n"); 276 *ierr = (PetscErrorCode)mierr; 277 return; 278 } 279 PetscBeganMPI = PETSC_TRUE; 280 } 281 if (f_petsc_comm_world) PETSC_COMM_WORLD = MPI_Comm_f2c(*(MPI_Fint *)&f_petsc_comm_world); /* User called MPI_INITIALIZE() and changed PETSC_COMM_WORLD */ 282 else PETSC_COMM_WORLD = MPI_COMM_WORLD; 283 284 *ierr = PetscInitialize_Common(name, filename, help, PETSC_TRUE, *readarguments, (PetscInt)len); 285 if (*ierr) { 286 (void)(*PetscErrorPrintf)("PetscInitialize:PetscInitialize_Common\n"); 287 return; 288 } 289 } 290 291 PETSC_EXTERN void petscfinalize_(PetscErrorCode *ierr) 292 { 293 /* was malloced with PetscMallocAlign() so free the same way */ 294 *ierr = PetscFreeAlign(PetscGlobalArgs, 0, 0, 0); 295 if (*ierr) { 296 (void)(*PetscErrorPrintf)("PetscFinalize:Freeing args\n"); 297 return; 298 } 299 300 *ierr = PetscFinalize(); 301 } 302 303 PETSC_EXTERN void petscend_(PetscErrorCode *ierr) 304 { 305 *ierr = PetscEnd(); 306 } 307