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