Actual source code: zdtdsf90.c
1: #include <petsc/private/fortranimpl.h>
2: #include <petscds.h>
3: #include <petsc/private/f90impl.h>
5: #if defined(PETSC_HAVE_FORTRAN_CAPS)
6: #define petscdsgettabulation_ PETSCDSGETTABULATION
7: #define petscdsrestoretabulation_ PETSCDSRESTORETABULATION
8: #define petscdsgetbdtabulation_ PETSCDSGETBDTABULATION
9: #define petscdsrestorebdtabulation_ PETSCDSRESTOREBDTABULATION
10: #elif !defined(PETSC_HAVE_FORTRAN_UNDERSCORE)
11: #define petscdsgettabulation_ petscdsgettabulation
12: #define petscdsrestoretabulation_ petscdsrestoretabulation
13: #define petscdsgetbdtabulation_ petscdsgetbdtabulation
14: #define petscdsrestorebdtabulation_ petscdsrestorebdtabulation
15: #endif
17: PETSC_EXTERN void petscdsgettabulation_(PetscDS *prob, PetscInt *f, F90Array1d *ptrB, F90Array1d *ptrD, PetscErrorCode *ierr PETSC_F90_2PTR_PROTO(ptrb) PETSC_F90_2PTR_PROTO(ptrd))
18: {
19: PetscFE fe;
20: PetscQuadrature q;
21: PetscInt dim, Nb, Nc, Nq;
22: PetscTabulation *T;
24: *ierr = PetscDSGetSpatialDimension(*prob, &dim);
25: if (*ierr) return;
26: *ierr = PetscDSGetDiscretization(*prob, *f, (PetscObject *)&fe);
27: if (*ierr) return;
28: *ierr = PetscFEGetDimension(fe, &Nb);
29: if (*ierr) return;
30: *ierr = PetscFEGetNumComponents(fe, &Nc);
31: if (*ierr) return;
32: *ierr = PetscFEGetQuadrature(fe, &q);
33: if (*ierr) return;
34: *ierr = PetscQuadratureGetData(q, NULL, NULL, &Nq, NULL, NULL);
35: if (*ierr) return;
36: *ierr = PetscDSGetTabulation(*prob, &T);
37: if (*ierr) return;
38: *ierr = F90Array1dCreate((void *)T[*f]->T[0], MPIU_REAL, 1, Nq * Nb * Nc, ptrB PETSC_F90_2PTR_PARAM(ptrb));
39: if (*ierr) return;
40: *ierr = F90Array1dCreate((void *)T[*f]->T[1], MPIU_REAL, 1, Nq * Nb * Nc * dim, ptrD PETSC_F90_2PTR_PARAM(ptrd));
41: }
43: PETSC_EXTERN void petscdsrestoretabulation_(PetscDS *prob, PetscInt *f, F90Array1d *ptrB, F90Array1d *ptrD, PetscErrorCode *ierr PETSC_F90_2PTR_PROTO(ptrb) PETSC_F90_2PTR_PROTO(ptrd))
44: {
45: *ierr = F90Array1dDestroy(ptrB, MPIU_REAL PETSC_F90_2PTR_PARAM(ptrb));
46: if (*ierr) return;
47: *ierr = F90Array1dDestroy(ptrD, MPIU_REAL PETSC_F90_2PTR_PARAM(ptrd));
48: }