Actual source code: zsf.c

      1: #include <petsc/private/f90impl.h>
      2: #include <petsc/private/sfimpl.h>

      4: #if defined(PETSC_HAVE_FORTRAN_CAPS)
      5:   #define petscsfgetgraph_      PETSCSFGETGRAPH
      6:   #define petscsfbcastbegin_    PETSCSFBCASTBEGIN
      7:   #define petscsfbcastend_      PETSCSFBCASTEND
      8:   #define petscsfreducebegin_   PETSCSFREDUCEBEGIN
      9:   #define petscsfreduceend_     PETSCSFREDUCEEND
     10:   #define f90arraysfnodecreate_ F90ARRAYSFNODECREATE
     11:   #define petscsfgetleafranks_  PETSCSFGETLEAFRANKS
     12:   #define petscsfgetrootranks_  PETSCSFGETROOTRANKS
     13: #elif !defined(PETSC_HAVE_FORTRAN_UNDERSCORE)
     14:   #define petscsfgetgraph_      petscsfgetgraph
     15:   #define petscsfbcastbegin_    petscsfbcastbegin
     16:   #define petscsfbcastend_      petscsfbcastend
     17:   #define petscsfreducebegin_   petscsfreducebegin
     18:   #define petscsfreduceend_     petscsfreduceend
     19:   #define f90arraysfnodecreate_ f90arraysfnodecreate
     20:   #define petscsfgetleafranks_  petscsfgetleafranks
     21:   #define petscsfgetrootranks_  petscsfgetrootranks
     22: #endif

     24: PETSC_EXTERN void f90arraysfnodecreate_(const PetscInt *, PetscInt *, void *PETSC_F90_2PTR_PROTO_NOVAR);

     26: PETSC_EXTERN void petscsfgetgraph_(PetscSF *sf, PetscInt *nroots, PetscInt *nleaves, F90Array1d *ailocal, F90Array1d *airemote, PetscErrorCode *ierr PETSC_F90_2PTR_PROTO(pilocal) PETSC_F90_2PTR_PROTO(piremote))
     27: {
     28:   const PetscInt    *ilocal;
     29:   const PetscSFNode *iremote;
     30:   PetscInt           nl;

     32:   *ierr = PetscSFGetGraph(*sf, nroots, nleaves, &ilocal, &iremote);
     33:   if (*ierr) return;
     34:   nl = *nleaves;
     35:   if (!ilocal) nl = 0;
     36:   *ierr = F90Array1dCreate((void *)ilocal, MPIU_INT, 1, nl, ailocal PETSC_F90_2PTR_PARAM(pilocal));
     37:   /* this creates a memory leak */
     38:   f90arraysfnodecreate_((PetscInt *)iremote, nleaves, airemote PETSC_F90_2PTR_PARAM(piremote));
     39: }

     41: PETSC_EXTERN void petscsfgetleafranks_(PetscSF *sf, PetscMPIInt *niranks, F90Array1d *airanks, F90Array1d *aioffset, F90Array1d *airootloc, PetscErrorCode *ierr PETSC_F90_2PTR_PROTO(piranks) PETSC_F90_2PTR_PROTO(pioffset) PETSC_F90_2PTR_PROTO(pirootloc))
     42: {
     43:   const PetscMPIInt *iranks   = NULL;
     44:   const PetscInt    *ioffset  = NULL;
     45:   const PetscInt    *irootloc = NULL;

     47:   *ierr = PetscSFGetLeafRanks(*sf, niranks, &iranks, &ioffset, &irootloc);
     48:   if (*ierr) return;
     49:   *ierr = F90Array1dCreate((void *)irootloc, MPIU_INT, 1, ioffset[*niranks], airootloc PETSC_F90_2PTR_PARAM(pirootloc));
     50:   if (*ierr) return;
     51:   *ierr = F90Array1dCreate((void *)iranks, MPI_INT, 1, *niranks, airanks PETSC_F90_2PTR_PARAM(piranks));
     52:   if (*ierr) return;
     53:   *ierr = F90Array1dCreate((void *)ioffset, MPIU_INT, 1, *niranks + 1, aioffset PETSC_F90_2PTR_PARAM(pioffset));
     54:   if (*ierr) return;
     55: }

     57: PETSC_EXTERN void petscsfgetrootranks_(PetscSF *sf, PetscMPIInt *nranks, F90Array1d *aranks, F90Array1d *aroffset, F90Array1d *armine, F90Array1d *arremote, PetscErrorCode *ierr PETSC_F90_2PTR_PROTO(pranks) PETSC_F90_2PTR_PROTO(proffset) PETSC_F90_2PTR_PROTO(prmine) PETSC_F90_2PTR_PROTO(prremote))
     58: {
     59:   const PetscMPIInt *ranks   = NULL;
     60:   const PetscInt    *roffset = NULL;
     61:   const PetscInt    *rmine   = NULL;
     62:   const PetscInt    *rremote = NULL;

     64:   *ierr = PetscSFGetRootRanks(*sf, nranks, &ranks, &roffset, &rmine, &rremote);
     65:   if (*ierr) return;
     66:   *ierr = F90Array1dCreate((void *)ranks, MPI_INT, 1, *nranks, aranks PETSC_F90_2PTR_PARAM(pranks));
     67:   if (*ierr) return;
     68:   *ierr = F90Array1dCreate((void *)roffset, MPIU_INT, 1, *nranks + 1, aroffset PETSC_F90_2PTR_PARAM(proffset));
     69:   if (*ierr) return;
     70:   *ierr = F90Array1dCreate((void *)rmine, MPIU_INT, 1, roffset[*nranks], armine PETSC_F90_2PTR_PARAM(prmine));
     71:   if (*ierr) return;
     72:   *ierr = F90Array1dCreate((void *)rremote, MPIU_INT, 1, roffset[*nranks], arremote PETSC_F90_2PTR_PARAM(prremote));
     73:   if (*ierr) return;
     74: }

     76: #if defined(PETSC_HAVE_F90_ASSUMED_TYPE_NOT_PTR)
     77: PETSC_EXTERN void petscsfbcastbegin_(PetscSF *sf, MPI_Fint *unit, const void *rptr, void *lptr, MPI_Fint *op, PetscErrorCode *ierr)
     78: {
     79:   MPI_Datatype dtype;
     80:   MPI_Op       cop = MPI_Op_f2c(*op);

     82:   *ierr = PetscMPIFortranDatatypeToC(*unit, &dtype);
     83:   if (*ierr) return;
     84:   *ierr = PetscSFBcastBegin(*sf, dtype, rptr, lptr, cop);
     85: }

     87: PETSC_EXTERN void petscsfbcastend_(PetscSF *sf, MPI_Fint *unit, const void *rptr, void *lptr, MPI_Fint *op, PetscErrorCode *ierr)
     88: {
     89:   MPI_Datatype dtype;
     90:   MPI_Op       cop = MPI_Op_f2c(*op);

     92:   *ierr = PetscMPIFortranDatatypeToC(*unit, &dtype);
     93:   if (*ierr) return;
     94:   *ierr = PetscSFBcastEnd(*sf, dtype, rptr, lptr, cop);
     95: }

     97: PETSC_EXTERN void petscsfreducebegin_(PetscSF *sf, MPI_Fint *unit, const void *lptr, void *rptr, MPI_Fint *op, PetscErrorCode *ierr)
     98: {
     99:   MPI_Datatype dtype;
    100:   MPI_Op       cop = MPI_Op_f2c(*op);

    102:   *ierr = PetscMPIFortranDatatypeToC(*unit, &dtype);
    103:   if (*ierr) return;
    104:   *ierr = PetscSFReduceBegin(*sf, dtype, lptr, rptr, cop);
    105: }

    107: PETSC_EXTERN void petscsfreduceend_(PetscSF *sf, MPI_Fint *unit, const void *lptr, void *rptr, MPI_Fint *op, PetscErrorCode *ierr)
    108: {
    109:   MPI_Datatype dtype;
    110:   MPI_Op       cop = MPI_Op_f2c(*op);

    112:   *ierr = PetscMPIFortranDatatypeToC(*unit, &dtype);
    113:   if (*ierr) return;
    114:   *ierr = PetscSFReduceEnd(*sf, dtype, lptr, rptr, cop);
    115: }

    117: #else

    119: PETSC_EXTERN void petscsfbcastbegin_(PetscSF *sf, MPI_Fint *unit, F90Array1d *rptr, F90Array1d *lptr, MPI_Fint *op, PetscErrorCode *ierr PETSC_F90_2PTR_PROTO(rptrd) PETSC_F90_2PTR_PROTO(lptrd))
    120: {
    121:   MPI_Datatype dtype;
    122:   const void  *rootdata;
    123:   void        *leafdata;
    124:   MPI_Op       cop = MPI_Op_f2c(*op);

    126:   *ierr = PetscMPIFortranDatatypeToC(*unit, &dtype);
    127:   if (*ierr) return;
    128:   *ierr = F90Array1dAccess(rptr, dtype, (void **)&rootdata PETSC_F90_2PTR_PARAM(rptrd));
    129:   if (*ierr) return;
    130:   *ierr = F90Array1dAccess(lptr, dtype, (void **)&leafdata PETSC_F90_2PTR_PARAM(lptrd));
    131:   if (*ierr) return;
    132:   *ierr = PetscSFBcastBegin(*sf, dtype, rootdata, leafdata, cop);
    133: }

    135: PETSC_EXTERN void petscsfbcastend_(PetscSF *sf, MPI_Fint *unit, F90Array1d *rptr, F90Array1d *lptr, MPI_Fint *op, PetscErrorCode *ierr PETSC_F90_2PTR_PROTO(rptrd) PETSC_F90_2PTR_PROTO(lptrd))
    136: {
    137:   MPI_Datatype dtype;
    138:   const void  *rootdata;
    139:   void        *leafdata;
    140:   MPI_Op       cop = MPI_Op_f2c(*op);

    142:   *ierr = PetscMPIFortranDatatypeToC(*unit, &dtype);
    143:   if (*ierr) return;
    144:   *ierr = F90Array1dAccess(rptr, dtype, (void **)&rootdata PETSC_F90_2PTR_PARAM(rptrd));
    145:   if (*ierr) return;
    146:   *ierr = F90Array1dAccess(lptr, dtype, (void **)&leafdata PETSC_F90_2PTR_PARAM(lptrd));
    147:   if (*ierr) return;
    148:   *ierr = PetscSFBcastEnd(*sf, dtype, rootdata, leafdata, cop);
    149: }

    151: PETSC_EXTERN void petscsfreducebegin_(PetscSF *sf, MPI_Fint *unit, F90Array1d *lptr, F90Array1d *rptr, MPI_Fint *op, PetscErrorCode *ierr PETSC_F90_2PTR_PROTO(lptrd) PETSC_F90_2PTR_PROTO(rptrd))
    152: {
    153:   MPI_Datatype dtype;
    154:   const void  *leafdata;
    155:   void        *rootdata;
    156:   MPI_Op       cop = MPI_Op_f2c(*op);

    158:   *ierr = PetscMPIFortranDatatypeToC(*unit, &dtype);
    159:   if (*ierr) return;
    160:   *ierr = F90Array1dAccess(rptr, dtype, (void **)&rootdata PETSC_F90_2PTR_PARAM(rptrd));
    161:   if (*ierr) return;
    162:   *ierr = F90Array1dAccess(lptr, dtype, (void **)&leafdata PETSC_F90_2PTR_PARAM(lptrd));
    163:   if (*ierr) return;
    164:   *ierr = PetscSFReduceBegin(*sf, dtype, leafdata, rootdata, cop);
    165: }

    167: PETSC_EXTERN void petscsfreduceend_(PetscSF *sf, MPI_Fint *unit, F90Array1d *lptr, F90Array1d *rptr, MPI_Fint *op, PetscErrorCode *ierr PETSC_F90_2PTR_PROTO(lptrd) PETSC_F90_2PTR_PROTO(rptrd))
    168: {
    169:   MPI_Datatype dtype;
    170:   const void  *leafdata;
    171:   void        *rootdata;
    172:   MPI_Op       cop = MPI_Op_f2c(*op);

    174:   *ierr = PetscMPIFortranDatatypeToC(*unit, &dtype);
    175:   if (*ierr) return;
    176:   *ierr = F90Array1dAccess(rptr, dtype, (void **)&rootdata PETSC_F90_2PTR_PARAM(rptrd));
    177:   if (*ierr) return;
    178:   *ierr = F90Array1dAccess(lptr, dtype, (void **)&leafdata PETSC_F90_2PTR_PARAM(lptrd));
    179:   if (*ierr) return;
    180:   *ierr = PetscSFReduceEnd(*sf, dtype, leafdata, rootdata, cop);
    181: }
    182: #endif