Actual source code: zsf.c
1: #include <petsc/private/ftnimpl.h>
2: #include <petsc/private/sfimpl.h>
4: #if defined(PETSC_HAVE_FORTRAN_CAPS)
5: #define petscsfrestoregraph_ PETSCSFRESTOREGRAPH
6: #define petscsfgetgraph_ PETSCSFGETGRAPH
7: #define petscsfbcastbegin_ PETSCSFBCASTBEGIN
8: #define petscsfbcastend_ PETSCSFBCASTEND
9: #define petscsfreducebegin_ PETSCSFREDUCEBEGIN
10: #define petscsfreduceend_ PETSCSFREDUCEEND
11: #define petscsfgetleafranks_ PETSCSFGETLEAFRANKS
12: #define petscsfgetrootranks_ PETSCSFGETROOTRANKS
13: #define f90array1dcreatesfnode_ F90ARRAY1DCREATESFNODE
14: #define f90array1ddestroysfnode_ F90ARRAY1DDESTROYSFNODE
15: #elif !defined(PETSC_HAVE_FORTRAN_UNDERSCORE)
16: #define petscsfrestoregraph_ petscsfrestoregraph
17: #define petscsfgetgraph_ petscsfgetgraph
18: #define petscsfbcastbegin_ petscsfbcastbegin
19: #define petscsfbcastend_ petscsfbcastend
20: #define petscsfreducebegin_ petscsfreducebegin
21: #define petscsfreduceend_ petscsfreduceend
22: #define petscsfgetleafranks_ petscsfgetleafranks
23: #define petscsfgetrootranks_ petscsfgetrootranks
24: #define f90array1dcreatesfnode_ f90array1dcreatesfnode
25: #define f90array1ddestroysfnode_ f90array1ddestroysfnode
26: #endif
28: PETSC_EXTERN void f90array1dcreatesfnode_(const PetscSFNode *, PetscInt *, PetscInt *, void *PETSC_F90_2PTR_PROTO_NOVAR);
29: PETSC_EXTERN void f90array1ddestroysfnode_(void *PETSC_F90_2PTR_PROTO_NOVAR);
31: 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))
32: {
33: const PetscInt *ilocal;
34: const PetscSFNode *iremote;
35: PetscInt nl, one = 1;
37: *ierr = PetscSFGetGraph(*sf, nroots, nleaves, &ilocal, &iremote);
38: if (*ierr) return;
39: nl = *nleaves;
40: if (!ilocal) nl = 0;
41: *ierr = F90Array1dCreate((void *)ilocal, MPIU_INT, 1, nl, ailocal PETSC_F90_2PTR_PARAM(pilocal));
42: /* this creates a memory leak */
43: f90array1dcreatesfnode_(iremote, &one, nleaves, airemote PETSC_F90_2PTR_PARAM(piremote));
44: }
46: PETSC_EXTERN void petscsfrestoregraph_(PetscSF *sf, PetscInt *nroots, PetscInt *nleaves, F90Array1d *ailocal, F90Array1d *airemote, PetscErrorCode *ierr PETSC_F90_2PTR_PROTO(pilocal) PETSC_F90_2PTR_PROTO(piremote))
47: {
48: *ierr = F90Array1dDestroy(ailocal, MPIU_INT PETSC_F90_2PTR_PARAM(pilocal));
49: if (*ierr) return;
50: f90array1ddestroysfnode_(airemote PETSC_F90_2PTR_PARAM(piremote));
51: }
53: 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))
54: {
55: const PetscMPIInt *iranks = NULL;
56: const PetscInt *ioffset = NULL;
57: const PetscInt *irootloc = NULL;
59: *ierr = PetscSFGetLeafRanks(*sf, niranks, &iranks, &ioffset, &irootloc);
60: if (*ierr) return;
61: *ierr = F90Array1dCreate((void *)irootloc, MPIU_INT, 1, ioffset[*niranks], airootloc PETSC_F90_2PTR_PARAM(pirootloc));
62: if (*ierr) return;
63: *ierr = F90Array1dCreate((void *)iranks, MPI_INT, 1, *niranks, airanks PETSC_F90_2PTR_PARAM(piranks));
64: if (*ierr) return;
65: *ierr = F90Array1dCreate((void *)ioffset, MPIU_INT, 1, *niranks + 1, aioffset PETSC_F90_2PTR_PARAM(pioffset));
66: if (*ierr) return;
67: }
69: 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))
70: {
71: const PetscMPIInt *ranks = NULL;
72: const PetscInt *roffset = NULL;
73: const PetscInt *rmine = NULL;
74: const PetscInt *rremote = NULL;
76: *ierr = PetscSFGetRootRanks(*sf, nranks, &ranks, &roffset, &rmine, &rremote);
77: if (*ierr) return;
78: *ierr = F90Array1dCreate((void *)ranks, MPI_INT, 1, *nranks, aranks PETSC_F90_2PTR_PARAM(pranks));
79: if (*ierr) return;
80: *ierr = F90Array1dCreate((void *)roffset, MPIU_INT, 1, *nranks + 1, aroffset PETSC_F90_2PTR_PARAM(proffset));
81: if (*ierr) return;
82: *ierr = F90Array1dCreate((void *)rmine, MPIU_INT, 1, roffset[*nranks], armine PETSC_F90_2PTR_PARAM(prmine));
83: if (*ierr) return;
84: *ierr = F90Array1dCreate((void *)rremote, MPIU_INT, 1, roffset[*nranks], arremote PETSC_F90_2PTR_PARAM(prremote));
85: if (*ierr) return;
86: }
88: #if defined(PETSC_HAVE_F90_ASSUMED_TYPE_NOT_PTR)
89: PETSC_EXTERN void petscsfbcastbegin_(PetscSF *sf, MPI_Fint *unit, const void *rptr, void *lptr, MPI_Fint *op, PetscErrorCode *ierr)
90: {
91: MPI_Datatype dtype;
92: MPI_Op cop = MPI_Op_f2c(*op);
94: *ierr = PetscMPIFortranDatatypeToC(*unit, &dtype);
95: if (*ierr) return;
96: *ierr = PetscSFBcastBegin(*sf, dtype, rptr, lptr, cop);
97: }
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);
104: *ierr = PetscMPIFortranDatatypeToC(*unit, &dtype);
105: if (*ierr) return;
106: *ierr = PetscSFBcastEnd(*sf, dtype, rptr, lptr, cop);
107: }
109: PETSC_EXTERN void petscsfreducebegin_(PetscSF *sf, MPI_Fint *unit, const void *lptr, void *rptr, MPI_Fint *op, PetscErrorCode *ierr)
110: {
111: MPI_Datatype dtype;
112: MPI_Op cop = MPI_Op_f2c(*op);
114: *ierr = PetscMPIFortranDatatypeToC(*unit, &dtype);
115: if (*ierr) return;
116: *ierr = PetscSFReduceBegin(*sf, dtype, lptr, rptr, cop);
117: }
119: PETSC_EXTERN void petscsfreduceend_(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);
124: *ierr = PetscMPIFortranDatatypeToC(*unit, &dtype);
125: if (*ierr) return;
126: *ierr = PetscSFReduceEnd(*sf, dtype, lptr, rptr, cop);
127: }
129: #else
131: 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))
132: {
133: MPI_Datatype dtype;
134: const void *rootdata;
135: void *leafdata;
136: MPI_Op cop = MPI_Op_f2c(*op);
138: *ierr = PetscMPIFortranDatatypeToC(*unit, &dtype);
139: if (*ierr) return;
140: *ierr = F90Array1dAccess(rptr, dtype, (void **)&rootdata PETSC_F90_2PTR_PARAM(rptrd));
141: if (*ierr) return;
142: *ierr = F90Array1dAccess(lptr, dtype, (void **)&leafdata PETSC_F90_2PTR_PARAM(lptrd));
143: if (*ierr) return;
144: *ierr = PetscSFBcastBegin(*sf, dtype, rootdata, leafdata, cop);
145: }
147: 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))
148: {
149: MPI_Datatype dtype;
150: const void *rootdata;
151: void *leafdata;
152: MPI_Op cop = MPI_Op_f2c(*op);
154: *ierr = PetscMPIFortranDatatypeToC(*unit, &dtype);
155: if (*ierr) return;
156: *ierr = F90Array1dAccess(rptr, dtype, (void **)&rootdata PETSC_F90_2PTR_PARAM(rptrd));
157: if (*ierr) return;
158: *ierr = F90Array1dAccess(lptr, dtype, (void **)&leafdata PETSC_F90_2PTR_PARAM(lptrd));
159: if (*ierr) return;
160: *ierr = PetscSFBcastEnd(*sf, dtype, rootdata, leafdata, cop);
161: }
163: 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))
164: {
165: MPI_Datatype dtype;
166: const void *leafdata;
167: void *rootdata;
168: MPI_Op cop = MPI_Op_f2c(*op);
170: *ierr = PetscMPIFortranDatatypeToC(*unit, &dtype);
171: if (*ierr) return;
172: *ierr = F90Array1dAccess(rptr, dtype, (void **)&rootdata PETSC_F90_2PTR_PARAM(rptrd));
173: if (*ierr) return;
174: *ierr = F90Array1dAccess(lptr, dtype, (void **)&leafdata PETSC_F90_2PTR_PARAM(lptrd));
175: if (*ierr) return;
176: *ierr = PetscSFReduceBegin(*sf, dtype, leafdata, rootdata, cop);
177: }
179: 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))
180: {
181: MPI_Datatype dtype;
182: const void *leafdata;
183: void *rootdata;
184: MPI_Op cop = MPI_Op_f2c(*op);
186: *ierr = PetscMPIFortranDatatypeToC(*unit, &dtype);
187: if (*ierr) return;
188: *ierr = F90Array1dAccess(rptr, dtype, (void **)&rootdata PETSC_F90_2PTR_PARAM(rptrd));
189: if (*ierr) return;
190: *ierr = F90Array1dAccess(lptr, dtype, (void **)&leafdata PETSC_F90_2PTR_PARAM(lptrd));
191: if (*ierr) return;
192: *ierr = PetscSFReduceEnd(*sf, dtype, leafdata, rootdata, cop);
193: }
194: #endif