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/fortranimpl.h> 15 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 37 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 55 #if defined(PETSC_HAVE_FORTRAN_IARGC_UNDERSCORE) /* HPUX + no underscore */ 56 #undef iargc_ 57 #undef getarg_ 58 #define iargc_ iargc_ 59 #define getarg_ getarg_ 60 #endif 61 62 #if defined(PETSC_HAVE_FORTRAN_GET_COMMAND_ARGUMENT) /* Fortran 2003 */ 63 #undef iargc_ 64 #undef getarg_ 65 #define iargc_ petsccommandargumentcount_ 66 #define getarg_ petscgetcommandargument_ 67 #elif defined(PETSC_HAVE__GFORTRAN_IARGC) /* gfortran from gcc4 */ 68 #undef iargc_ 69 #undef getarg_ 70 #define iargc_ _gfortran_iargc 71 #define getarg_ _gfortran_getarg_i4 72 #elif defined(PETSC_HAVE_BGL_IARGC) /* bgl g77 has different external & internal name mangling */ 73 #undef iargc_ 74 #undef getarg_ 75 #define iargc iargc_ 76 #define getarg getarg_ 77 #endif 78 79 /* 80 The extra _ is because the f2c compiler puts an 81 extra _ at the end if the original routine name 82 contained any _. 83 */ 84 #if defined(PETSC_HAVE_FORTRAN_UNDERSCORE_UNDERSCORE) 85 #define mpi_init_ mpi_init__ 86 #endif 87 88 #if defined(PETSC_HAVE_MPIUNI) 89 #if defined(mpi_init_) 90 #undef mpi_init_ 91 #if defined(PETSC_HAVE_FORTRAN_CAPS) 92 #define mpi_init_ PETSC_MPI_INIT 93 #elif !defined(PETSC_HAVE_FORTRAN_UNDERSCORE) 94 #define mpi_init_ petsc_mpi_init 95 #elif defined(PETSC_HAVE_FORTRAN_UNDERSCORE_UNDERSCORE) 96 #define mpi_init_ petsc_mpi_init__ 97 #endif 98 #else /* mpi_init_ */ 99 #define mpi_init_ petsc_mpi_init_ 100 #endif /* mpi_init_ */ 101 #endif /* PETSC_HAVE_MPIUNI */ 102 103 PETSC_EXTERN void mpi_init_(int*); 104 PETSC_EXTERN void petscgetcomm_(PetscMPIInt*); 105 106 /* 107 Different Fortran compilers handle command lines in different ways 108 */ 109 #if defined(PETSC_HAVE_FORTRAN_GET_COMMAND_ARGUMENT) /* Fortran 2003 - same as 'else' case */ 110 PETSC_EXTERN int iargc_(void); 111 PETSC_EXTERN void getarg_(int*,char*,int); 112 #elif defined(PETSC_USE_NARGS) 113 PETSC_EXTERN short __stdcall NARGS(); 114 PETSC_EXTERN void __stdcall GETARG(short*,char*,int,short *); 115 116 #elif defined(PETSC_HAVE_PXFGETARG_NEW) 117 PETSC_EXTERN int iargc_(); 118 PETSC_EXTERN void getarg_(int*,char*,int*,int*,int); 119 120 #else 121 PETSC_EXTERN int iargc_(); 122 PETSC_EXTERN void getarg_(int*,char*,int); 123 /* 124 The Cray T3D/T3E use the PXFGETARG() function 125 */ 126 #if defined(PETSC_HAVE_PXFGETARG) 127 PETSC_EXTERN void PXFGETARG(int*,_fcd,int*,int*); 128 #endif 129 #endif 130 131 PETSC_EXTERN PetscErrorCode PetscMallocAlign(size_t,PetscBool,int,const char[],const char[],void**); 132 PETSC_EXTERN PetscErrorCode PetscFreeAlign(void*,int,const char[],const char[]); 133 PETSC_INTERN int PetscGlobalArgc; 134 PETSC_INTERN char **PetscGlobalArgs; 135 136 /* 137 Reads in Fortran command line arguments and sends them to 138 all processors. 139 */ 140 141 PetscErrorCode PETScParseFortranArgs_Private(int *argc,char ***argv) 142 { 143 #if defined(PETSC_USE_NARGS) 144 short i,flg; 145 #else 146 int i; 147 #endif 148 PetscErrorCode ierr; 149 int warg = 256; 150 PetscMPIInt rank; 151 char *p; 152 153 ierr = MPI_Comm_rank(PETSC_COMM_WORLD,&rank);CHKERRMPI(ierr); 154 if (rank == 0) { 155 #if defined(PETSC_HAVE_IARG_COUNT_PROGNAME) 156 *argc = iargc_(); 157 #else 158 /* most compilers do not count the program name for argv[0] */ 159 *argc = 1 + iargc_(); 160 #endif 161 } 162 ierr = MPI_Bcast(argc,1,MPI_INT,0,PETSC_COMM_WORLD);CHKERRMPI(ierr); 163 164 /* PetscTrMalloc() not yet set, so don't use PetscMalloc() */ 165 ierr = PetscMallocAlign((*argc+1)*(warg*sizeof(char)+sizeof(char*)),PETSC_FALSE,0,0,0,(void**)argv);CHKERRQ(ierr); 166 (*argv)[0] = (char*)(*argv + *argc + 1); 167 168 if (rank == 0) { 169 ierr = PetscMemzero((*argv)[0],(*argc)*warg*sizeof(char));CHKERRQ(ierr); 170 for (i=0; i<*argc; i++) { 171 (*argv)[i+1] = (*argv)[i] + warg; 172 #if defined (PETSC_HAVE_FORTRAN_GET_COMMAND_ARGUMENT) /* same as 'else' case */ 173 getarg_(&i,(*argv)[i],warg); 174 #elif defined(PETSC_HAVE_PXFGETARG_NEW) 175 {char *tmp = (*argv)[i]; 176 int ilen; 177 getarg_(&i,tmp,&ilen,&ierr,warg);CHKERRQ(ierr); 178 tmp[ilen] = 0;} 179 #elif defined(PETSC_USE_NARGS) 180 GETARG(&i,(*argv)[i],warg,&flg); 181 #else 182 /* 183 Because the stupid #defines above define all kinds of things to getarg_ we cannot do this test 184 #elif defined(PETSC_HAVE_GETARG) 185 getarg_(&i,(*argv)[i],warg); 186 #else 187 SETERRQ(PETSC_COMM_SELF,PETSC_ERR_SUP,"Cannot get Fortran command line arguments"); 188 */ 189 getarg_(&i,(*argv)[i],warg); 190 #endif 191 /* zero out garbage at end of each argument */ 192 p = (*argv)[i] + warg-1; 193 while (p > (*argv)[i]) { 194 if (*p == ' ') *p = 0; 195 p--; 196 } 197 } 198 } 199 ierr = MPI_Bcast((*argv)[0],*argc*warg,MPI_CHAR,0,PETSC_COMM_WORLD);CHKERRMPI(ierr); 200 if (rank) { 201 for (i=0; i<*argc; i++) (*argv)[i+1] = (*argv)[i] + warg; 202 } 203 return 0; 204 } 205 206 /* -----------------------------------------------------------------------------------------------*/ 207 208 PETSC_INTERN PetscErrorCode PetscPreMPIInit_Private(); 209 210 PETSC_INTERN PetscErrorCode PetscInitFortran_Private(PetscBool readarguments,const char *filename,PetscInt len) 211 { 212 PetscErrorCode ierr; 213 char *tmp = NULL; 214 215 PetscFunctionBegin; 216 ierr = PetscInitializeFortran();CHKERRQ(ierr); 217 if (readarguments) { 218 ierr = PETScParseFortranArgs_Private(&PetscGlobalArgc,&PetscGlobalArgs);CHKERRQ(ierr); 219 if (filename != PETSC_NULL_CHARACTER_Fortran) { /* FIXCHAR */ 220 while ((len > 0) && (filename[len-1] == ' ')) len--; 221 ierr = PetscMalloc1(len+1,&tmp);CHKERRQ(ierr); 222 ierr = PetscStrncpy(tmp,filename,len+1);CHKERRQ(ierr); 223 } 224 ierr = PetscOptionsInsert(NULL,&PetscGlobalArgc,&PetscGlobalArgs,tmp);CHKERRQ(ierr); 225 ierr = PetscFree(tmp);CHKERRQ(ierr); /* FREECHAR */ 226 } 227 PetscFunctionReturn(0); 228 } 229 230 /* 231 petscinitialize - Version called from Fortran. 232 233 Notes: 234 Since this is called from Fortran it does not return error codes 235 236 */ 237 PETSC_EXTERN void petscinitializef_(char* filename,char* help,PetscBool *readarguments,PetscErrorCode *ierr,PETSC_FORTRAN_CHARLEN_T len,PETSC_FORTRAN_CHARLEN_T helplen) 238 { 239 int j,i; 240 #if defined (PETSC_USE_NARGS) 241 short flg; 242 #endif 243 int flag; 244 char name[256] = {0}; 245 PetscMPIInt f_petsc_comm_world; 246 247 if (PetscInitializeCalled) {*ierr = 0; return;} 248 i = 0; 249 #if defined (PETSC_HAVE_FORTRAN_GET_COMMAND_ARGUMENT) /* same as 'else' case */ 250 getarg_(&i,name,sizeof(name)); 251 #elif defined (PETSC_HAVE_PXFGETARG_NEW) 252 { int ilen,sierr; 253 getarg_(&i,name,&ilen,&sierr,256); 254 if (sierr) PetscStrncpy(name,"Unknown Name",256); 255 else name[ilen] = 0; 256 } 257 #elif defined(PETSC_USE_NARGS) 258 GETARG(&i,name,256,&flg); 259 #else 260 getarg_(&i,name,256); 261 #endif 262 /* Eliminate spaces at the end of the string */ 263 for (j=sizeof(name)-2; j>=0; j--) { 264 if (name[j] != ' ') { 265 name[j+1] = 0; 266 break; 267 } 268 } 269 if (j<0) PetscStrncpy(name,"Unknown Name",256); 270 271 /* check if PETSC_COMM_WORLD is initialized by the user in fortran */ 272 petscgetcomm_(&f_petsc_comm_world); 273 MPI_Initialized(&flag); 274 if (!flag) { 275 PetscMPIInt mierr; 276 277 if (f_petsc_comm_world) {(*PetscErrorPrintf)("You cannot set PETSC_COMM_WORLD if you have not initialized MPI first\n");return;} 278 279 *ierr = PetscPreMPIInit_Private(); if (*ierr) return; 280 mpi_init_(&mierr); 281 if (mierr) { 282 *ierr = mierr; 283 (*PetscErrorPrintf)("PetscInitialize: Calling Fortran MPI_Init()\n"); 284 return; 285 } 286 PetscBeganMPI = PETSC_TRUE; 287 } 288 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 */ 289 else PETSC_COMM_WORLD = MPI_COMM_WORLD; 290 291 *ierr = PetscInitialize_Common(name,filename,help,PETSC_TRUE,*readarguments,(PetscInt)len); 292 if (*ierr) {(*PetscErrorPrintf)("PetscInitialize:PetscInitialize_Common\n");return;} 293 } 294 295 PETSC_EXTERN void petscfinalize_(PetscErrorCode *ierr) 296 { 297 #if defined(PETSC_HAVE_SUNMATHPRO) 298 extern void standard_arithmetic(); 299 standard_arithmetic(); 300 #endif 301 /* was malloced with PetscMallocAlign() so free the same way */ 302 *ierr = PetscFreeAlign(PetscGlobalArgs,0,0,0);if (*ierr) {(*PetscErrorPrintf)("PetscFinalize:Freeing args\n");return;} 303 304 *ierr = PetscFinalize(); 305 } 306 307 PETSC_EXTERN void petscend_(PetscErrorCode *ierr) 308 { 309 #if defined(PETSC_HAVE_SUNMATHPRO) 310 extern void standard_arithmetic(); 311 standard_arithmetic(); 312 #endif 313 314 *ierr = PetscEnd(); 315 } 316