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