Date: 2025-03-28T21:11:13+00:00

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

     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

     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 */

     54: PETSC_EXTERN void mpi_init_(int *);
     55: PETSC_EXTERN void petscgetcomm_(PetscMPIInt *);

     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;

     67: /*
     68:     Reads in Fortran command line arguments and sends them to
     69:   all processors.
     70: */

     72: PetscErrorCode PETScParseFortranArgs_Private(int *argc, char ***argv)
     73: {
     74:   int         i;
     75:   int         warg = 256;
     76:   PetscMPIInt rank;
     77:   char       *p;

     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));

     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);

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

    107: /* -----------------------------------------------------------------------------------------------*/

    109: PETSC_INTERN PetscErrorCode PetscPreMPIInit_Private(void);

    111: PETSC_INTERN PetscErrorCode PetscInitFortran_Private(PetscBool readarguments, const char *filename, PetscInt len)
    112: {
    113:   char *tmp = NULL;

    115:   PetscFunctionBegin;
    116:   PetscCall(PetscInitializeFortran());
    117:   if (readarguments) {
    118:     PetscCall(PETScParseFortranArgs_Private(&PetscGlobalArgc, &PetscGlobalArgsFortran));
    119:     PetscGlobalArgs = PetscGlobalArgsFortran;
    120:     if (filename != PETSC_NULL_CHARACTER_Fortran) { /* FIXCHAR */
    121:       while ((len > 0) && (filename[len - 1] == ' ')) len--;
    122:       PetscCall(PetscMalloc1(len + 1, &tmp));
    123:       PetscCall(PetscStrncpy(tmp, filename, len + 1));
    124:     }
    125:     PetscCall(PetscOptionsInsert(NULL, &PetscGlobalArgc, &PetscGlobalArgsFortran, tmp));
    126:     PetscCall(PetscFree(tmp)); /* FREECHAR */
    127:   }
    128:   PetscFunctionReturn(PETSC_SUCCESS);
    129: }

    131: /*
    132:     petscinitialize - Version called from Fortran.

    134:     Note:
    135:       Since this is called from Fortran it does not return error codes

    137: */
    138: PETSC_EXTERN void petscinitializef_(char *filename, char *help, PetscBool *readarguments, PetscErrorCode *ierr, PETSC_FORTRAN_CHARLEN_T len, PETSC_FORTRAN_CHARLEN_T helplen)
    139: {
    140:   int         j, i;
    141:   int         flag;
    142:   char        name[256] = {0};
    143:   PetscMPIInt f_petsc_comm_world;

    145:   *ierr = PETSC_SUCCESS;
    146:   if (PetscInitializeCalled) return;
    147:   i = 0;
    148:   petscgetcommandargument_(&i, name, sizeof(name));
    149:   /* Eliminate spaces at the end of the string */
    150:   for (j = sizeof(name) - 2; j >= 0; j--) {
    151:     if (name[j] != ' ') {
    152:       name[j + 1] = 0;
    153:       break;
    154:     }
    155:   }
    156:   if (j < 0) {
    157:     *ierr = PetscStrncpy(name, "Unknown Name", 256);
    158:     if (*ierr) return;
    159:   }

    161:   /* check if PETSC_COMM_WORLD is initialized by the user in Fortran */
    162:   petscgetcomm_(&f_petsc_comm_world);
    163:   MPI_Initialized(&flag);
    164:   if (!flag) {
    165:     PetscMPIInt mierr;

    167:     if (f_petsc_comm_world) {
    168:       *ierr = (*PetscErrorPrintf)("You cannot set PETSC_COMM_WORLD if you have not initialized MPI first\n");
    169:       return;
    170:     }

    172:     *ierr = PetscPreMPIInit_Private();
    173:     if (*ierr) return;
    174:     mpi_init_(&mierr);
    175:     if (mierr) {
    176:       *ierr = (*PetscErrorPrintf)("PetscInitialize: Calling Fortran MPI_Init()\n");
    177:       *ierr = (PetscErrorCode)mierr;
    178:       return;
    179:     }
    180:     PetscBeganMPI = PETSC_TRUE;
    181:   }
    182:   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 */
    183:   else PETSC_COMM_WORLD = MPI_COMM_WORLD;

    185:   *ierr = PetscInitialize_Common(name, filename, help, PETSC_TRUE, *readarguments, (PetscInt)len);
    186:   if (*ierr) {
    187:     (void)(*PetscErrorPrintf)("PetscInitialize:PetscInitialize_Common\n");
    188:     return;
    189:   }
    190: }