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 mpi_init_ MPI_INIT 21 #define petscgetcomm_ PETSCGETCOMM 22 #define petsccommandargumentcount_ PETSCCOMMANDARGUMENTCOUNT 23 #define petscgetcommandargument_ PETSCGETCOMMANDARGUMENT 24 #elif !defined(PETSC_HAVE_FORTRAN_UNDERSCORE) 25 #define petscinitializef_ petscinitializef 26 #define petscfinalize_ petscfinalize 27 #define petscend_ petscend 28 #define mpi_init_ mpi_init 29 #define petscgetcomm_ petscgetcomm 30 #define petsccommandargumentcount_ petsccommandargumentcount 31 #define petscgetcommandargument_ petscgetcommandargument 32 #endif 33 34 /* 35 The extra _ is because the f2c compiler puts an 36 extra _ at the end if the original routine name 37 contained any _. 38 */ 39 #if defined(PETSC_HAVE_FORTRAN_UNDERSCORE_UNDERSCORE) 40 #define mpi_init_ mpi_init__ 41 #endif 42 43 #if defined(PETSC_HAVE_MPIUNI) 44 #if defined(mpi_init_) 45 #undef mpi_init_ 46 #if defined(PETSC_HAVE_FORTRAN_CAPS) 47 #define mpi_init_ PETSC_MPI_INIT 48 #elif !defined(PETSC_HAVE_FORTRAN_UNDERSCORE) 49 #define mpi_init_ petsc_mpi_init 50 #elif defined(PETSC_HAVE_FORTRAN_UNDERSCORE_UNDERSCORE) 51 #define mpi_init_ petsc_mpi_init__ 52 #endif 53 #else /* mpi_init_ */ 54 #define mpi_init_ petsc_mpi_init_ 55 #endif /* mpi_init_ */ 56 #endif /* PETSC_HAVE_MPIUNI */ 57 58 PETSC_EXTERN void mpi_init_(int *); 59 PETSC_EXTERN void petscgetcomm_(PetscMPIInt *); 60 61 /* 62 Different Fortran compilers handle command lines in different ways 63 */ 64 PETSC_EXTERN int petsccommandargumentcount_(void); 65 PETSC_EXTERN void petscgetcommandargument_(int *, char *, PETSC_FORTRAN_CHARLEN_T); 66 PETSC_EXTERN PetscErrorCode PetscMallocAlign(size_t, PetscBool, int, const char[], const char[], void **); 67 PETSC_EXTERN PetscErrorCode PetscFreeAlign(void *, int, const char[], const char[]); 68 PETSC_INTERN int PetscGlobalArgc; 69 PETSC_INTERN char **PetscGlobalArgs; 70 71 /* 72 Reads in Fortran command line arguments and sends them to 73 all processors. 74 */ 75 76 PetscErrorCode PETScParseFortranArgs_Private(int *argc, char ***argv) 77 { 78 int i; 79 int warg = 256; 80 PetscMPIInt rank; 81 char *p; 82 83 PetscCallMPI(MPI_Comm_rank(PETSC_COMM_WORLD, &rank)); 84 if (rank == 0) { *argc = 1 + petsccommandargumentcount_(); } 85 PetscCallMPI(MPI_Bcast(argc, 1, MPI_INT, 0, PETSC_COMM_WORLD)); 86 87 /* PetscTrMalloc() not yet set, so don't use PetscMalloc() */ 88 PetscCall(PetscMallocAlign((*argc + 1) * (warg * sizeof(char) + sizeof(char *)), PETSC_FALSE, 0, NULL, NULL, (void **)argv)); 89 (*argv)[0] = (char *)(*argv + *argc + 1); 90 91 if (rank == 0) { 92 PetscCall(PetscMemzero((*argv)[0], (*argc) * warg * sizeof(char))); 93 for (i = 0; i < *argc; i++) { 94 (*argv)[i + 1] = (*argv)[i] + warg; 95 petscgetcommandargument_(&i, (*argv)[i], warg); 96 /* zero out garbage at end of each argument */ 97 p = (*argv)[i] + warg - 1; 98 while (p > (*argv)[i]) { 99 if (*p == ' ') *p = 0; 100 p--; 101 } 102 } 103 } 104 PetscCallMPI(MPI_Bcast((*argv)[0], *argc * warg, MPI_CHAR, 0, PETSC_COMM_WORLD)); 105 if (rank) { 106 for (i = 0; i < *argc; i++) (*argv)[i + 1] = (*argv)[i] + warg; 107 } 108 return PETSC_SUCCESS; 109 } 110 111 /* -----------------------------------------------------------------------------------------------*/ 112 113 PETSC_INTERN PetscErrorCode PetscPreMPIInit_Private(void); 114 115 PETSC_INTERN PetscErrorCode PetscInitFortran_Private(PetscBool readarguments, const char *filename, PetscInt len) 116 { 117 char *tmp = NULL; 118 119 PetscFunctionBegin; 120 PetscCall(PetscInitializeFortran()); 121 if (readarguments) { 122 PetscCall(PETScParseFortranArgs_Private(&PetscGlobalArgc, &PetscGlobalArgs)); 123 if (filename != PETSC_NULL_CHARACTER_Fortran) { /* FIXCHAR */ 124 while ((len > 0) && (filename[len - 1] == ' ')) len--; 125 PetscCall(PetscMalloc1(len + 1, &tmp)); 126 PetscCall(PetscStrncpy(tmp, filename, len + 1)); 127 } 128 PetscCall(PetscOptionsInsert(NULL, &PetscGlobalArgc, &PetscGlobalArgs, tmp)); 129 PetscCall(PetscFree(tmp)); /* FREECHAR */ 130 } 131 PetscFunctionReturn(PETSC_SUCCESS); 132 } 133 134 /* 135 petscinitialize - Version called from Fortran. 136 137 Note: 138 Since this is called from Fortran it does not return error codes 139 140 */ 141 PETSC_EXTERN void petscinitializef_(char *filename, char *help, PetscBool *readarguments, PetscErrorCode *ierr, PETSC_FORTRAN_CHARLEN_T len, PETSC_FORTRAN_CHARLEN_T helplen) 142 { 143 int j, i; 144 int flag; 145 char name[256] = {0}; 146 PetscMPIInt f_petsc_comm_world; 147 148 *ierr = PETSC_SUCCESS; 149 if (PetscInitializeCalled) return; 150 i = 0; 151 petscgetcommandargument_(&i, name, sizeof(name)); 152 /* Eliminate spaces at the end of the string */ 153 for (j = sizeof(name) - 2; j >= 0; j--) { 154 if (name[j] != ' ') { 155 name[j + 1] = 0; 156 break; 157 } 158 } 159 if (j < 0) { 160 *ierr = PetscStrncpy(name, "Unknown Name", 256); 161 if (*ierr) return; 162 } 163 164 /* check if PETSC_COMM_WORLD is initialized by the user in Fortran */ 165 petscgetcomm_(&f_petsc_comm_world); 166 MPI_Initialized(&flag); 167 if (!flag) { 168 PetscMPIInt mierr; 169 170 if (f_petsc_comm_world) { 171 *ierr = (*PetscErrorPrintf)("You cannot set PETSC_COMM_WORLD if you have not initialized MPI first\n"); 172 return; 173 } 174 175 *ierr = PetscPreMPIInit_Private(); 176 if (*ierr) return; 177 mpi_init_(&mierr); 178 if (mierr) { 179 *ierr = (*PetscErrorPrintf)("PetscInitialize: Calling Fortran MPI_Init()\n"); 180 *ierr = (PetscErrorCode)mierr; 181 return; 182 } 183 PetscBeganMPI = PETSC_TRUE; 184 } 185 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 */ 186 else PETSC_COMM_WORLD = MPI_COMM_WORLD; 187 188 *ierr = PetscInitialize_Common(name, filename, help, PETSC_TRUE, *readarguments, (PetscInt)len); 189 if (*ierr) { 190 (void)(*PetscErrorPrintf)("PetscInitialize:PetscInitialize_Common\n"); 191 return; 192 } 193 } 194 195 PETSC_EXTERN void petscfinalize_(PetscErrorCode *ierr) 196 { 197 /* was malloced with PetscMallocAlign() so free the same way */ 198 *ierr = PetscFreeAlign(PetscGlobalArgs, 0, NULL, NULL); 199 if (*ierr) { 200 (void)(*PetscErrorPrintf)("PetscFinalize:Freeing args\n"); 201 return; 202 } 203 204 *ierr = PetscFinalize(); 205 } 206 207 PETSC_EXTERN void petscend_(PetscErrorCode *ierr) 208 { 209 *ierr = PetscEnd(); 210 } 211