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 src/fortran/custom/zpetsc.h
 15:  #include petscsys.h


 19: #ifdef PETSC_HAVE_FORTRAN_CAPS
 20: #define petscinitialize_              PETSCINITIALIZE
 21: #define petscfinalize_                PETSCFINALIZE
 22: #define petscend_                     PETSCEND
 23: #define iargc_                        IARGC
 24: #define getarg_                       GETARG
 25: #define mpi_init_                     MPI_INIT
 26: #elif !defined(PETSC_HAVE_FORTRAN_UNDERSCORE)
 27: #define petscinitialize_              petscinitialize
 28: #define petscfinalize_                petscfinalize
 29: #define petscend_                     petscend
 30: #define mpi_init_                     mpi_init
 31: #define iargc_                        iargc
 32: #define getarg_                       getarg
 33: #endif

 35: #if defined(PETSC_HAVE_NAGF90)
 36: #undef iargc_
 37: #undef getarg_
 38: #define iargc_  f90_unix_MP_iargc
 39: #define getarg_ f90_unix_MP_getarg
 40: #endif
 41: #if defined(PETSC_USE_NARGS) /* Digital Fortran */
 42: #undef iargc_
 43: #undef getarg_
 44: #define iargc_  NARGS
 45: #define getarg_ GETARG
 46: #elif defined (PETSC_HAVE_PXFGETARG_NEW) /* cray x1 */
 47: #undef iargc_
 48: #undef getarg_
 49: #define iargc_  ipxfargc_
 50: #define getarg_ pxfgetarg_
 51: #endif
 52: #if defined(PETSC_HAVE_FORTRAN_IARGC_UNDERSCORE) /* HPUX + no underscore */
 53: #undef iargc_
 54: #undef getarg_
 55: #define iargc_   iargc_
 56: #define getarg_  getarg_
 57: #endif
 58: #if defined(PETSC_HAVE_GFORTRAN_IARGC) /* gfortran from gcc4 */
 59: #define iargc_  _gfortran_iargc
 60: #define getarg_ _gfortran_getarg_i4
 61: #endif

 63: /*
 64:     The extra _ is because the f2c compiler puts an
 65:   extra _ at the end if the original routine name 
 66:   contained any _.
 67: */
 68: #if defined(PETSC_HAVE_FORTRAN_UNDERSCORE_UNDERSCORE)
 69: #define mpi_init_             mpi_init__
 70: #endif


 75: /*
 76:      Different Fortran compilers handle command lines in different ways
 77: */
 78: #if defined(PETSC_USE_NARGS)

 82: #elif defined(PETSC_HAVE_FORTRAN_STDCALL)

 86: #elif defined (PETSC_HAVE_PXFGETARG_NEW)

 90: #else
 93: /*
 94:       The Cray T3D/T3E use the PXFGETARG() function
 95: */
 96: #if defined(PETSC_HAVE_PXFGETARG)
 98: #endif
 99: #endif

102: #if defined(PETSC_USE_COMPLEX)

108: #endif


115: EXTERN PetscErrorCode PETSC_DLL_IMPORT PetscOptionsCheckInitial_Private(void);
116: EXTERN PetscErrorCode PETSC_DLL_IMPORT PetscOptionsCheckInitial_Components(void);
117: EXTERN PetscErrorCode PETSC_DLL_IMPORT PetscInitialize_DynamicLibraries(void);
118: EXTERN PetscErrorCode PETSC_DLL_IMPORT PetscLogBegin_Private(void);

120: /*
121:     Reads in Fortran command line argments and sends them to 
122:   all processors and adds them to Options database.
123: */

