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