Actual source code: zstart.c

  1: /*
  2:   This file contains Fortran stubs for PetscInitialize and Finalize.
  3: */

  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

 14: #include <petsc/private/fortranimpl.h>

 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

 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

 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 */

 58: PETSC_EXTERN void mpi_init_(int *);
 59: PETSC_EXTERN void petscgetcomm_(PetscMPIInt *);

 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;

 71: /*
 72:     Reads in Fortran command line arguments and sends them to
 73:   all processors.
 74: */

 76: PetscErrorCode PETScParseFortranArgs_Private(int *argc, char ***argv)
 77: {
 78:   int         i;
 79:   int         warg = 256;
 80:   PetscMPIInt rank;
 81:   char       *p;

 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));

 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);

 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: }

111: /* -----------------------------------------------------------------------------------------------*/

113: PETSC_INTERN PetscErrorCode PetscPreMPIInit_Private(void);

115: PETSC_INTERN PetscErrorCode PetscInitFortran_Private(PetscBool readarguments, const char *filename, PetscInt len)
116: {
117:   char *tmp = NULL;

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: }

134: /*
135:     petscinitialize - Version called from Fortran.

137:     Note:
138:       Since this is called from Fortran it does not return error codes

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;

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:   }

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;

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:     }

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;

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: }

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:   }

204:   *ierr = PetscFinalize();
205: }

207: PETSC_EXTERN void petscend_(PetscErrorCode *ierr)
208: {
209:   *ierr = PetscEnd();
210: }