1 /*
2 This file contains Fortran stubs for PetscInitialize and Finalize.
3 */
4
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
13
14 #include <petsc/private/ftnimpl.h>
15
16 #if defined(PETSC_HAVE_FORTRAN_CAPS)
17 #define petscinitializef_ PETSCINITIALIZEF
18 #define mpi_init_ MPI_INIT
19 #define petscgetcomm_ PETSCGETCOMM
20 #define petsccommandargumentcount_ PETSCCOMMANDARGUMENTCOUNT
21 #define petscgetcommandargument_ PETSCGETCOMMANDARGUMENT
22 #elif !defined(PETSC_HAVE_FORTRAN_UNDERSCORE)
23 #define petscinitializef_ petscinitializef
24 #define mpi_init_ mpi_init
25 #define petscgetcomm_ petscgetcomm
26 #define petsccommandargumentcount_ petsccommandargumentcount
27 #define petscgetcommandargument_ petscgetcommandargument
28 #endif
29
30 /*
31 The extra _ is because the f2c compiler puts an
32 extra _ at the end if the original routine name
33 contained any _.
34 */
35 #if defined(PETSC_HAVE_FORTRAN_UNDERSCORE_UNDERSCORE)
36 #define mpi_init_ mpi_init__
37 #endif
38
39 #if defined(PETSC_HAVE_MPIUNI)
40 #if defined(mpi_init_)
41 #undef mpi_init_
42 #if defined(PETSC_HAVE_FORTRAN_CAPS)
43 #define mpi_init_ PETSC_MPI_INIT
44 #elif !defined(PETSC_HAVE_FORTRAN_UNDERSCORE)
45 #define mpi_init_ petsc_mpi_init
46 #elif defined(PETSC_HAVE_FORTRAN_UNDERSCORE_UNDERSCORE)
47 #define mpi_init_ petsc_mpi_init__
48 #endif
49 #else /* mpi_init_ */
50 #define mpi_init_ petsc_mpi_init_
51 #endif /* mpi_init_ */
52 #endif /* PETSC_HAVE_MPIUNI */
53
54 PETSC_EXTERN void mpi_init_(int *);
55 PETSC_EXTERN void petscgetcomm_(PetscMPIInt *);
56
57 /*
58 Different Fortran compilers handle command lines in different ways
59 */
60 PETSC_EXTERN int petsccommandargumentcount_(void);
61 PETSC_EXTERN void petscgetcommandargument_(int *, char *, PETSC_FORTRAN_CHARLEN_T);
62 PETSC_EXTERN PetscErrorCode PetscMallocAlign(size_t, PetscBool, int, const char[], const char[], void **);
63 PETSC_EXTERN PetscErrorCode PetscFreeAlign(void *, int, const char[], const char[]);
64 PETSC_INTERN int PetscGlobalArgc;
65 PETSC_INTERN char **PetscGlobalArgs, **PetscGlobalArgsFortran;
66
67 /*
68 Reads in Fortran command line arguments and sends them to
69 all processors.
70 */
71
PETScParseFortranArgs_Private(int * argc,char *** argv)72 PetscErrorCode PETScParseFortranArgs_Private(int *argc, char ***argv)
73 {
74 int i;
75 int warg = 256;
76 PetscMPIInt rank;
77 char *p;
78
79 PetscCallMPI(MPI_Comm_rank(PETSC_COMM_WORLD, &rank));
80 if (rank == 0) *argc = 1 + petsccommandargumentcount_();
81 PetscCallMPI(MPI_Bcast(argc, 1, MPI_INT, 0, PETSC_COMM_WORLD));
82
83 /* PetscTrMalloc() not yet set, so don't use PetscMalloc() */
84 PetscCall(PetscMallocAlign((*argc + 1) * (warg * sizeof(char) + sizeof(char *)), PETSC_FALSE, 0, NULL, NULL, (void **)argv));
85 (*argv)[0] = (char *)(*argv + *argc + 1);
86
87 if (rank == 0) {
88 PetscCall(PetscMemzero((*argv)[0], (*argc) * warg * sizeof(char)));
89 for (i = 0; i < *argc; i++) {
90 (*argv)[i + 1] = (*argv)[i] + warg;
91 petscgetcommandargument_(&i, (*argv)[i], warg);
92 /* zero out garbage at end of each argument */
93 p = (*argv)[i] + warg - 1;
94 while (p > (*argv)[i]) {
95 if (*p == ' ') *p = 0;
96 p--;
97 }
98 }
99 }
100 PetscCallMPI(MPI_Bcast((*argv)[0], *argc * warg, MPI_CHAR, 0, PETSC_COMM_WORLD));
101 if (rank) {
102 for (i = 0; i < *argc; i++) (*argv)[i + 1] = (*argv)[i] + warg;
103 }
104 return PETSC_SUCCESS;
105 }
106
107 PETSC_INTERN PetscErrorCode PetscPreMPIInit_Private(void);
108
PetscInitFortran_Private(const char * filename,PetscInt len)109 PETSC_INTERN PetscErrorCode PetscInitFortran_Private(const char *filename, PetscInt len)
110 {
111 char *tmp = NULL;
112
113 PetscFunctionBegin;
114 PetscCall(PetscInitializeFortran());
115 PetscCall(PETScParseFortranArgs_Private(&PetscGlobalArgc, &PetscGlobalArgsFortran));
116 PetscGlobalArgs = PetscGlobalArgsFortran;
117 if (filename != PETSC_NULL_CHARACTER_Fortran) { /* filename comes from Fortran so may have blanking padding that needs removal */
118 while ((len > 0) && (filename[len - 1] == ' ')) len--;
119 PetscCall(PetscMalloc1(len + 1, &tmp));
120 PetscCall(PetscStrncpy(tmp, filename, len + 1));
121 }
122 PetscCall(PetscOptionsInsert(NULL, &PetscGlobalArgc, &PetscGlobalArgsFortran, tmp));
123 PetscCall(PetscFree(tmp));
124 PetscFunctionReturn(PETSC_SUCCESS);
125 }
126
petscinitializef_(char * filename,char * help,PetscErrorCode * ierr,PETSC_FORTRAN_CHARLEN_T len,PETSC_FORTRAN_CHARLEN_T helplen)127 PETSC_EXTERN void petscinitializef_(char *filename, char *help, PetscErrorCode *ierr, PETSC_FORTRAN_CHARLEN_T len, PETSC_FORTRAN_CHARLEN_T helplen)
128 {
129 int j, i;
130 int flag;
131 char name[256] = {0};
132 PetscMPIInt f_petsc_comm_world;
133
134 *ierr = PETSC_SUCCESS;
135 if (PetscInitializeCalled) return;
136 i = 0;
137 petscgetcommandargument_(&i, name, sizeof(name));
138 /* Eliminate spaces at the end of the string */
139 for (j = sizeof(name) - 2; j >= 0; j--) {
140 if (name[j] != ' ') {
141 name[j + 1] = 0;
142 break;
143 }
144 }
145 if (j < 0) {
146 *ierr = PetscStrncpy(name, "Unknown Name", 256);
147 if (*ierr) return;
148 }
149
150 /* check if PETSC_COMM_WORLD is initialized by the user in Fortran */
151 petscgetcomm_(&f_petsc_comm_world);
152 MPI_Initialized(&flag);
153 if (!flag) {
154 PetscMPIInt mierr;
155
156 if (f_petsc_comm_world) {
157 *ierr = (*PetscErrorPrintf)("You cannot set PETSC_COMM_WORLD if you have not initialized MPI first\n");
158 return;
159 }
160
161 *ierr = PetscPreMPIInit_Private();
162 if (*ierr) return;
163 mpi_init_(&mierr);
164 if (mierr) {
165 *ierr = (*PetscErrorPrintf)("PetscInitialize: Calling Fortran MPI_Init()\n");
166 *ierr = (PetscErrorCode)mierr;
167 return;
168 }
169 PetscBeganMPI = PETSC_TRUE;
170 }
171 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 */
172 else PETSC_COMM_WORLD = MPI_COMM_WORLD;
173
174 *ierr = PetscInitialize_Common(name, filename, help, PETSC_TRUE, (PetscInt)len);
175 if (*ierr) {
176 (void)(*PetscErrorPrintf)("PetscInitialize:PetscInitialize_Common\n");
177 return;
178 }
179 }
180