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 PETSC_INTERN PetscErrorCode PetscPreMPIInit_Private(void); 108 109 PETSC_INTERN PetscErrorCode PetscInitFortran_Private(const char *filename, PetscInt len) 110 { 111 char *tmp = NULL; 112 113 PetscFunctionBegin; 114 PetscCall(PetscInitializeFortran()); 115 PetscCall(PETScParseFortranArgs_Private(&PetscGlobalArgc, &PetscGlobalArgsFortran)); 116 PetscGlobalArgs = PetscGlobalArgsFortran; 117 if (filename != PETSC_NULL_CHARACTER_Fortran) { /* filename comes from Fortran so may have blanking padding that needs removal */ 118 while ((len > 0) && (filename[len - 1] == ' ')) len--; 119 PetscCall(PetscMalloc1(len + 1, &tmp)); 120 PetscCall(PetscStrncpy(tmp, filename, len + 1)); 121 } 122 PetscCall(PetscOptionsInsert(NULL, &PetscGlobalArgc, &PetscGlobalArgsFortran, tmp)); 123 PetscCall(PetscFree(tmp)); 124 PetscFunctionReturn(PETSC_SUCCESS); 125 } 126 127 PETSC_EXTERN void petscinitializef_(char *filename, char *help, PetscErrorCode *ierr, PETSC_FORTRAN_CHARLEN_T len, PETSC_FORTRAN_CHARLEN_T helplen) 128 { 129 int j, i; 130 int flag; 131 char name[256] = {0}; 132 PetscMPIInt f_petsc_comm_world; 133 134 *ierr = PETSC_SUCCESS; 135 if (PetscInitializeCalled) return; 136 i = 0; 137 petscgetcommandargument_(&i, name, sizeof(name)); 138 /* Eliminate spaces at the end of the string */ 139 for (j = sizeof(name) - 2; j >= 0; j--) { 140 if (name[j] != ' ') { 141 name[j + 1] = 0; 142 break; 143 } 144 } 145 if (j < 0) { 146 *ierr = PetscStrncpy(name, "Unknown Name", 256); 147 if (*ierr) return; 148 } 149 150 /* check if PETSC_COMM_WORLD is initialized by the user in Fortran */ 151 petscgetcomm_(&f_petsc_comm_world); 152 MPI_Initialized(&flag); 153 if (!flag) { 154 PetscMPIInt mierr; 155 156 if (f_petsc_comm_world) { 157 *ierr = (*PetscErrorPrintf)("You cannot set PETSC_COMM_WORLD if you have not initialized MPI first\n"); 158 return; 159 } 160 161 *ierr = PetscPreMPIInit_Private(); 162 if (*ierr) return; 163 mpi_init_(&mierr); 164 if (mierr) { 165 *ierr = (*PetscErrorPrintf)("PetscInitialize: Calling Fortran MPI_Init()\n"); 166 *ierr = (PetscErrorCode)mierr; 167 return; 168 } 169 PetscBeganMPI = PETSC_TRUE; 170 } 171 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 */ 172 else PETSC_COMM_WORLD = MPI_COMM_WORLD; 173 174 *ierr = PetscInitialize_Common(name, filename, help, PETSC_TRUE, (PetscInt)len); 175 if (*ierr) { 176 (void)(*PetscErrorPrintf)("PetscInitialize:PetscInitialize_Common\n"); 177 return; 178 } 179 } 180