PetscErrorCode DMDAComputeCellGeometryFEM(DM dm, PetscInt cell, PetscQuadrature quad, PetscReal v0[], PetscReal J[], PetscReal invJ[], PetscReal detJ[])
{
DM cdm;
Vec coordinates;
const PetscReal *quadPoints;
PetscScalar *vertices = NULL;
PetscInt numQuadPoints, csize, dim, d, q;
PetscErrorCode ierr;
PetscFunctionBegin;
PetscValidHeaderSpecific(dm, DM_CLASSID, 1);
ierr = DMDAGetInfo(dm, &dim, 0,0,0,0,0,0,0,0,0,0,0,0);CHKERRQ(ierr);
ierr = DMGetCoordinatesLocal(dm, &coordinates);CHKERRQ(ierr);
ierr = DMGetCoordinateDM(dm, &cdm);CHKERRQ(ierr);
ierr = DMDAVecGetClosure(cdm, NULL, coordinates, cell, &csize, &vertices);CHKERRQ(ierr);
for (d = 0; d < dim; ++d) v0[d] = PetscRealPart(vertices[d]);
switch (dim) {
case 2:
ierr = PetscQuadratureGetData(quad, NULL, &numQuadPoints, &quadPoints, NULL);CHKERRQ(ierr);
for (q = 0; q < numQuadPoints; ++q) {
ierr = DMDAComputeCellGeometry_2D(dm, vertices, &quadPoints[q*dim], J, invJ, detJ);CHKERRQ(ierr);
}
break;
default:
SETERRQ1(PetscObjectComm((PetscObject) dm), PETSC_ERR_SUP, "Dimension %d not supported", dim);
}
ierr = DMDAVecRestoreClosure(cdm, NULL, coordinates, cell, &csize, &vertices);CHKERRQ(ierr);
PetscFunctionReturn(0);
}
PetscErrorCode PetscFEGeomCreate(PetscQuadrature quad, PetscInt numCells, PetscInt dimEmbed, PetscBool faceData, PetscFEGeom **geom)
{
PetscFEGeom *g;
PetscInt dim, Nq, N;
const PetscReal *p;
PetscErrorCode ierr;
PetscFunctionBegin;
ierr = PetscQuadratureGetData(quad,&dim,NULL,&Nq,&p,NULL);CHKERRQ(ierr);
ierr = PetscNew(&g);CHKERRQ(ierr);
g->xi = p;
g->numCells = numCells;
g->numPoints = Nq;
g->dim = dim;
g->dimEmbed = dimEmbed;
N = numCells * Nq;
ierr = PetscCalloc3(N * dimEmbed, &g->v, N * dimEmbed * dimEmbed, &g->J, N, &g->detJ);CHKERRQ(ierr);
if (faceData) {
ierr = PetscCalloc4(numCells, &g->face, N * dimEmbed, &g->n, N * dimEmbed * dimEmbed, &(g->suppInvJ[0]), N * dimEmbed * dimEmbed, &(g->suppInvJ[1]));CHKERRQ(ierr);
}
ierr = PetscCalloc1(N * dimEmbed * dimEmbed, &g->invJ);CHKERRQ(ierr);
*geom = g;
PetscFunctionReturn(0);
}
#if defined(PETSC_HAVE_FORTRAN_CAPS)
#define petscquadraturegetdata_ PETSCQUADRATUREGETDATA
#define petscquadraturerestoredata_ PETSCQUADRATURERESTOREDATA
#define petscquadraturesetdata_ PETSCQUADRATURESETDATA
#elif !defined(PETSC_HAVE_FORTRAN_UNDERSCORE)
#define petscquadraturegetdata_ petscquadraturegetdata
#define petscquadraturerestoredata_ petscquadraturerestoredata
#define petscquadraturesetdata_ petscquadraturesetdata
#endif
PETSC_EXTERN void PETSC_STDCALL petscquadraturegetdata_(PetscQuadrature *q, PetscInt *dim, PetscInt *npoints, F90Array1d *ptrP, F90Array1d *ptrW, PetscErrorCode *ierr PETSC_F90_2PTR_PROTO(ptrp) PETSC_F90_2PTR_PROTO(ptrw))
{
const PetscReal *points, *weights;
*ierr = PetscQuadratureGetData(*q, dim, npoints, &points, &weights);if (*ierr) return;
*ierr = F90Array1dCreate((void *) points, PETSC_REAL, 1, (*npoints)*(*dim), ptrP PETSC_F90_2PTR_PARAM(ptrp));if (*ierr) return;
*ierr = F90Array1dCreate((void *) weights, PETSC_REAL, 1, *npoints, ptrW PETSC_F90_2PTR_PARAM(ptrw));
}
PETSC_EXTERN void PETSC_STDCALL petscquadraturerestoredata_(PetscQuadrature *q, PetscInt *dim, PetscInt *npoints, F90Array1d *ptrP, F90Array1d *ptrW, PetscErrorCode *ierr PETSC_F90_2PTR_PROTO(ptrp) PETSC_F90_2PTR_PROTO(ptrw))
{
*ierr = F90Array1dDestroy(ptrP, PETSC_REAL PETSC_F90_2PTR_PARAM(ptrp));if (*ierr) return;
*ierr = F90Array1dDestroy(ptrW, PETSC_REAL PETSC_F90_2PTR_PARAM(ptrw));
}
PETSC_EXTERN void PETSC_STDCALL petscquadraturesetdata_(PetscQuadrature *q, PetscInt *dim, PetscInt *npoints, F90Array1d *ptrP, F90Array1d *ptrW, PetscErrorCode *ierr PETSC_F90_2PTR_PROTO(ptrp) PETSC_F90_2PTR_PROTO(ptrw))
{
PetscReal *points, *weights;
*ierr = F90Array1dAccess(ptrP, PETSC_REAL, (void **) &points PETSC_F90_2PTR_PARAM(ptrp));if (*ierr) return;
PetscErrorCode PetscFESetUp_Composite(PetscFE fem)
{
PetscFE_Composite *cmp = (PetscFE_Composite *) fem->data;
DM K;
PetscReal *subpoint;
PetscBLASInt *pivots;
PetscBLASInt n, info;
PetscScalar *work, *invVscalar;
PetscInt dim, pdim, spdim, j, s;
PetscErrorCode ierr;
PetscFunctionBegin;
/* Get affine mapping from reference cell to each subcell */
ierr = PetscDualSpaceGetDM(fem->dualSpace, &K);CHKERRQ(ierr);
ierr = DMGetDimension(K, &dim);CHKERRQ(ierr);
ierr = DMPlexGetCellRefiner_Internal(K, &cmp->cellRefiner);CHKERRQ(ierr);
ierr = CellRefinerGetAffineTransforms_Internal(cmp->cellRefiner, &cmp->numSubelements, &cmp->v0, &cmp->jac, &cmp->invjac);CHKERRQ(ierr);
/* Determine dof embedding into subelements */
ierr = PetscDualSpaceGetDimension(fem->dualSpace, &pdim);CHKERRQ(ierr);
ierr = PetscSpaceGetDimension(fem->basisSpace, &spdim);CHKERRQ(ierr);
ierr = PetscMalloc1(cmp->numSubelements*spdim,&cmp->embedding);CHKERRQ(ierr);
ierr = DMGetWorkArray(K, dim, MPIU_REAL, &subpoint);CHKERRQ(ierr);
for (s = 0; s < cmp->numSubelements; ++s) {
PetscInt sd = 0;
for (j = 0; j < pdim; ++j) {
PetscBool inside;
PetscQuadrature f;
PetscInt d, e;
ierr = PetscDualSpaceGetFunctional(fem->dualSpace, j, &f);CHKERRQ(ierr);
/* Apply transform to first point, and check that point is inside subcell */
for (d = 0; d < dim; ++d) {
subpoint[d] = -1.0;
for (e = 0; e < dim; ++e) subpoint[d] += cmp->invjac[(s*dim + d)*dim+e]*(f->points[e] - cmp->v0[s*dim+e]);
}
ierr = CellRefinerInCellTest_Internal(cmp->cellRefiner, subpoint, &inside);CHKERRQ(ierr);
if (inside) {cmp->embedding[s*spdim+sd++] = j;}
}
if (sd != spdim) SETERRQ3(PetscObjectComm((PetscObject) fem), PETSC_ERR_PLIB, "Subelement %d has %d dual basis vectors != %d", s, sd, spdim);
}
ierr = DMRestoreWorkArray(K, dim, MPIU_REAL, &subpoint);CHKERRQ(ierr);
/* Construct the change of basis from prime basis to nodal basis for each subelement */
ierr = PetscMalloc1(cmp->numSubelements*spdim*spdim,&fem->invV);CHKERRQ(ierr);
ierr = PetscMalloc2(spdim,&pivots,spdim,&work);CHKERRQ(ierr);
#if defined(PETSC_USE_COMPLEX)
ierr = PetscMalloc1(cmp->numSubelements*spdim*spdim,&invVscalar);CHKERRQ(ierr);
#else
invVscalar = fem->invV;
#endif
for (s = 0; s < cmp->numSubelements; ++s) {
for (j = 0; j < spdim; ++j) {
PetscReal *Bf;
PetscQuadrature f;
const PetscReal *points, *weights;
PetscInt Nc, Nq, q, k;
ierr = PetscDualSpaceGetFunctional(fem->dualSpace, cmp->embedding[s*spdim+j], &f);CHKERRQ(ierr);
ierr = PetscQuadratureGetData(f, NULL, &Nc, &Nq, &points, &weights);CHKERRQ(ierr);
ierr = PetscMalloc1(f->numPoints*spdim*Nc,&Bf);CHKERRQ(ierr);
ierr = PetscSpaceEvaluate(fem->basisSpace, Nq, points, Bf, NULL, NULL);CHKERRQ(ierr);
for (k = 0; k < spdim; ++k) {
/* n_j \cdot \phi_k */
invVscalar[(s*spdim + j)*spdim+k] = 0.0;
for (q = 0; q < Nq; ++q) {
invVscalar[(s*spdim + j)*spdim+k] += Bf[q*spdim+k]*weights[q];
}
}
ierr = PetscFree(Bf);CHKERRQ(ierr);
}
n = spdim;
PetscStackCallBLAS("LAPACKgetrf", LAPACKgetrf_(&n, &n, &invVscalar[s*spdim*spdim], &n, pivots, &info));
PetscStackCallBLAS("LAPACKgetri", LAPACKgetri_(&n, &invVscalar[s*spdim*spdim], &n, pivots, work, &n, &info));
}
#if defined(PETSC_USE_COMPLEX)
for (s = 0; s <cmp->numSubelements*spdim*spdim; s++) fem->invV[s] = PetscRealPart(invVscalar[s]);
ierr = PetscFree(invVscalar);CHKERRQ(ierr);
#endif
ierr = PetscFree2(pivots,work);CHKERRQ(ierr);
PetscFunctionReturn(0);
}