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