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