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 iargc_                     IARGC
 21:   #define getarg_                    GETARG
 22:   #define mpi_init_                  MPI_INIT
 23:   #define petscgetcomm_              PETSCGETCOMM
 24:   #define petsccommandargumentcount_ PETSCCOMMANDARGUMENTCOUNT
 25:   #define petscgetcommandargument_   PETSCGETCOMMANDARGUMENT
 26: #elif !defined(PETSC_HAVE_FORTRAN_UNDERSCORE)
 27:   #define petscinitializef_          petscinitializef
 28:   #define petscfinalize_             petscfinalize
 29:   #define petscend_                  petscend
 30:   #define mpi_init_                  mpi_init
 31:   #define iargc_                     iargc
 32:   #define getarg_                    getarg
 33:   #define petscgetcomm_              petscgetcomm
 34:   #define petsccommandargumentcount_ petsccommandargumentcount
 35:   #define petscgetcommandargument_   petscgetcommandargument
 36: #endif

 38: #if defined(PETSC_HAVE_NAGF90)
 39:   #undef iargc_
 40:   #undef getarg_
 41:   #define iargc_  f90_unix_MP_iargc
 42:   #define getarg_ f90_unix_MP_getarg
 43: #endif
 44: #if defined(PETSC_USE_NARGS) /* Digital Fortran */
 45:   #undef iargc_
 46:   #undef getarg_
 47:   #define iargc_  NARGS
 48:   #define getarg_ GETARG
 49: #elif defined(PETSC_HAVE_PXFGETARG_NEW) /* cray x1 */
 50:   #undef iargc_
 51:   #undef getarg_
 52:   #define iargc_  ipxfargc_
 53:   #define getarg_ pxfgetarg_
 54: #endif

 56: #if defined(PETSC_HAVE_FORTRAN_GET_COMMAND_ARGUMENT) /* Fortran 2003 */
 57:   #undef iargc_
 58:   #undef getarg_
 59:   #define iargc_  petsccommandargumentcount_
 60:   #define getarg_ petscgetcommandargument_
 61: #elif defined(PETSC_HAVE_BGL_IARGC) /* bgl g77 has different external & internal name mangling */
 62:   #undef iargc_
 63:   #undef getarg_
 64:   #define iargc  iargc_
 65:   #define getarg getarg_
 66: #endif

 68: /*
 69:     The extra _ is because the f2c compiler puts an
 70:   extra _ at the end if the original routine name
 71:   contained any _.
 72: */
 73: #if defined(PETSC_HAVE_FORTRAN_UNDERSCORE_UNDERSCORE)
 74:   #define mpi_init_ mpi_init__
 75: #endif

 77: #if defined(PETSC_HAVE_MPIUNI)
 78:   #if defined(mpi_init_)
 79:     #undef mpi_init_
 80:     #if defined(PETSC_HAVE_FORTRAN_CAPS)
 81:       #define mpi_init_ PETSC_MPI_INIT
 82:     #elif !defined(PETSC_HAVE_FORTRAN_UNDERSCORE)
 83:       #define mpi_init_ petsc_mpi_init
 84:     #elif defined(PETSC_HAVE_FORTRAN_UNDERSCORE_UNDERSCORE)
 85:       #define mpi_init_ petsc_mpi_init__
 86:     #endif
 87:   #else /* mpi_init_ */
 88:     #define mpi_init_ petsc_mpi_init_
 89:   #endif /* mpi_init_ */
 90: #endif   /* PETSC_HAVE_MPIUNI */

 92: PETSC_EXTERN void mpi_init_(int *);
 93: PETSC_EXTERN void petscgetcomm_(PetscMPIInt *);

 95: /*
 96:      Different Fortran compilers handle command lines in different ways
 97: */
 98: #if defined(PETSC_HAVE_FORTRAN_GET_COMMAND_ARGUMENT) /* Fortran 2003  - same as 'else' case */
 99: PETSC_EXTERN int  iargc_(void);
100: PETSC_EXTERN void getarg_(int *, char *, int);
101: #elif defined(PETSC_USE_NARGS)
102: PETSC_EXTERN short __stdcall NARGS(void);
103: PETSC_EXTERN void __stdcall GETARG(short *, char *, int, short *);

105: #elif defined(PETSC_HAVE_PXFGETARG_NEW)
106: PETSC_EXTERN int  iargc_(void);
107: PETSC_EXTERN void getarg_(int *, char *, int *, int *, int);

