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);if (*ierr) return; 55 nl = *nleaves; 56 if (!ilocal) nl = 0; 57 *ierr = F90Array1dCreate((void*)ilocal,MPIU_INT,1,nl, ailocal PETSC_F90_2PTR_PARAM(pilocal)); 58 /* this creates a memory leak */ 59 f90arraysfnodecreate_((PetscInt*)iremote,nleaves, airemote PETSC_F90_2PTR_PARAM(piremote)); 60 } 61 62 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)) 63 { 64 const PetscMPIInt *iranks = NULL; 65 const PetscInt *ioffset = NULL; 66 const PetscInt *irootloc = NULL; 67 68 *ierr = PetscSFGetLeafRanks(*sf, niranks, &iranks, &ioffset, &irootloc);if (*ierr) return; 69 *ierr = F90Array1dCreate((void*)irootloc, MPIU_INT, 1, ioffset[*niranks], airootloc PETSC_F90_2PTR_PARAM(pirootloc));if (*ierr) return; 70 *ierr = F90Array1dCreate((void*)iranks, MPI_INT, 1, *niranks, airanks PETSC_F90_2PTR_PARAM(piranks));if (*ierr) return; 71 *ierr = F90Array1dCreate((void*)ioffset, MPIU_INT, 1, *niranks+1, aioffset PETSC_F90_2PTR_PARAM(pioffset));if (*ierr) return; 72 } 73 74 PETSC_EXTERN void petscsfgetrootranks_(PetscSF *sf, PetscInt *nranks, F90Array1d *aranks, F90Array1d *aroffset, F90Array1d *armine, F90Array1d *arremote, 75 PetscErrorCode *ierr PETSC_F90_2PTR_PROTO(pranks) PETSC_F90_2PTR_PROTO(proffset) PETSC_F90_2PTR_PROTO(prmine) PETSC_F90_2PTR_PROTO(prremote)) 76 { 77 const PetscMPIInt *ranks = NULL; 78 const PetscInt *roffset = NULL; 79 const PetscInt *rmine = NULL; 80 const PetscInt *rremote = NULL; 81 82 *ierr = PetscSFGetRootRanks(*sf, nranks, &ranks, &roffset, &rmine, &rremote);if (*ierr) return; 83 *ierr = F90Array1dCreate((void*)ranks, MPI_INT, 1, *nranks, aranks PETSC_F90_2PTR_PARAM(pranks));if (*ierr) return; 84 *ierr = F90Array1dCreate((void*)roffset, MPIU_INT, 1, *nranks+1, aroffset PETSC_F90_2PTR_PARAM(proffset));if (*ierr) return; 85 *ierr = F90Array1dCreate((void*)rmine, MPIU_INT, 1, roffset[*nranks], armine PETSC_F90_2PTR_PARAM(prmine));if (*ierr) return; 86 *ierr = F90Array1dCreate((void*)rremote, MPIU_INT, 1, roffset[*nranks], arremote PETSC_F90_2PTR_PARAM(prremote));if (*ierr) return; 87 } 88 89 #if defined(PETSC_HAVE_F90_ASSUMED_TYPE_NOT_PTR) 90 PETSC_EXTERN void petscsfbcastbegin_(PetscSF *sf, MPI_Fint *unit, const void *rptr, void *lptr, MPI_Fint *op, PetscErrorCode *ierr) 91 { 92 MPI_Datatype dtype; 93 MPI_Op cop = MPI_Op_f2c(*op); 94 95 *ierr = PetscMPIFortranDatatypeToC(*unit,&dtype);if (*ierr) return; 96 *ierr = PetscSFBcastBegin(*sf, dtype, rptr, lptr, cop); 97 } 98 99 PETSC_EXTERN void petscsfbcastend_(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);if (*ierr) return; 105 *ierr = PetscSFBcastEnd(*sf, dtype, rptr, lptr, cop); 106 } 107 108 PETSC_EXTERN void petscsfreducebegin_(PetscSF *sf, MPI_Fint *unit, const void *lptr, void *rptr, MPI_Fint *op, PetscErrorCode *ierr) 109 { 110 MPI_Datatype dtype; 111 MPI_Op cop = MPI_Op_f2c(*op); 112 113 *ierr = PetscMPIFortranDatatypeToC(*unit,&dtype);if (*ierr) return; 114 *ierr = PetscSFReduceBegin(*sf, dtype, lptr, rptr, cop); 115 } 116 117 PETSC_EXTERN void petscsfreduceend_(PetscSF *sf, MPI_Fint *unit, const void *lptr, void *rptr, MPI_Fint *op, PetscErrorCode *ierr) 118 { 119 MPI_Datatype dtype; 120 MPI_Op cop = MPI_Op_f2c(*op); 121 122 *ierr = PetscMPIFortranDatatypeToC(*unit,&dtype);if (*ierr) return; 123 *ierr = PetscSFReduceEnd(*sf, dtype, lptr, rptr, cop); 124 } 125 126 #else 127 128 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)) 129 { 130 MPI_Datatype dtype; 131 const void *rootdata; 132 void *leafdata; 133 MPI_Op cop = MPI_Op_f2c(*op); 134 135 *ierr = PetscMPIFortranDatatypeToC(*unit,&dtype);if (*ierr) return; 136 *ierr = F90Array1dAccess(rptr, dtype, (void**) &rootdata PETSC_F90_2PTR_PARAM(rptrd));if (*ierr) return; 137 *ierr = F90Array1dAccess(lptr, dtype, (void**) &leafdata PETSC_F90_2PTR_PARAM(lptrd));if (*ierr) return; 138 *ierr = PetscSFBcastBegin(*sf, dtype, rootdata, leafdata, cop); 139 } 140 141 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)) 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);if (*ierr) return; 149 *ierr = F90Array1dAccess(rptr, dtype, (void**) &rootdata PETSC_F90_2PTR_PARAM(rptrd));if (*ierr) return; 150 *ierr = F90Array1dAccess(lptr, dtype, (void**) &leafdata PETSC_F90_2PTR_PARAM(lptrd));if (*ierr) return; 151 *ierr = PetscSFBcastEnd(*sf, dtype, rootdata, leafdata, cop); 152 } 153 154 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)) 155 { 156 MPI_Datatype dtype; 157 const void *leafdata; 158 void *rootdata; 159 MPI_Op cop = MPI_Op_f2c(*op); 160 161 *ierr = PetscMPIFortranDatatypeToC(*unit,&dtype);if (*ierr) return; 162 *ierr = F90Array1dAccess(rptr, dtype, (void**) &rootdata PETSC_F90_2PTR_PARAM(rptrd));if (*ierr) return; 163 *ierr = F90Array1dAccess(lptr, dtype, (void**) &leafdata PETSC_F90_2PTR_PARAM(lptrd));if (*ierr) return; 164 *ierr = PetscSFReduceBegin(*sf, dtype, leafdata, rootdata, cop); 165 } 166 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); 173 174 *ierr = PetscMPIFortranDatatypeToC(*unit,&dtype);if (*ierr) return; 175 *ierr = F90Array1dAccess(rptr, dtype, (void**) &rootdata PETSC_F90_2PTR_PARAM(rptrd));if (*ierr) return; 176 *ierr = F90Array1dAccess(lptr, dtype, (void**) &leafdata PETSC_F90_2PTR_PARAM(lptrd));if (*ierr) return; 177 *ierr = PetscSFReduceEnd(*sf, dtype, leafdata, rootdata, cop); 178 } 179 180 PETSC_EXTERN void petscsfviewfromoptions_(PetscSF *ao,PetscObject obj,char* type,PetscErrorCode *ierr,PETSC_FORTRAN_CHARLEN_T len) 181 { 182 char *t; 183 184 FIXCHAR(type,len,t); 185 CHKFORTRANNULLOBJECT(obj); 186 *ierr = PetscSFViewFromOptions(*ao,obj,t);if (*ierr) return; 187 FREECHAR(type,t); 188 } 189 190 PETSC_EXTERN void petscsfdestroy_(PetscSF *x,int *ierr) 191 { 192 PETSC_FORTRAN_OBJECT_F_DESTROYED_TO_C_NULL(x); 193 *ierr = PetscSFDestroy(x); if (*ierr) return; 194 PETSC_FORTRAN_OBJECT_C_NULL_TO_F_DESTROYED(x); 195 } 196 197 #endif 198