125: PetscErrorCode PETScParseFortranArgs_Private(int *argc,char ***argv)
126: {
127: #if defined (PETSC_USE_NARGS)
128:   short i,flg;
129: #else
130:   int   i;
131: #endif
133:   int            warg = 256;
134:   PetscMPIInt    rank;
135:   char           *p;

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

148:   PetscMalloc((*argc+1)*(warg*sizeof(char)+sizeof(char*)),argv);
149:   (*argv)[0] = (char*)(*argv + *argc + 1);

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

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



200: /*
201:     petscinitialize - Version called from Fortran.

203:     Notes:
204:       Since this is called from Fortran it does not return error codes
205:       
206: */
207: void PETSC_STDCALL petscinitialize_(CHAR filename PETSC_MIXED_LEN(len),PetscErrorCode *ierr PETSC_END_LEN(len))
208: {
209: #if defined (PETSC_USE_NARGS)
210:   short       flg,i;
211: #else
212:   int         i;
213: #if !defined(PETSC_HAVE_PXFGETARG_NEW) && !defined (PETSC_HAVE_PXFGETARG_NEW) 
214:   int         j;
215: #endif
216: #endif
217:   int         flag,argc = 0;
218:   PetscMPIInt size;
219:   char        **args = 0,*t1,name[256],hostname[64];
220: 
221:   *1;
222:   *PetscMemzero(name,256); if (*ierr) return;
223:   if (PetscInitializeCalled) {*0; return;}
224: 
225:   *PetscOptionsCreate();
226:   if (*ierr) return;
227:   i = 0;
228: #if defined(PETSC_HAVE_PXFGETARG)
229:   { int ilen,sierr;
230:     PXFGETARG(&i,_cptofcd(name,256),&ilen,&sierr);
231:     if (sierr) {
232:       *sierr;
233:       return;
234:     }
235:     name[ilen] = 0;
236:   }
237: #elif defined (PETSC_HAVE_PXFGETARG_NEW)
238:   { int ilen,sierr;
239:     getarg_(&i,name,&ilen,&sierr,256);
240:     if (sierr) {
241:       *sierr;
242:       return;
243:     }
244:     name[ilen] = 0;
245:   }
246: #elif defined (PETSC_USE_NARGS)
247:   GETARG(&i,name,256,&flg);
248: #else
249:   getarg_(&i,name,256);
250:   /* Eliminate spaces at the end of the string */
251:   for (j=254; j>=0; j--) {
252:     if (name[j] != ' ') {
253:       name[j+1] = 0;
254:       break;
255:     }
256:   }
257: #endif
258:   *PetscSetProgramName(name);
259:   if (*ierr) {(*PetscErrorPrintf)("PetscInitialize: Calling PetscSetProgramName()");return;}

261:   MPI_Initialized(&flag);
262:   if (!flag) {
263:     PetscMPIInt mierr;

265:     if (PETSC_COMM_WORLD) {(*PetscErrorPrintf)("You cannot set PETSC_COMM_WORLD if you have not initialized MPI first");return;}
266:     /* MPI requires calling Fortran mpi_init() if main program is Fortran */
267:     mpi_init_(&mierr);
268:     if (mierr) {
269:       *mierr;
270:       (*PetscErrorPrintf)("PetscInitialize: Calling Fortran MPI_Init()");
271:       return;
272:     }
273:     PetscBeganMPI    = PETSC_TRUE;
274:   }
275:   if (!PETSC_COMM_WORLD) {
276:     PETSC_COMM_WORLD = MPI_COMM_WORLD;
277:   }
278:   PetscInitializeCalled = PETSC_TRUE;

280:   *PetscErrorPrintfInitialize();
281:   if (*ierr) {(*PetscErrorPrintf)("PetscInitialize: Calling PetscErrorPrintfInitialize()");return;}

283:   *MPI_Comm_rank(MPI_COMM_WORLD,&PetscGlobalRank);
284:   if (*ierr) {(*PetscErrorPrintf)("PetscInitialize: Setting PetscGlobalRank");return;}
285:   *MPI_Comm_size(MPI_COMM_WORLD,&PetscGlobalSize);
286:   if (*ierr) {(*PetscErrorPrintf)("PetscInitialize: Setting PetscGlobalSize");return;}

288: #if defined(PETSC_USE_COMPLEX)
289:   /* 
290:      Initialized the global variable; this is because with 
291:      shared libraries the constructors for global variables
292:      are not called; at least on IRIX.
293:   */
294:   {
295:     PetscScalar ic(0.0,1.0);
296:     PETSC_i = ic;
297:   }
298:   *MPI_Type_contiguous(2,MPIU_REAL,&MPIU_COMPLEX);
299:   if (*ierr) {(*PetscErrorPrintf)("PetscInitialize:Creating MPI types");return;}
300:   *MPI_Type_commit(&MPIU_COMPLEX);
301:   if (*ierr) {(*PetscErrorPrintf)("PetscInitialize:Creating MPI types");return;}
302:   *MPI_Op_create(PetscSum_Local,1,&PetscSum_Op);
303:   if (*ierr) {(*PetscErrorPrintf)("PetscInitialize:Creating MPI ops");return;}
304: #endif

306:   /*
307:        Create the PETSc MPI reduction operator that sums of the first
308:      half of the entries and maxes the second half.
309:   */
310:   *MPI_Op_create(PetscMaxSum_Local,1,&PetscMaxSum_Op);
311:   if (*ierr) {(*PetscErrorPrintf)("PetscInitialize:Creating MPI ops");return;}

313:   *MPI_Type_contiguous(2,MPIU_SCALAR,&MPIU_2SCALAR);
314:   if (*ierr) {(*PetscErrorPrintf)("PetscInitialize:Creating MPI types");return;}
315:   *MPI_Type_commit(&MPIU_2SCALAR);
316:   if (*ierr) {(*PetscErrorPrintf)("PetscInitialize:Creating MPI types");return;}
317:   *MPI_Type_contiguous(2,MPIU_INT,&MPIU_2INT);
318:   if (*ierr) {(*PetscErrorPrintf)("PetscInitialize:Creating MPI types");return;}
319:   *MPI_Type_commit(&MPIU_2INT);
320:   if (*ierr) {(*PetscErrorPrintf)("PetscInitialize:Creating MPI types");return;}
321:   *MPI_Op_create(PetscADMax_Local,1,&PetscADMax_Op);
322:   if (*ierr) {(*PetscErrorPrintf)("PetscInitialize:Creating MPI ops");return;}
323:   *MPI_Op_create(PetscADMin_Local,1,&PetscADMin_Op);
324:   if (*ierr) {(*PetscErrorPrintf)("PetscInitialize:Creating MPI ops");return;}

326:   /*
327:      PetscInitializeFortran() is called twice. Here it initializes
328:      PETSC_NULLCHARACTER_Fortran. Below it initializes the PETSC_VIEWERs.
329:      The PETSC_VIEWERs have not been created yet, so they must be initialized
330:      below.
331:   */
332:   PetscInitializeFortran();

334:   PETScParseFortranArgs_Private(&argc,&args);
335:   FIXCHAR(filename,len,t1);
336:   *PetscOptionsInsert(&argc,&args,t1);
337:   FREECHAR(filename,t1);
338:   if (*ierr) {(*PetscErrorPrintf)("PetscInitialize:Creating options database");return;}
339:   *PetscFree(args);
340:   if (*ierr) {(*PetscErrorPrintf)("PetscInitialize:Freeing args");return;}
341:   *PetscOptionsCheckInitial_Private();
342:   if (*ierr) {(*PetscErrorPrintf)("PetscInitialize:Checking initial options");return;}
343:   *PetscLogBegin_Private();
344:   if (*ierr) {(*PetscErrorPrintf)("PetscInitialize: intializing logging");return;}
345:   *PetscInitialize_DynamicLibraries();
346:   if (*ierr) {(*PetscErrorPrintf)("PetscInitialize:Initializing dynamic libraries");return;}

348:   *PetscInitializeFortran();
349:   if (*ierr) { (*PetscErrorPrintf)("PetscInitialize:Setting up common block");return;}

351:   *MPI_Comm_size(PETSC_COMM_WORLD,&size);
352:   if (*ierr) { (*PetscErrorPrintf)("PetscInitialize:Getting MPI_Comm_size()");return;}
353:   *PetscLogInfo((0,"PetscInitialize(Fortran):PETSc successfully started: procs %d\n",size));
354:   if (*ierr) { (*PetscErrorPrintf)("PetscInitialize:Calling PetscLogInfo()");return;}
355:   *PetscGetHostName(hostname,64);
356:   if (*ierr) { (*PetscErrorPrintf)("PetscInitialize:Getting hostname");return;}
357:   *PetscLogInfo((0,"Running on machine: %s\n",hostname));
358:   if (*ierr) { (*PetscErrorPrintf)("PetscInitialize:Calling PetscLogInfo()");return;}
359:   *PetscOptionsCheckInitial_Components();
360:   if (*ierr) {(*PetscErrorPrintf)("PetscInitialize:Checking initial options");return;}
361: }

363: void PETSC_STDCALL petscfinalize_(PetscErrorCode *ierr)
364: {
365: #if defined(PETSC_HAVE_SUNMATHPRO)
367:   standard_arithmetic();
368: #endif

370:   *PetscFinalize();
371: }

373: void PETSC_STDCALL petscend_(PetscErrorCode *ierr)
374: {
375: #if defined(PETSC_HAVE_SUNMATHPRO)
377:   standard_arithmetic();
378: #endif

380:   *PetscEnd();
381: }