1 #include <petsc/private/f90impl.h> 2 #include <petsc/private/sfimpl.h> 3 4 #if defined(PETSC_HAVE_FORTRAN_CAPS) 5 #define petscsfview_ PETSCSFVIEW 6 #define petscsfgetgraph_ PETSCSFGETGRAPH 7 #define petscsfbcastbegin_ PETSCSFBCASTBEGIN 8 #define petscsfbcastend_ PETSCSFBCASTEND 9 #define petscsfreducebegin_ PETSCSFREDUCEBEGIN 10 #define petscsfreduceend_ PETSCSFREDUCEEND 11 #define f90arraysfnodecreate_ F90ARRAYSFNODECREATE 12 #define petscsfviewfromoptions_ PETSCSFVIEWFROMOPTIONS 13 #define petscsfdestroy_ PETSCSFDESTROY 14 #define petscsfsetgraph_ PETSCSFSETGRAPH 15 #define petscsfgetleafranks_ PETSCSFGETLEAFRANKS 16 #define petscsfgetrootranks_ PETSCSFGETROOTRANKS 17 #elif !defined(PETSC_HAVE_FORTRAN_UNDERSCORE) 18 #define petscsfgetgraph_ petscsfgetgraph 19 #define petscsfview_ petscsfview 20 #define petscsfbcastbegin_ petscsfbcastbegin 21 #define petscsfbcastend_ petscsfbcastend 22 #define petscsfreducebegin_ petscsfreducebegin 23 #define petscsfreduceend_ petscsfreduceend 24 #define f90arraysfnodecreate_ f90arraysfnodecreate 25 #define petscsfviewfromoptions_ petscsfviewfromoptions 26 #define petscsfdestroy_ petscsfdestroy 27 #define petscsfsetgraph_ petscsfsetgraph 28 #define petscsfgetleafranks_ petscsfgetleafranks 29 #define petscsfgetrootranks_ petscsfgetrootranks 30 #endif 31 32 PETSC_EXTERN void f90arraysfnodecreate_(const PetscInt *, PetscInt *, void *PETSC_F90_2PTR_PROTO_NOVAR); 33 34 PETSC_EXTERN void petscsfsetgraph_(PetscSF *sf, PetscInt *nroots, PetscInt *nleaves, PetscInt *ilocal, PetscCopyMode *localmode, PetscSFNode *iremote, PetscCopyMode *remotemode, int *ierr) 35 { 36 if (ilocal == PETSC_NULL_INTEGER_Fortran) ilocal = NULL; 37 *ierr = PetscSFSetGraph(*sf, *nroots, *nleaves, ilocal, *localmode, iremote, *remotemode); 38 } 39 40 PETSC_EXTERN void petscsfview_(PetscSF *sf, PetscViewer *vin, PetscErrorCode *ierr) 41 { 42 PetscViewer v; 43 44 PetscPatchDefaultViewers_Fortran(vin, v); 45 *ierr = PetscSFView(*sf, v); 46 } 47 48 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)) 49 { 50 const PetscInt *ilocal; 51 const PetscSFNode *iremote; 52 PetscInt nl; 53 54 *ierr = PetscSFGetGraph(*sf, nroots, nleaves, &ilocal, &iremote); 55 if (*ierr) return; 56 nl = *nleaves; 57 if (!ilocal) nl = 0; 58 *ierr = F90Array1dCreate((void *)ilocal, MPIU_INT, 1, nl, ailocal PETSC_F90_2PTR_PARAM(pilocal)); 59 /* this creates a memory leak */ 60 f90arraysfnodecreate_((PetscInt *)iremote, nleaves, airemote PETSC_F90_2PTR_PARAM(piremote)); 61 } 62 63 PETSC_EXTERN void petscsfgetleafranks_(PetscSF *sf, PetscInt *niranks, F90Array1d *airanks, F90Array1d *aioffset, F90Array1d *airootloc, PetscErrorCode *ierr PETSC_F90_2PTR_PROTO(piranks) PETSC_F90_2PTR_PROTO(pioffset) PETSC_F90_2PTR_PROTO(pirootloc)) 64 { 65 const PetscMPIInt *iranks = NULL; 66 const PetscInt *ioffset = NULL; 67 const PetscInt *irootloc = NULL; 68 69 *ierr = PetscSFGetLeafRanks(*sf, niranks, &iranks, &ioffset, &irootloc); 70 if (*ierr) return; 71 *ierr = F90Array1dCreate((void *)irootloc, MPIU_INT, 1, ioffset[*niranks], airootloc PETSC_F90_2PTR_PARAM(pirootloc)); 72 if (*ierr) return; 73 *ierr = F90Array1dCreate((void *)iranks, MPI_INT, 1, *niranks, airanks PETSC_F90_2PTR_PARAM(piranks)); 74 if (*ierr) return; 75 *ierr = F90Array1dCreate((void *)ioffset, MPIU_INT, 1, *niranks + 1, aioffset PETSC_F90_2PTR_PARAM(pioffset)); 76 if (*ierr) return; 77 } 78 79 PETSC_EXTERN void petscsfgetrootranks_(PetscSF *sf, PetscInt *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)) 80 { 81 const PetscMPIInt *ranks = NULL; 82 const PetscInt *roffset = NULL; 83 const PetscInt *rmine = NULL; 84 const PetscInt *rremote = NULL; 85 86 *ierr = PetscSFGetRootRanks(*sf, nranks, &ranks, &roffset, &rmine, &rremote); 87 if (*ierr) return; 88 *ierr = F90Array1dCreate((void *)ranks, MPI_INT, 1, *nranks, aranks PETSC_F90_2PTR_PARAM(pranks)); 89 if (*ierr) return; 90 *ierr = F90Array1dCreate((void *)roffset, MPIU_INT, 1, *nranks + 1, aroffset PETSC_F90_2PTR_PARAM(proffset)); 91 if (*ierr) return; 92 *ierr = F90Array1dCreate((void *)rmine, MPIU_INT, 1, roffset[*nranks], armine PETSC_F90_2PTR_PARAM(prmine)); 93 if (*ierr) return; 94 *ierr = F90Array1dCreate((void *)rremote, MPIU_INT, 1, roffset[*nranks], arremote PETSC_F90_2PTR_PARAM(prremote)); 95 if (*ierr) return; 96 } 97 98 #if defined(PETSC_HAVE_F90_ASSUMED_TYPE_NOT_PTR) 99 PETSC_EXTERN void petscsfbcastbegin_(PetscSF *sf, MPI_Fint *unit, const void *rptr, void *lptr, MPI_Fint *op, PetscErrorCode *ierr) 100 { 101 MPI_Datatype dtype; 102 MPI_Op cop = MPI_Op_f2c(*op); 103 104 *ierr = PetscMPIFortranDatatypeToC(*unit, &dtype); 105 if (*ierr) return; 106 *ierr = PetscSFBcastBegin(*sf, dtype, rptr, lptr, cop); 107 } 108 109 PETSC_EXTERN void petscsfbcastend_(PetscSF *sf, MPI_Fint *unit, const void *rptr, void *lptr, MPI_Fint *op, PetscErrorCode *ierr) 110 { 111 MPI_Datatype dtype; 112 MPI_Op cop = MPI_Op_f2c(*op); 113 114 *ierr = PetscMPIFortranDatatypeToC(*unit, &dtype); 115 if (*ierr) return; 116 *ierr = PetscSFBcastEnd(*sf, dtype, rptr, lptr, cop); 117 } 118 119 PETSC_EXTERN void petscsfreducebegin_(PetscSF *sf, MPI_Fint *unit, const void *lptr, void *rptr, MPI_Fint *op, PetscErrorCode *ierr) 120 { 121 MPI_Datatype dtype; 122 MPI_Op cop = MPI_Op_f2c(*op); 123 124 *ierr = PetscMPIFortranDatatypeToC(*unit, &dtype); 125 if (*ierr) return; 126 *ierr = PetscSFReduceBegin(*sf, dtype, lptr, rptr, cop); 127 } 128 129 PETSC_EXTERN void petscsfreduceend_(PetscSF *sf, MPI_Fint *unit, const void *lptr, void *rptr, MPI_Fint *op, PetscErrorCode *ierr) 130 { 131 MPI_Datatype dtype; 132 MPI_Op cop = MPI_Op_f2c(*op); 133 134 *ierr = PetscMPIFortranDatatypeToC(*unit, &dtype); 135 if (*ierr) return; 136 *ierr = PetscSFReduceEnd(*sf, dtype, lptr, rptr, cop); 137 } 138 139 #else 140 141 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)) 142 { 143 MPI_Datatype dtype; 144 const void *rootdata; 145 void *leafdata; 146 MPI_Op cop = MPI_Op_f2c(*op); 147 148 *ierr = PetscMPIFortranDatatypeToC(*unit, &dtype); 149 if (*ierr) return; 150 *ierr = F90Array1dAccess(rptr, dtype, (void **)&rootdata PETSC_F90_2PTR_PARAM(rptrd)); 151 if (*ierr) return; 152 *ierr = F90Array1dAccess(lptr, dtype, (void **)&leafdata PETSC_F90_2PTR_PARAM(lptrd)); 153 if (*ierr) return; 154 *ierr = PetscSFBcastBegin(*sf, dtype, rootdata, leafdata, cop); 155 } 156 157 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)) 158 { 159 MPI_Datatype dtype; 160 const void *rootdata; 161 void *leafdata; 162 MPI_Op cop = MPI_Op_f2c(*op); 163 164 *ierr = PetscMPIFortranDatatypeToC(*unit, &dtype); 165 if (*ierr) return; 166 *ierr = F90Array1dAccess(rptr, dtype, (void **)&rootdata PETSC_F90_2PTR_PARAM(rptrd)); 167 if (*ierr) return; 168 *ierr = F90Array1dAccess(lptr, dtype, (void **)&leafdata PETSC_F90_2PTR_PARAM(lptrd)); 169 if (*ierr) return; 170 *ierr = PetscSFBcastEnd(*sf, dtype, rootdata, leafdata, cop); 171 } 172 173 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)) 174 { 175 MPI_Datatype dtype; 176 const void *leafdata; 177 void *rootdata; 178 MPI_Op cop = MPI_Op_f2c(*op); 179 180 *ierr = PetscMPIFortranDatatypeToC(*unit, &dtype); 181 if (*ierr) return; 182 *ierr = F90Array1dAccess(rptr, dtype, (void **)&rootdata PETSC_F90_2PTR_PARAM(rptrd)); 183 if (*ierr) return; 184 *ierr = F90Array1dAccess(lptr, dtype, (void **)&leafdata PETSC_F90_2PTR_PARAM(lptrd)); 185 if (*ierr) return; 186 *ierr = PetscSFReduceBegin(*sf, dtype, leafdata, rootdata, cop); 187 } 188 189 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)) 190 { 191 MPI_Datatype dtype; 192 const void *leafdata; 193 void *rootdata; 194 MPI_Op cop = MPI_Op_f2c(*op); 195 196 *ierr = PetscMPIFortranDatatypeToC(*unit, &dtype); 197 if (*ierr) return; 198 *ierr = F90Array1dAccess(rptr, dtype, (void **)&rootdata PETSC_F90_2PTR_PARAM(rptrd)); 199 if (*ierr) return; 200 *ierr = F90Array1dAccess(lptr, dtype, (void **)&leafdata PETSC_F90_2PTR_PARAM(lptrd)); 201 if (*ierr) return; 202 *ierr = PetscSFReduceEnd(*sf, dtype, leafdata, rootdata, cop); 203 } 204 205 PETSC_EXTERN void petscsfviewfromoptions_(PetscSF *ao, PetscObject obj, char *type, PetscErrorCode *ierr, PETSC_FORTRAN_CHARLEN_T len) 206 { 207 char *t; 208 209 FIXCHAR(type, len, t); 210 CHKFORTRANNULLOBJECT(obj); 211 *ierr = PetscSFViewFromOptions(*ao, obj, t); 212 if (*ierr) return; 213 FREECHAR(type, t); 214 } 215 216 PETSC_EXTERN void petscsfdestroy_(PetscSF *x, int *ierr) 217 { 218 PETSC_FORTRAN_OBJECT_F_DESTROYED_TO_C_NULL(x); 219 *ierr = PetscSFDestroy(x); 220 if (*ierr) return; 221 PETSC_FORTRAN_OBJECT_C_NULL_TO_F_DESTROYED(x); 222 } 223 224 #endif 225