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: }