109: #else
110: PETSC_EXTERN int  iargc_(void);
111: PETSC_EXTERN void getarg_(int *, char *, int);
112:   /*
113:       The Cray T3D/T3E use the PXFGETARG() function
114: */
115:   #if defined(PETSC_HAVE_PXFGETARG)
116: PETSC_EXTERN void PXFGETARG(int *, _fcd, int *, int *);
117:   #endif
118: #endif

120: PETSC_EXTERN PetscErrorCode PetscMallocAlign(size_t, PetscBool, int, const char[], const char[], void **);
121: PETSC_EXTERN PetscErrorCode PetscFreeAlign(void *, int, const char[], const char[]);
122: PETSC_INTERN int            PetscGlobalArgc;
123: PETSC_INTERN char         **PetscGlobalArgs;

125: /*
126:     Reads in Fortran command line arguments and sends them to
127:   all processors.
128: */

130: PetscErrorCode PETScParseFortranArgs_Private(int *argc, char ***argv)
131: {
132: #if defined(PETSC_USE_NARGS)
133:   short i, flg;
134: #else
135:   int i;
136: #endif
137:   int         warg = 256;
138:   PetscMPIInt rank;
139:   char       *p;

141:   PetscCallMPI(MPI_Comm_rank(PETSC_COMM_WORLD, &rank));
142:   if (rank == 0) {
143: #if defined(PETSC_HAVE_IARG_COUNT_PROGNAME)
144:     *argc = iargc_();
145: #else
146:     /* most compilers do not count the program name for argv[0] */
147:     *argc = 1 + iargc_();
148: #endif
149:   }
150:   PetscCallMPI(MPI_Bcast(argc, 1, MPI_INT, 0, PETSC_COMM_WORLD));

152:   /* PetscTrMalloc() not yet set, so don't use PetscMalloc() */
153:   PetscCall(PetscMallocAlign((*argc + 1) * (warg * sizeof(char) + sizeof(char *)), PETSC_FALSE, 0, 0, 0, (void **)argv));
154:   (*argv)[0] = (char *)(*argv + *argc + 1);

156:   if (rank == 0) {
157:     PetscCall(PetscMemzero((*argv)[0], (*argc) * warg * sizeof(char)));
158:     for (i = 0; i < *argc; i++) {
159:       (*argv)[i + 1] = (*argv)[i] + warg;
160: #if defined(PETSC_HAVE_FORTRAN_GET_COMMAND_ARGUMENT) /* same as 'else' case */
161:       getarg_(&i, (*argv)[i], warg);
162: #elif defined(PETSC_HAVE_PXFGETARG_NEW)
163:       {
164:         char *tmp = (*argv)[i];
165:         int   ilen;
166:         PetscCallFortranVoidFunction(getarg_(&i, tmp, &ilen, &ierr, warg));
167:         tmp[ilen] = 0;
168:       }
169: #elif defined(PETSC_USE_NARGS)
170:       GETARG(&i, (*argv)[i], warg, &flg);
171: #else
172:       getarg_(&i, (*argv)[i], warg);
173: #endif
174:       /* zero out garbage at end of each argument */
175:       p = (*argv)[i] + warg - 1;
176:       while (p > (*argv)[i]) {
177:         if (*p == ' ') *p = 0;
178:         p--;
179:       }
180:     }
181:   }
182:   PetscCallMPI(MPI_Bcast((*argv)[0], *argc * warg, MPI_CHAR, 0, PETSC_COMM_WORLD));
183:   if (rank) {
184:     for (i = 0; i < *argc; i++) (*argv)[i + 1] = (*argv)[i] + warg;
185:   }
186:   return PETSC_SUCCESS;
187: }

189: /* -----------------------------------------------------------------------------------------------*/

191: PETSC_INTERN PetscErrorCode PetscPreMPIInit_Private(void);

