1 #include <petsc/private/ftnimpl.h> 2 #include <petscds.h> 3 4 #if defined(PETSC_HAVE_FORTRAN_CAPS) 5 #define petscdsgettabulationsetsizes_ PETSCDSGETTABULATIONSETSIZES 6 #define petscdsgettabulationsetpointers_ PETSCDSGETTABULATIONSETPOINTERS 7 #define f90arraysetrealpointer_ F90ARRAYSETREALPOINTER 8 #elif !defined(PETSC_HAVE_FORTRAN_UNDERSCORE) 9 #define petscdsgettabulationsetsizes_ petscdsgettabulationsetsizes 10 #define petscdsgettabulationsetpointers_ petscdsgettabulationsetpointers 11 #define f90arraysetrealpointer_ f90arraysetrealpointer 12 #endif 13 14 PETSC_EXTERN void f90arraysetrealpointer_(const PetscReal *, PetscInt *, PetscInt *, F90Array1d *PETSC_F90_2PTR_PROTO_NOVAR); 15 16 typedef struct { 17 PetscInt K; 18 PetscInt Nr; 19 PetscInt Np; 20 PetscInt Nb; 21 PetscInt Nc; 22 PetscInt cdim; 23 } PetscTabulationFtn; 24 25 PETSC_EXTERN void petscdsgettabulationsetsizes_(PetscDS *ds, PetscInt *i, PetscTabulationFtn *tftn, PetscErrorCode *ierr) 26 { 27 PetscTabulation *tab; 28 29 *ierr = PetscDSGetTabulation(*ds, &tab); 30 if (*ierr) return; 31 *ierr = PetscMemcpy(tftn, tab[*i - 1], sizeof(PetscTabulationFtn)); 32 } 33 34 PETSC_EXTERN void petscdsgettabulationsetpointers_(PetscDS *ds, PetscInt *i, F90Array1d *ptrB, PetscErrorCode *ierr PETSC_F90_2PTR_PROTO(ptrb)) 35 { 36 PetscTabulation *tab; 37 PetscInt size; 38 39 *ierr = PetscDSGetTabulation(*ds, &tab); 40 if (*ierr) return; 41 size = tab[*i - 1]->Nr * tab[*i - 1]->Np * tab[*i - 1]->Nb * tab[*i - 1]->Nc; 42 43 for (PetscInt j = 0; j <= tab[*i - 1]->K; j++) { 44 f90arraysetrealpointer_(tab[*i - 1]->T[j], &size, &j, ptrB PETSC_F90_2PTR_PARAM(ptrb)); 45 if (*ierr) return; 46 size *= tab[*i - 1]->cdim; 47 } 48 } 49