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_CUDA) 17 #include <cublas.h> 18 #endif 19 #include <petscthreadcomm.h> 20 21 #if defined(PETSC_HAVE_FORTRAN_CAPS) 22 #define petscinitialize_ PETSCINITIALIZE 23 #define petscfinalize_ PETSCFINALIZE 24 #define petscend_ PETSCEND 25 #define iargc_ IARGC 26 #define getarg_ GETARG 27 #define mpi_init_ MPI_INIT 28 #define petscgetcommoncomm_ PETSCGETCOMMONCOMM 29 #elif !defined(PETSC_HAVE_FORTRAN_UNDERSCORE) 30 #define petscinitialize_ petscinitialize 31 #define petscfinalize_ petscfinalize 32 #define petscend_ petscend 33 #define mpi_init_ mpi_init 34 #define iargc_ iargc 35 #define getarg_ getarg 36 #define petscgetcommoncomm_ petscgetcommoncomm 37 #endif 38 39 #if defined(PETSC_HAVE_NAGF90) 40 #undef iargc_ 41 #undef getarg_ 42 #define iargc_ f90_unix_MP_iargc 43 #define getarg_ f90_unix_MP_getarg 44 #endif 45 #if defined(PETSC_USE_NARGS) /* Digital Fortran */ 46 #undef iargc_ 47 #undef getarg_ 48 #define iargc_ NARGS 49 #define getarg_ GETARG 50 #elif defined(PETSC_HAVE_PXFGETARG_NEW) /* cray x1 */ 51 #undef iargc_ 52 #undef getarg_ 53 #define iargc_ ipxfargc_ 54 #define getarg_ pxfgetarg_ 55 #endif 56 #if defined(PETSC_HAVE_FORTRAN_IARGC_UNDERSCORE) /* HPUX + no underscore */ 57 #undef iargc_ 58 #undef getarg_ 59 #define iargc_ iargc_ 60 #define getarg_ getarg_ 61 #endif 62 #if defined(PETSC_HAVE_GFORTRAN_IARGC) /* gfortran from gcc4 */ 63 #undef iargc_ 64 #undef getarg_ 65 #define iargc_ _gfortran_iargc 66 #define getarg_ _gfortran_getarg_i4 67 #elif defined(PETSC_HAVE_BGL_IARGC) /* bgl g77 has different external & internal name mangling */ 68 #undef iargc_ 69 #undef getarg_ 70 #define iargc iargc_ 71 #define getarg getarg_ 72 #endif 73 74 /* 75 The extra _ is because the f2c compiler puts an 76 extra _ at the end if the original routine name 77 contained any _. 78 */ 79 #if defined(PETSC_HAVE_FORTRAN_UNDERSCORE_UNDERSCORE) 80 #undef mpi_init_ 81 #define mpi_init_ mpi_init__ 82 #endif 83 84 PETSC_EXTERN void PETSC_STDCALL mpi_init_(int*); 85 PETSC_EXTERN void PETSC_STDCALL petscgetcommoncomm_(PetscMPIInt*); 86 87 /* 88 Different Fortran compilers handle command lines in different ways 89 */ 90 #if defined(PETSC_USE_NARGS) 91 PETSC_EXTERN short __stdcall NARGS(); 92 PETSC_EXTERN void __stdcall GETARG(short*,char*,int,short *); 93 94 #elif defined(PETSC_HAVE_FORTRAN_STDCALL) 95 PETSC_EXTERN int PETSC_STDCALL IARGC(); 96 PETSC_EXTERN void PETSC_STDCALL GETARG(int *,char *,int); 97 98 #elif defined(PETSC_HAVE_PXFGETARG_NEW) 99 PETSC_EXTERN int iargc_(); 100 PETSC_EXTERN void getarg_(int*,char*,int*,int*,int); 101 102 #else 103 PETSC_EXTERN int iargc_(); 104 PETSC_EXTERN void getarg_(int*,char*,int); 105 /* 106 The Cray T3D/T3E use the PXFGETARG() function 107 */ 108 #if defined(PETSC_HAVE_PXFGETARG) 109 PETSC_EXTERN void PXFGETARG(int*,_fcd,int*,int*); 110 #endif 111 #endif 112 113 #if (defined(PETSC_HAVE_COMPLEX) && !defined(PETSC_HAVE_MPI_C_DOUBLE_COMPLEX)) || defined(PETSC_USE_REAL___FLOAT128) 114 extern MPI_Op MPIU_SUM; 115 116 PETSC_EXTERN void MPIAPI PetscSum_Local(void*,void*,PetscMPIInt*,MPI_Datatype*); 117 118 #endif 119 #if defined(PETSC_USE_REAL___FLOAT128) 120 121 PETSC_EXTERN void MPIAPI PetscSum_Local(void*,void*,PetscMPIInt*,MPI_Datatype*); 122 PETSC_EXTERN void MPIAPI PetscMax_Local(void*,void*,PetscMPIInt*,MPI_Datatype*); 123 PETSC_EXTERN void MPIAPI PetscMin_Local(void*,void*,PetscMPIInt*,MPI_Datatype*); 124 #endif 125 126 extern MPI_Op PetscMaxSum_Op; 127 128 PETSC_EXTERN void MPIAPI PetscMaxSum_Local(void*,void*,PetscMPIInt*,MPI_Datatype*); 129 PETSC_EXTERN PetscMPIInt MPIAPI Petsc_DelCounter(MPI_Comm,PetscMPIInt,void*,void*); 130 PETSC_EXTERN PetscMPIInt MPIAPI Petsc_DelComm_Inner(MPI_Comm,PetscMPIInt,void*,void*); 131 PETSC_EXTERN PetscMPIInt MPIAPI Petsc_DelComm_Outer(MPI_Comm,PetscMPIInt,void*,void*); 132 133 extern PetscErrorCode PetscOptionsCheckInitial_Private(void); 134 extern PetscErrorCode PetscOptionsCheckInitial_Components(void); 135 extern PetscErrorCode PetscInitialize_DynamicLibraries(void); 136 #if defined(PETSC_USE_LOG) 137 extern PetscErrorCode PetscLogBegin_Private(void); 138 #endif 139 extern PetscErrorCode PetscMallocAlign(size_t,int,const char[],const char[],void**); 140 extern PetscErrorCode PetscFreeAlign(void*,int,const char[],const char[]); 141 extern int PetscGlobalArgc; 142 extern char **PetscGlobalArgs; 143 144 /* 145 Reads in Fortran command line argments and sends them to 146 all processors and adds them to Options database. 147 */ 148 149 PetscErrorCode PETScParseFortranArgs_Private(int *argc,char ***argv) 150 { 151 #if defined(PETSC_USE_NARGS) 152 short i,flg; 153 #else 154 int i; 155 #endif 156 PetscErrorCode ierr; 157 int warg = 256; 158 PetscMPIInt rank; 159 char *p; 160 161 ierr = MPI_Comm_rank(PETSC_COMM_WORLD,&rank);CHKERRQ(ierr); 162 if (!rank) { 163 #if defined(PETSC_HAVE_IARG_COUNT_PROGNAME) 164 *argc = iargc_(); 165 #else 166 /* most compilers do not count the program name for argv[0] */ 167 *argc = 1 + iargc_(); 168 #endif 169 } 170 ierr = MPI_Bcast(argc,1,MPI_INT,0,PETSC_COMM_WORLD);CHKERRQ(ierr); 171 172 /* PetscTrMalloc() not yet set, so don't use PetscMalloc() */ 173 ierr = PetscMallocAlign((*argc+1)*(warg*sizeof(char)+sizeof(char*)),0,0,0,(void**)argv);CHKERRQ(ierr); 174 (*argv)[0] = (char*)(*argv + *argc + 1); 175 176 if (!rank) { 177 ierr = PetscMemzero((*argv)[0],(*argc)*warg*sizeof(char));CHKERRQ(ierr); 178 for (i=0; i<*argc; i++) { 179 (*argv)[i+1] = (*argv)[i] + warg; 180 #if defined(PETSC_HAVE_PXFGETARG_NEW) 181 {char *tmp = (*argv)[i]; 182 int ilen; 183 getarg_(&i,tmp,&ilen,&ierr,warg);CHKERRQ(ierr); 184 tmp[ilen] = 0;} 185 #elif defined(PETSC_USE_NARGS) 186 GETARG(&i,(*argv)[i],warg,&flg); 187 #else 188 /* 189 Because the stupid #defines above define all kinds of things to getarg_ we cannot do this test 190 #elif defined(PETSC_HAVE_GETARG) 191 getarg_(&i,(*argv)[i],warg); 192 #else 193 SETERRQ(PETSC_COMM_SELF,PETSC_ERR_SUP,"Cannot get Fortran command line arguments"); 194 */ 195 getarg_(&i,(*argv)[i],warg); 196 #endif 197 /* zero out garbage at end of each argument */ 198 p = (*argv)[i] + warg-1; 199 while (p > (*argv)[i]) { 200 if (*p == ' ') *p = 0; 201 p--; 202 } 203 } 204 } 205 ierr = MPI_Bcast((*argv)[0],*argc*warg,MPI_CHAR,0,PETSC_COMM_WORLD);CHKERRQ(ierr); 206 if (rank) { 207 for (i=0; i<*argc; i++) (*argv)[i+1] = (*argv)[i] + warg; 208 } 209 return 0; 210 } 211 212 #if defined(PETSC_SERIALIZE_FUNCTIONS) 213 extern PetscFPT PetscFPTData; 214 #endif 215 216 /* -----------------------------------------------------------------------------------------------*/ 217 218 #if defined(PETSC_HAVE_SAWS) 219 #include <petscviewersaws.h> 220 extern PetscErrorCode PetscInitializeSAWs(const char[]); 221 #endif 222 223 /* 224 petscinitialize - Version called from Fortran. 225 226 Notes: 227 Since this is called from Fortran it does not return error codes 228 229 */ 230 PETSC_EXTERN void PETSC_STDCALL petscinitialize_(CHAR filename PETSC_MIXED_LEN(len),PetscErrorCode *ierr PETSC_END_LEN(len)) 231 { 232 #if defined (PETSC_USE_NARGS) 233 short flg,i; 234 #else 235 int i; 236 #if !defined(PETSC_HAVE_PXFGETARG_NEW) && !defined (PETSC_HAVE_PXFGETARG_NEW) 237 int j; 238 #endif 239 #endif 240 #if defined(PETSC_HAVE_CUDA) 241 PetscBool flg2; 242 #endif 243 int flag; 244 PetscMPIInt size; 245 char *t1,name[256],hostname[64]; 246 PetscMPIInt f_petsc_comm_world; 247 248 *ierr = PetscMemzero(name,256); if (*ierr) return; 249 if (PetscInitializeCalled) {*ierr = 0; return;} 250 251 /* this must be initialized in a routine, not as a constant declaration*/ 252 PETSC_STDOUT = stdout; 253 PETSC_STDERR = stderr; 254 255 /* on Windows - set printf to default to printing 2 digit exponents */ 256 #if defined(PETSC_HAVE__SET_OUTPUT_FORMAT) 257 _set_output_format(_TWO_DIGIT_EXPONENT); 258 #endif 259 260 *ierr = PetscOptionsCreate(); 261 if (*ierr) return; 262 i = 0; 263 #if defined (PETSC_HAVE_PXFGETARG_NEW) 264 { int ilen,sierr; 265 getarg_(&i,name,&ilen,&sierr,256); 266 if (sierr) PetscStrncpy(name,"Unknown Name",256); 267 else name[ilen] = 0; 268 } 269 #elif defined(PETSC_USE_NARGS) 270 GETARG(&i,name,256,&flg); 271 #else 272 getarg_(&i,name,256); 273 /* Eliminate spaces at the end of the string */ 274 for (j=254; j>=0; j--) { 275 if (name[j] != ' ') { 276 name[j+1] = 0; 277 break; 278 } 279 } 280 if (j<0) PetscStrncpy(name,"Unknown Name",256); 281 #endif 282 *ierr = PetscSetProgramName(name); 283 if (*ierr) {(*PetscErrorPrintf)("PetscInitialize: Calling PetscSetProgramName()\n");return;} 284 285 /* check if PETSC_COMM_WORLD is initialized by the user in fortran */ 286 petscgetcommoncomm_(&f_petsc_comm_world); 287 MPI_Initialized(&flag); 288 if (!flag) { 289 PetscMPIInt mierr; 290 291 if (f_petsc_comm_world) {(*PetscErrorPrintf)("You cannot set PETSC_COMM_WORLD if you have not initialized MPI first\n");return;} 292 /* MPI requires calling Fortran mpi_init() if main program is Fortran */ 293 #if defined(PETSC_HAVE_MPIUNI) && defined(MPIUNI_AVOID_MPI_NAMESPACE) 294 mierr = MPI_Init((int*)0, (char***)0); 295 #else 296 mpi_init_(&mierr); 297 #endif 298 if (mierr) { 299 *ierr = mierr; 300 (*PetscErrorPrintf)("PetscInitialize: Calling Fortran MPI_Init()\n"); 301 return; 302 } 303 PetscBeganMPI = PETSC_TRUE; 304 } 305 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 */ 306 else PETSC_COMM_WORLD = MPI_COMM_WORLD; 307 PetscInitializeCalled = PETSC_TRUE; 308 309 *ierr = PetscErrorPrintfInitialize(); 310 if (*ierr) {(*PetscErrorPrintf)("PetscInitialize: Calling PetscErrorPrintfInitialize()\n");return;} 311 *ierr = MPI_Comm_rank(MPI_COMM_WORLD,&PetscGlobalRank); 312 if (*ierr) {(*PetscErrorPrintf)("PetscInitialize: Setting PetscGlobalRank\n");return;} 313 *ierr = MPI_Comm_size(MPI_COMM_WORLD,&PetscGlobalSize); 314 if (*ierr) {(*PetscErrorPrintf)("PetscInitialize: Setting PetscGlobalSize\n");return;} 315 316 MPIU_BOOL = MPI_INT; 317 MPIU_ENUM = MPI_INT; 318 319 #if defined(PETSC_HAVE_COMPLEX) 320 /* 321 Initialized the global variable; this is because with 322 shared libraries the constructors for global variables 323 are not called; at least on IRIX. 324 */ 325 { 326 #if defined(PETSC_CLANGUAGE_CXX) 327 PetscComplex ic(0.0,1.0); 328 PETSC_i = ic; 329 #else 330 PETSC_i = _Complex_I; 331 #endif 332 } 333 334 #if !defined(PETSC_HAVE_MPI_C_DOUBLE_COMPLEX) 335 *ierr = MPI_Type_contiguous(2,MPI_DOUBLE,&MPIU_C_DOUBLE_COMPLEX); 336 if (*ierr) {(*PetscErrorPrintf)("PetscInitialize:Creating MPI types\n");return;} 337 *ierr = MPI_Type_commit(&MPIU_C_DOUBLE_COMPLEX); 338 if (*ierr) {(*PetscErrorPrintf)("PetscInitialize:Creating MPI types\n");return;} 339 *ierr = MPI_Type_contiguous(2,MPI_FLOAT,&MPIU_C_COMPLEX); 340 if (*ierr) {(*PetscErrorPrintf)("PetscInitialize:Creating MPI types\n");return;} 341 *ierr = MPI_Type_commit(&MPIU_C_COMPLEX); 342 if (*ierr) {(*PetscErrorPrintf)("PetscInitialize:Creating MPI types\n");return;} 343 *ierr = MPI_Op_create(PetscSum_Local,1,&MPIU_SUM); 344 if (*ierr) {(*PetscErrorPrintf)("PetscInitialize:Creating MPI ops\n");return;} 345 #endif 346 347 #endif 348 349 #if defined(PETSC_USE_REAL___FLOAT128) 350 *ierr = MPI_Type_contiguous(2,MPI_DOUBLE,&MPIU___FLOAT128); 351 if (*ierr) {(*PetscErrorPrintf)("PetscInitialize:Creating MPI types\n");return;} 352 *ierr = MPI_Type_commit(&MPIU___FLOAT128); 353 if (*ierr) {(*PetscErrorPrintf)("PetscInitialize:Creating MPI types\n");return;} 354 #if defined(PETSC_HAVE_COMPLEX) 355 *ierr = MPI_Type_contiguous(4,MPI_DOUBLE,&MPIU___COMPLEX128); 356 if (*ierr) {(*PetscErrorPrintf)("PetscInitialize:Creating MPI types\n");return;} 357 *ierr = MPI_Type_commit(&MPIU___COMPLEX128); 358 if (*ierr) {(*PetscErrorPrintf)("PetscInitialize:Creating MPI types\n");return;} 359 #endif 360 *ierr = MPI_Op_create(PetscSum_Local,1,&MPIU_SUM); 361 if (*ierr) {(*PetscErrorPrintf)("PetscInitialize:Creating MPI ops\n");return;} 362 *ierr = MPI_Op_create(PetscMax_Local,1,&MPIU_MAX); 363 if (*ierr) {(*PetscErrorPrintf)("PetscInitialize:Creating MPI ops\n");return;} 364 *ierr = MPI_Op_create(PetscMin_Local,1,&MPIU_MIN); 365 if (*ierr) {(*PetscErrorPrintf)("PetscInitialize:Creating MPI ops\n");return;} 366 #endif 367 368 /* 369 Create the PETSc MPI reduction operator that sums of the first 370 half of the entries and maxes the second half. 371 */ 372 *ierr = MPI_Op_create(PetscMaxSum_Local,1,&PetscMaxSum_Op); 373 if (*ierr) {(*PetscErrorPrintf)("PetscInitialize:Creating MPI ops\n");return;} 374 375 *ierr = MPI_Type_contiguous(2,MPIU_SCALAR,&MPIU_2SCALAR); 376 if (*ierr) {(*PetscErrorPrintf)("PetscInitialize:Creating MPI types\n");return;} 377 *ierr = MPI_Type_commit(&MPIU_2SCALAR); 378 if (*ierr) {(*PetscErrorPrintf)("PetscInitialize:Creating MPI types\n");return;} 379 #if defined(PETSC_USE_64BIT_INDICES) || !defined(MPI_2INT) 380 *ierr = MPI_Type_contiguous(2,MPIU_INT,&MPIU_2INT); 381 if (*ierr) {(*PetscErrorPrintf)("PetscInitialize:Creating MPI types\n");return;} 382 *ierr = MPI_Type_commit(&MPIU_2INT); 383 if (*ierr) {(*PetscErrorPrintf)("PetscInitialize:Creating MPI types\n");return;} 384 #endif 385 *ierr = MPI_Keyval_create(MPI_NULL_COPY_FN,Petsc_DelCounter,&Petsc_Counter_keyval,(void*)0); 386 if (*ierr) {(*PetscErrorPrintf)("PetscInitialize:Creating MPI keyvals\n");return;} 387 *ierr = MPI_Keyval_create(MPI_NULL_COPY_FN,Petsc_DelComm_Outer,&Petsc_InnerComm_keyval,(void*)0); 388 if (*ierr) {(*PetscErrorPrintf)("PetscInitialize:Creating MPI keyvals\n");return;} 389 *ierr = MPI_Keyval_create(MPI_NULL_COPY_FN,Petsc_DelComm_Inner,&Petsc_OuterComm_keyval,(void*)0); 390 if (*ierr) {(*PetscErrorPrintf)("PetscInitialize:Creating MPI keyvals\n");return;} 391 392 /* 393 PetscInitializeFortran() is called twice. Here it initializes 394 PETSC_NULL_CHARACTER_Fortran. Below it initializes the PETSC_VIEWERs. 395 The PETSC_VIEWERs have not been created yet, so they must be initialized 396 below. 397 */ 398 PetscInitializeFortran(); 399 PETScParseFortranArgs_Private(&PetscGlobalArgc,&PetscGlobalArgs); 400 FIXCHAR(filename,len,t1); 401 *ierr = PetscOptionsInsert(&PetscGlobalArgc,&PetscGlobalArgs,t1); 402 FREECHAR(filename,t1); 403 if (*ierr) {(*PetscErrorPrintf)("PetscInitialize:Creating options database\n");return;} 404 *ierr = PetscOptionsCheckInitial_Private(); 405 if (*ierr) {(*PetscErrorPrintf)("PetscInitialize:Checking initial options\n");return;} 406 *ierr = PetscCitationsInitialize(); 407 if (*ierr) {(*PetscErrorPrintf)("PetscInitialize:PetscCitationsInitialize()\n");return;} 408 #if defined(PETSC_HAVE_SAWS) 409 *ierr = PetscInitializeSAWs(NULL); 410 if (*ierr) {(*PetscErrorPrintf)("PetscInitialize:Initializing SAWs\n");return;} 411 #endif 412 #if defined(PETSC_USE_LOG) 413 *ierr = PetscLogBegin_Private(); 414 if (*ierr) {(*PetscErrorPrintf)("PetscInitialize: intializing logging\n");return;} 415 #endif 416 *ierr = PetscInitialize_DynamicLibraries(); 417 if (*ierr) {(*PetscErrorPrintf)("PetscInitialize:Initializing dynamic libraries\n");return;} 418 419 *ierr = PetscInitializeFortran(); 420 if (*ierr) { (*PetscErrorPrintf)("PetscInitialize:Setting up common block\n");return;} 421 422 *ierr = MPI_Comm_size(PETSC_COMM_WORLD,&size); 423 if (*ierr) { (*PetscErrorPrintf)("PetscInitialize:Getting MPI_Comm_size()\n");return;} 424 *ierr = PetscInfo1(0,"(Fortran):PETSc successfully started: procs %d\n",size); 425 if (*ierr) { (*PetscErrorPrintf)("PetscInitialize:Calling PetscInfo()\n");return;} 426 *ierr = PetscGetHostName(hostname,64); 427 if (*ierr) { (*PetscErrorPrintf)("PetscInitialize:Getting hostname\n");return;} 428 *ierr = PetscInfo1(0,"Running on machine: %s\n",hostname); 429 if (*ierr) { (*PetscErrorPrintf)("PetscInitialize:Calling PetscInfo()\n");return;} 430 *ierr = PetscOptionsCheckInitial_Components(); 431 if (*ierr) {(*PetscErrorPrintf)("PetscInitialize:Checking initial options\n");return;} 432 433 *ierr = PetscThreadCommInitializePackage(); 434 if (*ierr) {(*PetscErrorPrintf)("PetscInitialize:Calling PetscThreadCommInitialize()\n");return;} 435 436 PetscThreadLocalRegister((PetscThreadKey*)&petscstack); /* Creates pthread_key */ 437 #if defined(PETSC_USE_DEBUG) 438 *ierr = PetscStackCreate(); 439 if (*ierr) {(*PetscErrorPrintf)("PetscInitialize:PetscStackCreate()\n");return;} 440 #endif 441 442 #if defined(PETSC_SERIALIZE_FUNCTIONS) 443 *ierr = PetscFPTCreate(10000); 444 if (*ierr) {(*PetscErrorPrintf)("PetscInitialize:PetscFPTCreate()\n");return;} 445 #endif 446 447 #if defined(PETSC_HAVE_CUDA) 448 flg2 = PETSC_TRUE; 449 *ierr = PetscOptionsGetBool(NULL,"-cublas",&flg2,NULL); 450 if (flg2) cublasInit(); 451 #endif 452 } 453 454 PETSC_EXTERN void PETSC_STDCALL petscfinalize_(PetscErrorCode *ierr) 455 { 456 #if defined(PETSC_HAVE_SUNMATHPRO) 457 extern void standard_arithmetic(); 458 standard_arithmetic(); 459 #endif 460 /* was malloced with PetscMallocAlign() so free the same way */ 461 *ierr = PetscFreeAlign(PetscGlobalArgs,0,0,0);if (*ierr) {(*PetscErrorPrintf)("PetscFinalize:Freeing args\n");return;} 462 463 *ierr = PetscFinalize(); 464 } 465 466 void PETSC_STDCALL petscend_(PetscErrorCode *ierr) 467 { 468 #if defined(PETSC_HAVE_SUNMATHPRO) 469 extern void standard_arithmetic(); 470 standard_arithmetic(); 471 #endif 472 473 *ierr = PetscEnd(); 474 } 475 476