193: PETSC_INTERN PetscErrorCode PetscInitFortran_Private(PetscBool readarguments, const char *filename, PetscInt len)
194: {
195:   char *tmp = NULL;

197:   PetscFunctionBegin;
198:   PetscCall(PetscInitializeFortran());
199:   if (readarguments) {
200:     PetscCall(PETScParseFortranArgs_Private(&PetscGlobalArgc, &PetscGlobalArgs));
201:     if (filename != PETSC_NULL_CHARACTER_Fortran) { /* FIXCHAR */
202:       while ((len > 0) && (filename[len - 1] == ' ')) len--;
203:       PetscCall(PetscMalloc1(len + 1, &tmp));
204:       PetscCall(PetscStrncpy(tmp, filename, len + 1));
205:     }
206:     PetscCall(PetscOptionsInsert(NULL, &PetscGlobalArgc, &PetscGlobalArgs, tmp));
207:     PetscCall(PetscFree(tmp)); /* FREECHAR */
208:   }
209:   PetscFunctionReturn(PETSC_SUCCESS);
210: }

212: /*
213:     petscinitialize - Version called from Fortran.

215:     Note:
216:       Since this is called from Fortran it does not return error codes

218: */
219: PETSC_EXTERN void petscinitializef_(char *filename, char *help, PetscBool *readarguments, PetscErrorCode *ierr, PETSC_FORTRAN_CHARLEN_T len, PETSC_FORTRAN_CHARLEN_T helplen)
220: {
221:   int j, i;
222: #if defined(PETSC_USE_NARGS)
223:   short flg;
224: #endif
225:   int         flag;
226:   char        name[256] = {0};
227:   PetscMPIInt f_petsc_comm_world;

229:   *ierr = PETSC_SUCCESS;
230:   if (PetscInitializeCalled) return;
231:   i = 0;
232: #if defined(PETSC_HAVE_FORTRAN_GET_COMMAND_ARGUMENT) /* same as 'else' case */
233:   getarg_(&i, name, sizeof(name));
234: #elif defined(PETSC_HAVE_PXFGETARG_NEW)
235:   {
236:     int ilen, sierr;
237:     getarg_(&i, name, &ilen, &sierr, 256);
238:     if (sierr) {
239:       *ierr = PetscStrncpy(name, "Unknown Name", 256);
240:       if (*ierr) return;
241:     } else name[ilen] = 0;
242:   }
243: #elif defined(PETSC_USE_NARGS)
244:   GETARG(&i, name, 256, &flg);
245: #else
246:   getarg_(&i, name, 256);
247: #endif
248:   /* Eliminate spaces at the end of the string */
249:   for (j = sizeof(name) - 2; j >= 0; j--) {
250:     if (name[j] != ' ') {
251:       name[j + 1] = 0;
252:       break;
253:     }
254:   }
255:   if (j < 0) {
256:     *ierr = PetscStrncpy(name, "Unknown Name", 256);
257:     if (*ierr) return;
258:   }

260:   /* check if PETSC_COMM_WORLD is initialized by the user in fortran */
261:   petscgetcomm_(&f_petsc_comm_world);
262:   MPI_Initialized(&flag);
263:   if (!flag) {
264:     PetscMPIInt mierr;

266:     if (f_petsc_comm_world) {
267:       *ierr = (*PetscErrorPrintf)("You cannot set PETSC_COMM_WORLD if you have not initialized MPI first\n");
268:       return;
269:     }

271:     *ierr = PetscPreMPIInit_Private();
272:     if (*ierr) return;
273:     mpi_init_(&mierr);
274:     if (mierr) {
275:       *ierr = (*PetscErrorPrintf)("PetscInitialize: Calling Fortran MPI_Init()\n");
276:       *ierr = (PetscErrorCode)mierr;
277:       return;
278:     }
279:     PetscBeganMPI = PETSC_TRUE;
280:   }
281:   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 */
282:   else PETSC_COMM_WORLD = MPI_COMM_WORLD;

284:   *ierr = PetscInitialize_Common(name, filename, help, PETSC_TRUE, *readarguments, (PetscInt)len);
285:   if (*ierr) {
286:     (void)(*PetscErrorPrintf)("PetscInitialize:PetscInitialize_Common\n");
287:     return;
288:   }
289: }

291: PETSC_EXTERN void petscfinalize_(PetscErrorCode *ierr)
292: {
293:   /* was malloced with PetscMallocAlign() so free the same way */
294:   *ierr = PetscFreeAlign(PetscGlobalArgs, 0, 0, 0);
295:   if (*ierr) {
296:     (void)(*PetscErrorPrintf)("PetscFinalize:Freeing args\n");
297:     return;
298:   }

300:   *ierr = PetscFinalize();
301: }

303: PETSC_EXTERN void petscend_(PetscErrorCode *ierr)
304: {
305:   *ierr = PetscEnd();
306: }