Actual source code: dmfieldds.c
petsc-3.10.5 2019-03-28
Report Typos and Errors

      1:  #include <petsc/private/dmfieldimpl.h>
      2:  #include <petsc/private/petscfeimpl.h>
      3:  #include <petscfe.h>
      4:  #include <petscdmplex.h>
      5:  #include <petscds.h>

      7: typedef struct _n_DMField_DS
      8: {
      9:   PetscInt    fieldNum;
     10:   Vec         vec;
     11:   PetscInt    height;
     12:   PetscObject *disc;
     13:   PetscBool   multifieldVec;
     14: }
     15: DMField_DS;

     17: static PetscErrorCode DMFieldDestroy_DS(DMField field)
     18: {
     19:   DMField_DS     *dsfield;
     20:   PetscInt       i;

     24:   dsfield = (DMField_DS *) field->data;
     25:   VecDestroy(&dsfield->vec);
     26:   for (i = 0; i < dsfield->height; i++) {
     27:     PetscObjectDereference(dsfield->disc[i]);
     28:   }
     29:   PetscFree(dsfield->disc);
     30:   PetscFree(dsfield);
     31:   return(0);
     32: }

     34: static PetscErrorCode DMFieldView_DS(DMField field,PetscViewer viewer)
     35: {
     36:   DMField_DS     *dsfield = (DMField_DS *) field->data;
     37:   PetscBool      iascii;
     38:   PetscObject    disc;

     42:   PetscObjectTypeCompare((PetscObject)viewer,PETSCVIEWERASCII,&iascii);
     43:   disc = dsfield->disc[0];
     44:   if (iascii) {
     45:     PetscViewerASCIIPrintf(viewer, "PetscDS field %D\n",dsfield->fieldNum);
     46:     PetscViewerASCIIPushTab(viewer);
     47:     PetscObjectView(disc,viewer);
     48:     PetscViewerASCIIPopTab(viewer);
     49:   }
     50:   PetscViewerASCIIPushTab(viewer);
     51:   if (dsfield->multifieldVec) {
     52:     SETERRQ(PetscObjectComm((PetscObject)field),PETSC_ERR_SUP,"View of subfield not implemented yet");
     53:   } else {
     54:     VecView(dsfield->vec,viewer);
     55:   }
     56:   PetscViewerASCIIPopTab(viewer);
     57:   return(0);
     58: }

     60: static PetscErrorCode DMFieldDSGetHeightDisc(DMField field, PetscInt height, PetscObject *disc)
     61: {
     62:   DMField_DS     *dsfield = (DMField_DS *) field->data;

     66:   if (!dsfield->disc[height]) {
     67:     PetscClassId   id;

     69:     PetscObjectGetClassId(dsfield->disc[0],&id);
     70:     if (id == PETSCFE_CLASSID) {
     71:       PetscFE fe = (PetscFE) dsfield->disc[0];

     73:       PetscFECreateHeightTrace(fe,height,(PetscFE *)&dsfield->disc[height]);
     74:     }
     75:   }
     76:   *disc = dsfield->disc[height];
     77:   return(0);
     78: }

     80: #define DMFieldDSdot(y,A,b,m,n,c,cast)                                           \
     81:   do {                                                                           \
     82:     PetscInt _i, _j, _k;                                                         \
     83:     for (_i = 0; _i < (m); _i++) {                                               \
     84:       for (_k = 0; _k < (c); _k++) {                                             \
     85:         (y)[_i * (c) + _k] = 0.;                                                 \
     86:       }                                                                          \
     87:       for (_j = 0; _j < (n); _j++) {                                             \
     88:         for (_k = 0; _k < (c); _k++) {                                           \
     89:           (y)[_i * (c) + _k] += (A)[(_i * (n) + _j) * (c) + _k] * cast((b)[_j]); \
     90:         }                                                                        \
     91:       }                                                                          \
     92:     }                                                                            \
     93:   } while (0)

     95: static PetscErrorCode DMFieldEvaluateFE_DS(DMField field, IS pointIS, PetscQuadrature quad, PetscDataType type, void *B, void *D, void *H)
     96: {
     97:   DMField_DS      *dsfield = (DMField_DS *) field->data;
     98:   DM              dm;
     99:   PetscObject     disc;
    100:   PetscClassId    classid;
    101:   PetscInt        nq, nc, dim, meshDim, numCells;
    102:   PetscSection    section;
    103:   const PetscReal *qpoints;
    104:   PetscBool       isStride;
    105:   const PetscInt  *points = NULL;
    106:   PetscInt        sfirst = -1, stride = -1;
    107:   PetscErrorCode  ierr;

    110:   dm   = field->dm;
    111:   nc   = field->numComponents;
    112:   PetscQuadratureGetData(quad,&dim,NULL,&nq,&qpoints,NULL);
    113:   DMFieldDSGetHeightDisc(field,dsfield->height - 1 - dim,&disc);
    114:   DMGetDimension(dm,&meshDim);
    115:   DMGetDefaultSection(dm,&section);
    116:   PetscSectionGetField(section,dsfield->fieldNum,&section);
    117:   PetscObjectGetClassId(disc,&classid);
    118:   /* TODO: batch */
    119:   PetscObjectTypeCompare((PetscObject)pointIS,ISSTRIDE,&isStride);
    120:   ISGetLocalSize(pointIS,&numCells);
    121:   if (isStride) {
    122:     ISStrideGetInfo(pointIS,&sfirst,&stride);
    123:   } else {
    124:     ISGetIndices(pointIS,&points);
    125:   }
    126:   if (classid == PETSCFE_CLASSID) {
    127:     PetscFE      fe = (PetscFE) disc;
    128:     PetscInt     feDim, i;
    129:     PetscReal    *fB = NULL, *fD = NULL, *fH = NULL;

    131:     PetscFEGetDimension(fe,&feDim);
    132:     PetscFEGetTabulation(fe,nq,qpoints,B ? &fB : NULL,D ? &fD : NULL,H ? &fH : NULL);
    133:     for (i = 0; i < numCells; i++) {
    134:       PetscInt     c = isStride ? (sfirst + i * stride) : points[i];
    135:       PetscInt     closureSize;
    136:       PetscScalar *elem = NULL;

    138:       DMPlexVecGetClosure(dm,section,dsfield->vec,c,&closureSize,&elem);
    139:       if (B) {
    140:         if (type == PETSC_SCALAR) {
    141:           PetscScalar *cB = &((PetscScalar *) B)[nc * nq * i];

    143:           DMFieldDSdot(cB,fB,elem,nq,feDim,nc,(PetscScalar));
    144:         } else {
    145:           PetscReal *cB = &((PetscReal *) B)[nc * nq * i];

    147:           DMFieldDSdot(cB,fB,elem,nq,feDim,nc,PetscRealPart);
    148:         }
    149:       }
    150:       if (D) {
    151:         if (type == PETSC_SCALAR) {
    152:           PetscScalar *cD = &((PetscScalar *) D)[nc * nq * dim * i];

    154:           DMFieldDSdot(cD,fD,elem,nq,feDim,(nc * dim),(PetscScalar));
    155:         } else {
    156:           PetscReal *cD = &((PetscReal *) D)[nc * nq * dim * i];

    158:           DMFieldDSdot(cD,fD,elem,nq,feDim,(nc * dim),PetscRealPart);
    159:         }
    160:       }
    161:       if (H) {
    162:         if (type == PETSC_SCALAR) {
    163:           PetscScalar *cH = &((PetscScalar *) H)[nc * nq * dim * dim * i];

    165:           DMFieldDSdot(cH,fH,elem,nq,feDim,(nc * dim * dim),(PetscScalar));
    166:         } else {
    167:           PetscReal *cH = &((PetscReal *) H)[nc * nq * dim * dim * i];

    169:           DMFieldDSdot(cH,fH,elem,nq,feDim,(nc * dim * dim),PetscRealPart);
    170:         }
    171:       }
    172:       DMPlexVecRestoreClosure(dm,section,dsfield->vec,c,&closureSize,&elem);
    173:     }
    174:     PetscFERestoreTabulation(fe,nq,qpoints,B ? &fB : NULL,D ? &fD : NULL,H ? &fH : NULL);
    175:   } else {SETERRQ(PetscObjectComm((PetscObject)field),PETSC_ERR_SUP,"Not implemented");}
    176:   if (!isStride) {
    177:     ISRestoreIndices(pointIS,&points);
    178:   }
    179:   PetscSectionDestroy(&section);
    180:   return(0);
    181: }

    183: static PetscErrorCode DMFieldEvaluate_DS(DMField field, Vec points, PetscDataType datatype, void *B, void *D, void *H)
    184: {
    185:   DMField_DS        *dsfield = (DMField_DS *) field->data;
    186:   PetscSF            cellSF = NULL;
    187:   const PetscSFNode *cells;
    188:   PetscInt           c, nFound, numCells, feDim, nc;
    189:   const PetscInt    *cellDegrees;
    190:   const PetscScalar *pointsArray;
    191:   PetscScalar       *cellPoints;
    192:   PetscInt           gatherSize, gatherMax;
    193:   PetscInt           dim, dimR, offset;
    194:   MPI_Datatype       pointType;
    195:   PetscObject        cellDisc;
    196:   PetscFE            cellFE;
    197:   PetscClassId       discID;
    198:   PetscReal         *coordsReal, *coordsRef;
    199:   PetscSection       section;
    200:   PetscScalar       *cellBs = NULL, *cellDs = NULL, *cellHs = NULL;
    201:   PetscReal         *cellBr = NULL, *cellDr = NULL, *cellHr = NULL;
    202:   PetscReal         *v, *J, *invJ, *detJ;
    203:   PetscErrorCode     ierr;

    206:   nc   = field->numComponents;
    207:   DMGetDefaultSection(field->dm,&section);
    208:   DMFieldDSGetHeightDisc(field,0,&cellDisc);
    209:   PetscObjectGetClassId(cellDisc, &discID);
    210:   if (discID != PETSCFE_CLASSID) SETERRQ(PETSC_COMM_SELF,PETSC_ERR_PLIB, "Discretization type not supported\n");
    211:   cellFE = (PetscFE) cellDisc;
    212:   PetscFEGetDimension(cellFE,&feDim);
    213:   DMGetCoordinateDim(field->dm, &dim);
    214:   DMGetDimension(field->dm, &dimR);
    215:   DMLocatePoints(field->dm, points, DM_POINTLOCATION_NONE, &cellSF);
    216:   PetscSFGetGraph(cellSF, &numCells, &nFound, NULL, &cells);
    217:   for (c = 0; c < nFound; c++) {
    218:     if (cells[c].index < 0) SETERRQ1(PetscObjectComm((PetscObject)points),PETSC_ERR_ARG_WRONG, "Point %D could not be located\n", c);
    219:   }
    220:   PetscSFComputeDegreeBegin(cellSF,&cellDegrees);
    221:   PetscSFComputeDegreeEnd(cellSF,&cellDegrees);
    222:   for (c = 0, gatherSize = 0, gatherMax = 0; c < numCells; c++) {
    223:     gatherMax = PetscMax(gatherMax,cellDegrees[c]);
    224:     gatherSize += cellDegrees[c];
    225:   }
    226:   PetscMalloc3(gatherSize*dim,&cellPoints,gatherMax*dim,&coordsReal,gatherMax*dimR,&coordsRef);
    227:   PetscMalloc4(gatherMax*dimR,&v,gatherMax*dimR*dimR,&J,gatherMax*dimR*dimR,&invJ,gatherMax,&detJ);
    228:   if (datatype == PETSC_SCALAR) {
    229:     PetscMalloc3(B ? nc * gatherSize : 0, &cellBs, D ? nc * dim * gatherSize : 0, &cellDs, H ? nc * dim * dim * gatherSize : 0, &cellHs);
    230:   } else {
    231:     PetscMalloc3(B ? nc * gatherSize : 0, &cellBr, D ? nc * dim * gatherSize : 0, &cellDr, H ? nc * dim * dim * gatherSize : 0, &cellHr);
    232:   }

    234:   MPI_Type_contiguous(dim,MPIU_SCALAR,&pointType);
    235:   MPI_Type_commit(&pointType);
    236:   VecGetArrayRead(points,&pointsArray);
    237:   PetscSFGatherBegin(cellSF, pointType, pointsArray, cellPoints);
    238:   PetscSFGatherEnd(cellSF, pointType, pointsArray, cellPoints);
    239:   VecRestoreArrayRead(points,&pointsArray);
    240:   for (c = 0, offset = 0; c < numCells; c++) {
    241:     PetscInt nq = cellDegrees[c], p;

    243:     if (nq) {
    244:       PetscReal *fB, *fD, *fH;
    245:       PetscInt     closureSize;
    246:       PetscScalar *elem = NULL;
    247:       PetscReal   *quadPoints;
    248:       PetscQuadrature quad;
    249:       PetscInt d, e, f, g;

    251:       for (p = 0; p < dim * nq; p++) coordsReal[p] = PetscRealPart(cellPoints[dim * offset + p]);
    252:       DMPlexCoordinatesToReference(field->dm, c, nq, coordsReal, coordsRef);
    253:       PetscFEGetTabulation(cellFE,nq,coordsRef,B ? &fB : NULL,D ? &fD : NULL,H ? &fH : NULL);
    254:       PetscQuadratureCreate(PETSC_COMM_SELF, &quad);
    255:       PetscMalloc1(dimR * nq, &quadPoints);
    256:       for (p = 0; p < dimR * nq; p++) quadPoints[p] = coordsRef[p];
    257:       PetscQuadratureSetData(quad, dimR, 0, nq, quadPoints, NULL);
    258:       DMPlexComputeCellGeometryFEM(field->dm, c, quad, v, J, invJ, detJ);
    259:       PetscQuadratureDestroy(&quad);
    260:       DMPlexVecGetClosure(field->dm,section,dsfield->vec,c,&closureSize,&elem);
    261:       if (B) {
    262:         if (datatype == PETSC_SCALAR) {
    263:           PetscScalar *cB = &cellBs[nc * offset];

    265:           DMFieldDSdot(cB,fB,elem,nq,feDim,nc,(PetscScalar));
    266:         } else {
    267:           PetscReal *cB = &cellBr[nc * offset];

    269:           DMFieldDSdot(cB,fB,elem,nq,feDim,nc,PetscRealPart);
    270:         }
    271:       }
    272:       if (D) {
    273:         if (datatype == PETSC_SCALAR) {
    274:           PetscScalar *cD = &cellDs[nc * dim * offset];

    276:           DMFieldDSdot(cD,fD,elem,nq,feDim,(nc * dim),(PetscScalar));
    277:           for (p = 0; p < nq; p++) {
    278:             for (g = 0; g < nc; g++) {
    279:               PetscScalar vs[3];

    281:               for (d = 0; d < dimR; d++) {
    282:                 vs[d] = 0.;
    283:                 for (e = 0; e < dimR; e++) {
    284:                   vs[d] += invJ[dimR * dimR * p + e * dimR + d] * cD[(nc * p + g) * dimR + e];
    285:                 }
    286:               }
    287:               for (d = 0; d < dimR; d++) {
    288:                 cD[(nc * p + g) * dimR + d] = vs[d];
    289:               }
    290:             }
    291:           }
    292:         } else {
    293:           PetscReal *cD = &cellDr[nc * dim * offset];

    295:           DMFieldDSdot(cD,fD,elem,nq,feDim,(nc * dim),PetscRealPart);
    296:           for (p = 0; p < nq; p++) {
    297:             for (g = 0; g < nc; g++) {
    298:               for (d = 0; d < dimR; d++) {
    299:                 v[d] = 0.;
    300:                 for (e = 0; e < dimR; e++) {
    301:                   v[d] += invJ[dimR * dimR * p + e * dimR + d] * cD[(nc * p + g) * dimR + e];
    302:                 }
    303:               }
    304:               for (d = 0; d < dimR; d++) {
    305:                 cD[(nc * p + g) * dimR + d] = v[d];
    306:               }
    307:             }
    308:           }
    309:         }
    310:       }
    311:       if (H) {
    312:         if (datatype == PETSC_SCALAR) {
    313:           PetscScalar *cH = &cellHs[nc * dim * dim * offset];

    315:           DMFieldDSdot(cH,fH,elem,nq,feDim,(nc * dim * dim),(PetscScalar));
    316:           for (p = 0; p < nq; p++) {
    317:             for (g = 0; g < nc * dimR; g++) {
    318:               PetscScalar vs[3];

    320:               for (d = 0; d < dimR; d++) {
    321:                 vs[d] = 0.;
    322:                 for (e = 0; e < dimR; e++) {
    323:                   vs[d] += invJ[dimR * dimR * p + e * dimR + d] * cH[(nc * dimR * p + g) * dimR + e];
    324:                 }
    325:               }
    326:               for (d = 0; d < dimR; d++) {
    327:                 cH[(nc * dimR * p + g) * dimR + d] = vs[d];
    328:               }
    329:             }
    330:             for (g = 0; g < nc; g++) {
    331:               for (f = 0; f < dimR; f++) {
    332:                 PetscScalar vs[3];

    334:                 for (d = 0; d < dimR; d++) {
    335:                   vs[d] = 0.;
    336:                   for (e = 0; e < dimR; e++) {
    337:                     vs[d] += invJ[dimR * dimR * p + e * dimR + d] * cH[((nc * p + g) * dimR + e) * dimR + f];
    338:                   }
    339:                 }
    340:                 for (d = 0; d < dimR; d++) {
    341:                   cH[((nc * p + g) * dimR + d) * dimR + f] = vs[d];
    342:                 }
    343:               }
    344:             }
    345:           }
    346:         } else {
    347:           PetscReal *cH = &cellHr[nc * dim * dim * offset];

    349:           DMFieldDSdot(cH,fH,elem,nq,feDim,(nc * dim * dim),PetscRealPart);
    350:           for (p = 0; p < nq; p++) {
    351:             for (g = 0; g < nc * dimR; g++) {
    352:               for (d = 0; d < dimR; d++) {
    353:                 v[d] = 0.;
    354:                 for (e = 0; e < dimR; e++) {
    355:                   v[d] += invJ[dimR * dimR * p + e * dimR + d] * cH[(nc * dimR * p + g) * dimR + e];
    356:                 }
    357:               }
    358:               for (d = 0; d < dimR; d++) {
    359:                 cH[(nc * dimR * p + g) * dimR + d] = v[d];
    360:               }
    361:             }
    362:             for (g = 0; g < nc; g++) {
    363:               for (f = 0; f < dimR; f++) {
    364:                 for (d = 0; d < dimR; d++) {
    365:                   v[d] = 0.;
    366:                   for (e = 0; e < dimR; e++) {
    367:                     v[d] += invJ[dimR * dimR * p + e * dimR + d] * cH[((nc * p + g) * dimR + e) * dimR + f];
    368:                   }
    369:                 }
    370:                 for (d = 0; d < dimR; d++) {
    371:                   cH[((nc * p + g) * dimR + d) * dimR + f] = v[d];
    372:                 }
    373:               }
    374:             }
    375:           }
    376:         }
    377:       }
    378:       DMPlexVecRestoreClosure(field->dm,section,dsfield->vec,c,&closureSize,&elem);
    379:       PetscFERestoreTabulation(cellFE,nq,coordsRef,B ? &fB : NULL,D ? &fD : NULL,H ? &fH : NULL);
    380:     }
    381:     offset += nq;
    382:   }
    383:   {
    384:     MPI_Datatype origtype;

    386:     if (datatype == PETSC_SCALAR) {
    387:       origtype = MPIU_SCALAR;
    388:     } else {
    389:       origtype = MPIU_REAL;
    390:     }
    391:     if (B) {
    392:       MPI_Datatype Btype;

    394:       MPI_Type_contiguous(nc, origtype, &Btype);
    395:       MPI_Type_commit(&Btype);
    396:       PetscSFScatterBegin(cellSF,Btype,(datatype == PETSC_SCALAR) ? (void *) cellBs : (void *) cellBr, B);
    397:       PetscSFScatterEnd(cellSF,Btype,(datatype == PETSC_SCALAR) ? (void *) cellBs : (void *) cellBr, B);
    398:       MPI_Type_free(&Btype);
    399:     }
    400:     if (D) {
    401:       MPI_Datatype Dtype;

    403:       MPI_Type_contiguous(nc * dim, origtype, &Dtype);
    404:       MPI_Type_commit(&Dtype);
    405:       PetscSFScatterBegin(cellSF,Dtype,(datatype == PETSC_SCALAR) ? (void *) cellDs : (void *) cellDr, D);
    406:       PetscSFScatterEnd(cellSF,Dtype,(datatype == PETSC_SCALAR) ? (void *) cellDs : (void *) cellDr, D);
    407:       MPI_Type_free(&Dtype);
    408:     }
    409:     if (H) {
    410:       MPI_Datatype Htype;

    412:       MPI_Type_contiguous(nc * dim * dim, origtype, &Htype);
    413:       MPI_Type_commit(&Htype);
    414:       PetscSFScatterBegin(cellSF,Htype,(datatype == PETSC_SCALAR) ? (void *) cellHs : (void *) cellHr, H);
    415:       PetscSFScatterEnd(cellSF,Htype,(datatype == PETSC_SCALAR) ? (void *) cellHs : (void *) cellHr, H);
    416:       MPI_Type_free(&Htype);
    417:     }
    418:   }
    419:   PetscFree4(v,J,invJ,detJ);
    420:   PetscFree3(cellBr, cellDr, cellHr);
    421:   PetscFree3(cellBs, cellDs, cellHs);
    422:   PetscFree3(cellPoints,coordsReal,coordsRef);
    423:   MPI_Type_free(&pointType);
    424:   PetscSFDestroy(&cellSF);
    425:   return(0);
    426: }

    428: static PetscErrorCode DMFieldEvaluateFV_DS(DMField field, IS pointIS, PetscDataType type, void *B, void *D, void *H)
    429: {
    430:   DMField_DS      *dsfield = (DMField_DS *) field->data;
    431:   PetscInt         h, imin;
    432:   PetscInt         dim;
    433:   PetscClassId     id;
    434:   PetscQuadrature  quad = NULL;
    435:   PetscInt         maxDegree;
    436:   PetscFEGeom      *geom;
    437:   PetscInt         Nq, Nc, dimC, qNc, N;
    438:   PetscInt         numPoints;
    439:   void            *qB = NULL, *qD = NULL, *qH = NULL;
    440:   const PetscReal *weights;
    441:   MPI_Datatype     mpitype = type == PETSC_SCALAR ? MPIU_SCALAR : MPIU_REAL;
    442:   PetscObject      disc;
    443:   DMField          coordField;
    444:   PetscErrorCode   ierr;

    447:   Nc = field->numComponents;
    448:   DMGetCoordinateDim(field->dm, &dimC);
    449:   DMGetDimension(field->dm, &dim);
    450:   ISGetLocalSize(pointIS, &numPoints);
    451:   ISGetMinMax(pointIS,&imin,NULL);
    452:   for (h = 0; h < dsfield->height; h++) {
    453:     PetscInt hEnd;

    455:     DMPlexGetHeightStratum(field->dm,h,NULL,&hEnd);
    456:     if (imin < hEnd) break;
    457:   }
    458:   dim -= h;
    459:   DMFieldDSGetHeightDisc(field,h,&disc);
    460:   PetscObjectGetClassId(disc,&id);
    461:   if (id != PETSCFE_CLASSID) SETERRQ(PETSC_COMM_SELF, PETSC_ERR_PLIB, "Discretization not supported\n");
    462:   DMGetCoordinateField(field->dm, &coordField);
    463:   DMFieldGetDegree(coordField, pointIS, NULL, &maxDegree);
    464:   if (maxDegree <= 1) {
    465:     DMFieldCreateDefaultQuadrature(coordField, pointIS, &quad);
    466:   }
    467:   if (!quad) {DMFieldCreateDefaultQuadrature(field, pointIS, &quad);}
    468:   if (!quad) SETERRQ(PETSC_COMM_SELF, PETSC_ERR_PLIB, "Could not determine quadrature for cell averages\n");
    469:   DMFieldCreateFEGeom(coordField,pointIS,quad,PETSC_FALSE,&geom);
    470:   PetscQuadratureGetData(quad, NULL, &qNc, &Nq, NULL, &weights);
    471:   if (qNc != 1) SETERRQ(PETSC_COMM_SELF, PETSC_ERR_PLIB, "Expected scalar quadrature components\n");
    472:   N = numPoints * Nq * Nc;
    473:   if (B) DMGetWorkArray(field->dm, N, mpitype, &qB);
    474:   if (D) DMGetWorkArray(field->dm, N * dimC, mpitype, &qD);
    475:   if (H) DMGetWorkArray(field->dm, N * dimC * dimC, mpitype, &qH);
    476:   DMFieldEvaluateFE(field,pointIS,quad,type,qB,qD,qH);
    477:   if (B) {
    478:     PetscInt i, j, k;

    480:     if (type == PETSC_SCALAR) {
    481:       PetscScalar * sB  = (PetscScalar *) B;
    482:       PetscScalar * sqB = (PetscScalar *) qB;

    484:       for (i = 0; i < numPoints; i++) {
    485:         PetscReal vol = 0.;

    487:         for (j = 0; j < Nc; j++) {sB[i * Nc + j] = 0.;}
    488:         for (k = 0; k < Nq; k++) {
    489:           vol += geom->detJ[i * Nq + k] * weights[k];
    490:           for (j = 0; j < Nc; j++) {
    491:             sB[i * Nc + j] += geom->detJ[i * Nq + k] * weights[k] * sqB[ (i * Nq + k) * Nc + j];
    492:           }
    493:         }
    494:         for (k = 0; k < Nq * Nc; k++) sB[i * Nq * Nc + k] /= vol;
    495:       }
    496:     } else {
    497:       PetscReal * rB  = (PetscReal *) B;
    498:       PetscReal * rqB = (PetscReal *) qB;

    500:       for (i = 0; i < numPoints; i++) {
    501:         PetscReal vol = 0.;

    503:         for (j = 0; j < Nc; j++) {rB[i * Nc + j] = 0.;}
    504:         for (k = 0; k < Nq; k++) {
    505:           vol += geom->detJ[i * Nq + k] * weights[k];
    506:           for (j = 0; j < Nc; j++) {
    507:             rB[i * Nc + j] += weights[k] * rqB[ (i * Nq + k) * Nc + j];
    508:           }
    509:         }
    510:         for (k = 0; k < Nc; k++) rB[i * Nc + k] /= vol;
    511:       }
    512:     }
    513:   }
    514:   if (D) {
    515:     PetscInt i, j, k, l, m;

    517:     if (type == PETSC_SCALAR) {
    518:       PetscScalar * sD  = (PetscScalar *) D;
    519:       PetscScalar * sqD = (PetscScalar *) qD;

    521:       for (i = 0; i < numPoints; i++) {
    522:         PetscReal vol = 0.;

    524:         for (j = 0; j < Nc * dimC; j++) {sD[i * Nc * dimC + j] = 0.;}
    525:         for (k = 0; k < Nq; k++) {
    526:           vol += geom->detJ[i * Nq + k] * weights[k];
    527:           for (j = 0; j < Nc; j++) {
    528:             PetscScalar pD[3] = {0.,0.,0.};

    530:             for (l = 0; l < dimC; l++) {
    531:               for (m = 0; m < dim; m++) {
    532:                 pD[l] += geom->invJ[((i * Nq + k) * dimC + m) * dimC + l] * sqD[((i * Nq + k) * Nc + j) * dim + m];
    533:               }
    534:             }
    535:             for (l = 0; l < dimC; l++) {
    536:               sD[(i * Nc + j) * dimC + l] += geom->detJ[i * Nq + k] * weights[k] * pD[l];
    537:             }
    538:           }
    539:         }
    540:         for (k = 0; k < Nc * dimC; k++) sD[i * Nc * dimC + k] /= vol;
    541:       }
    542:     } else {
    543:       PetscReal * rD  = (PetscReal *) D;
    544:       PetscReal * rqD = (PetscReal *) qD;

    546:       for (i = 0; i < numPoints; i++) {
    547:         PetscReal vol = 0.;

    549:         for (j = 0; j < Nc * dimC; j++) {rD[i * Nc * dimC + j] = 0.;}
    550:         for (k = 0; k < Nq; k++) {
    551:           vol += geom->detJ[i * Nq + k] * weights[k];
    552:           for (j = 0; j < Nc; j++) {
    553:             PetscReal pD[3] = {0.,0.,0.};

    555:             for (l = 0; l < dimC; l++) {
    556:               for (m = 0; m < dim; m++) {
    557:                 pD[l] += geom->invJ[((i * Nq + k) * dimC + m) * dimC + l] * rqD[((i * Nq + k) * Nc + j) * dim + m];
    558:               }
    559:             }
    560:             for (l = 0; l < dimC; l++) {
    561:               rD[(i * Nc + j) * dimC + l] += geom->detJ[i * Nq + k] * weights[k] * pD[l];
    562:             }
    563:           }
    564:         }
    565:         for (k = 0; k < Nc * dimC; k++) rD[i * Nc * dimC + k] /= vol;
    566:       }
    567:     }
    568:   }
    569:   if (H) {
    570:     PetscInt i, j, k, l, m, q, r;

    572:     if (type == PETSC_SCALAR) {
    573:       PetscScalar * sH  = (PetscScalar *) H;
    574:       PetscScalar * sqH = (PetscScalar *) qH;

    576:       for (i = 0; i < numPoints; i++) {
    577:         PetscReal vol = 0.;

    579:         for (j = 0; j < Nc * dimC * dimC; j++) {sH[i * Nc * dimC * dimC + j] = 0.;}
    580:         for (k = 0; k < Nq; k++) {
    581:           const PetscReal *invJ = &geom->invJ[(i * Nq + k) * dimC * dimC];

    583:           vol += geom->detJ[i * Nq + k] * weights[k];
    584:           for (j = 0; j < Nc; j++) {
    585:             PetscScalar pH[3][3] = {{0.,0.,0.},{0.,0.,0.},{0.,0.,0.}};
    586:             const PetscScalar *spH = &sqH[((i * Nq + k) * Nc + j) * dimC * dimC];

    588:             for (l = 0; l < dimC; l++) {
    589:               for (m = 0; m < dimC; m++) {
    590:                 for (q = 0; q < dim; q++) {
    591:                   for (r = 0; r < dim; r++) {
    592:                     pH[l][m] += invJ[q * dimC + l] * invJ[r * dimC + m] * spH[q * dim + r];
    593:                   }
    594:                 }
    595:               }
    596:             }
    597:             for (l = 0; l < dimC; l++) {
    598:               for (m = 0; m < dimC; m++) {
    599:                 sH[(i * Nc + j) * dimC * dimC + l * dimC + m] += geom->detJ[i * Nq + k] * weights[k] * pH[l][m];
    600:               }
    601:             }
    602:           }
    603:         }
    604:         for (k = 0; k < Nc * dimC * dimC; k++) sH[i * Nc * dimC * dimC + k] /= vol;
    605:       }
    606:     } else {
    607:       PetscReal * rH  = (PetscReal *) H;
    608:       PetscReal * rqH = (PetscReal *) qH;

    610:       for (i = 0; i < numPoints; i++) {
    611:         PetscReal vol = 0.;

    613:         for (j = 0; j < Nc * dimC * dimC; j++) {rH[i * Nc * dimC * dimC + j] = 0.;}
    614:         for (k = 0; k < Nq; k++) {
    615:           const PetscReal *invJ = &geom->invJ[(i * Nq + k) * dimC * dimC];

    617:           vol += geom->detJ[i * Nq + k] * weights[k];
    618:           for (j = 0; j < Nc; j++) {
    619:             PetscReal pH[3][3] = {{0.,0.,0.},{0.,0.,0.},{0.,0.,0.}};
    620:             const PetscReal *rpH = &rqH[((i * Nq + k) * Nc + j) * dimC * dimC];

    622:             for (l = 0; l < dimC; l++) {
    623:               for (m = 0; m < dimC; m++) {
    624:                 for (q = 0; q < dim; q++) {
    625:                   for (r = 0; r < dim; r++) {
    626:                     pH[l][m] += invJ[q * dimC + l] * invJ[r * dimC + m] * rpH[q * dim + r];
    627:                   }
    628:                 }
    629:               }
    630:             }
    631:             for (l = 0; l < dimC; l++) {
    632:               for (m = 0; m < dimC; m++) {
    633:                 rH[(i * Nc + j) * dimC * dimC + l * dimC + m] += geom->detJ[i * Nq + k] * weights[k] * pH[l][m];
    634:               }
    635:             }
    636:           }
    637:         }
    638:         for (k = 0; k < Nc * dimC * dimC; k++) rH[i * Nc * dimC * dimC + k] /= vol;
    639:       }
    640:     }
    641:   }
    642:   if (B) DMRestoreWorkArray(field->dm, N, mpitype, &qB);
    643:   if (D) DMRestoreWorkArray(field->dm, N * dimC, mpitype, &qD);
    644:   if (H) DMRestoreWorkArray(field->dm, N * dimC * dimC, mpitype, &qH);
    645:   PetscFEGeomDestroy(&geom);
    646:   PetscQuadratureDestroy(&quad);
    647:   return(0);
    648: }

    650: static PetscErrorCode DMFieldGetDegree_DS(DMField field, IS pointIS, PetscInt *minDegree, PetscInt *maxDegree)
    651: {
    652:   DMField_DS     *dsfield;
    653:   PetscObject    disc;
    654:   PetscInt       h, imin, imax;
    655:   PetscClassId   id;

    659:   dsfield = (DMField_DS *) field->data;
    660:   ISGetMinMax(pointIS,&imin,&imax);
    661:   if (imin >= imax) {
    662:     h = 0;
    663:   } else {
    664:     for (h = 0; h < dsfield->height; h++) {
    665:       PetscInt hEnd;

    667:       DMPlexGetHeightStratum(field->dm,h,NULL,&hEnd);
    668:       if (imin < hEnd) break;
    669:     }
    670:   }
    671:   DMFieldDSGetHeightDisc(field,h,&disc);
    672:   PetscObjectGetClassId(disc,&id);
    673:   if (id == PETSCFE_CLASSID) {
    674:     PetscFE    fe = (PetscFE) disc;
    675:     PetscSpace sp;

    677:     PetscFEGetBasisSpace(fe, &sp);
    678:     PetscSpaceGetDegree(sp, minDegree, maxDegree);
    679:   }
    680:   return(0);
    681: }

    683: static PetscErrorCode DMFieldCreateDefaultQuadrature_DS(DMField field, IS pointIS, PetscQuadrature *quad)
    684: {
    685:   PetscInt       h, dim, imax, imin, cellHeight;
    686:   DM             dm;
    687:   DMField_DS     *dsfield;
    688:   PetscObject    disc;
    689:   PetscFE        fe;
    690:   PetscClassId   id;

    695:   dm = field->dm;
    696:   dsfield = (DMField_DS *) field->data;
    697:   ISGetMinMax(pointIS,&imin,&imax);
    698:   DMGetDimension(dm,&dim);
    699:   for (h = 0; h <= dim; h++) {
    700:     PetscInt hStart, hEnd;

    702:     DMPlexGetHeightStratum(dm,h,&hStart,&hEnd);
    703:     if (imax >= hStart && imin < hEnd) break;
    704:   }
    705:   DMPlexGetVTKCellHeight(dm, &cellHeight);
    706:   h -= cellHeight;
    707:   *quad = NULL;
    708:   if (h < dsfield->height) {
    709:     DMFieldDSGetHeightDisc(field,h,&disc);
    710:     PetscObjectGetClassId(disc,&id);
    711:     if (id != PETSCFE_CLASSID) return(0);
    712:     fe = (PetscFE) disc;
    713:     PetscFEGetQuadrature(fe,quad);
    714:     PetscObjectReference((PetscObject)*quad);
    715:   }
    716:   return(0);
    717: }

    719: static PetscErrorCode DMFieldComputeFaceData_DS(DMField field, IS pointIS, PetscQuadrature quad, PetscFEGeom *geom)
    720: {
    721:   const PetscInt *points;
    722:   PetscInt        p, dim, dE, numFaces, Nq;
    723:   PetscInt        maxDegree;
    724:   DMLabel         depthLabel;
    725:   IS              cellIS;
    726:   DM              dm = field->dm;
    727:   PetscErrorCode  ierr;

    730:   dim = geom->dim;
    731:   dE  = geom->dimEmbed;
    732:   DMPlexGetDepthLabel(dm, &depthLabel);
    733:   DMLabelGetStratumIS(depthLabel, dim + 1, &cellIS);
    734:   DMFieldGetDegree(field,cellIS,NULL,&maxDegree);
    735:   ISGetIndices(pointIS, &points);
    736:   numFaces = geom->numCells;
    737:   Nq = geom->numPoints;
    738:   if (maxDegree <= 1) {
    739:     PetscInt        numCells, offset, *cells;
    740:     PetscFEGeom     *cellGeom;
    741:     IS              suppIS;
    742:     PetscQuadrature cellQuad = NULL;

    744:     DMFieldCreateDefaultQuadrature(field,cellIS,&cellQuad);
    745:     for (p = 0, numCells = 0; p < numFaces; p++) {
    746:       PetscInt        point = points[p];
    747:       PetscInt        numSupp, numChildren;

    749:       DMPlexGetTreeChildren(dm, point, &numChildren, NULL);
    750:       if (numChildren) SETERRQ(PETSC_COMM_SELF, PETSC_ERR_PLIB, "Face data not valid for facets with children");
    751:       DMPlexGetSupportSize(dm, point,&numSupp);
    752:       if (numSupp > 2) SETERRQ2(PETSC_COMM_SELF, PETSC_ERR_PLIB, "Point %D has %D support, expected at most 2\n", point, numSupp);
    753:       numCells += numSupp;
    754:     }
    755:     PetscMalloc1(numCells, &cells);
    756:     for (p = 0, offset = 0; p < numFaces; p++) {
    757:       PetscInt        point = points[p];
    758:       PetscInt        numSupp, s;
    759:       const PetscInt *supp;

    761:       DMPlexGetSupportSize(dm, point,&numSupp);
    762:       DMPlexGetSupport(dm, point, &supp);
    763:       for (s = 0; s < numSupp; s++, offset++) {
    764:         cells[offset] = supp[s];
    765:       }
    766:     }
    767:     ISCreateGeneral(PETSC_COMM_SELF,numCells,cells,PETSC_USE_POINTER, &suppIS);
    768:     DMFieldCreateFEGeom(field,suppIS,cellQuad,PETSC_FALSE,&cellGeom);
    769:     for (p = 0, offset = 0; p < numFaces; p++) {
    770:       PetscInt        point = points[p];
    771:       PetscInt        numSupp, s, q;
    772:       const PetscInt *supp;

    774:       DMPlexGetSupportSize(dm, point,&numSupp);
    775:       DMPlexGetSupport(dm, point, &supp);
    776:       for (s = 0; s < numSupp; s++, offset++) {
    777:         for (q = 0; q < Nq * dE * dE; q++) {
    778:           geom->suppInvJ[s][p * Nq * dE * dE + q] = cellGeom->invJ[offset * Nq * dE * dE + q];
    779:         }
    780:       }
    781:     }
    782:     PetscFEGeomDestroy(&cellGeom);
    783:     ISDestroy(&suppIS);
    784:     PetscFree(cells);
    785:     PetscQuadratureDestroy(&cellQuad);
    786:   } else {
    787:     PetscObject          faceDisc, cellDisc;
    788:     PetscClassId         faceId, cellId;
    789:     PetscDualSpace       dsp;
    790:     DM                   K;
    791:     PetscInt           (*co)[2][3];
    792:     PetscInt             coneSize;
    793:     PetscInt           **counts;
    794:     PetscInt             f, i, o, q, s;
    795:     const PetscInt      *coneK;
    796:     PetscInt             minOrient, maxOrient, numOrient;
    797:     PetscInt            *orients;
    798:     PetscReal          **orientPoints;
    799:     PetscReal           *cellPoints;
    800:     PetscReal           *dummyWeights;
    801:     PetscQuadrature      cellQuad = NULL;

    803:     DMFieldDSGetHeightDisc(field, 1, &faceDisc);
    804:     DMFieldDSGetHeightDisc(field, 0, &cellDisc);
    805:     PetscObjectGetClassId(faceDisc,&faceId);
    806:     PetscObjectGetClassId(cellDisc,&cellId);
    807:     if (faceId != PETSCFE_CLASSID || cellId != PETSCFE_CLASSID) SETERRQ(PETSC_COMM_SELF, PETSC_ERR_PLIB, "Not supported\n");
    808:     PetscFEGetDualSpace((PetscFE)cellDisc, &dsp);
    809:     PetscDualSpaceGetDM(dsp, &K);
    810:     DMPlexGetConeSize(K,0,&coneSize);
    811:     DMPlexGetCone(K,0,&coneK);
    812:     PetscMalloc2(numFaces, &co, coneSize, &counts);
    813:     PetscMalloc1(dE*Nq, &cellPoints);
    814:     PetscMalloc1(Nq, &dummyWeights);
    815:     PetscQuadratureCreate(PetscObjectComm((PetscObject)field), &cellQuad);
    816:     PetscQuadratureSetData(cellQuad, dE, 1, Nq, cellPoints, dummyWeights);
    817:     minOrient = PETSC_MAX_INT;
    818:     maxOrient = PETSC_MIN_INT;
    819:     for (p = 0; p < numFaces; p++) { /* record the orientation of the facet wrt the support cells */
    820:       PetscInt        point = points[p];
    821:       PetscInt        numSupp, numChildren;
    822:       const PetscInt *supp;

    824:       DMPlexGetTreeChildren(dm, point, &numChildren, NULL);
    825:       if (numChildren) SETERRQ(PETSC_COMM_SELF, PETSC_ERR_PLIB, "Face data not valid for facets with children");
    826:       DMPlexGetSupportSize(dm, point,&numSupp);
    827:       if (numSupp > 2) SETERRQ2(PETSC_COMM_SELF, PETSC_ERR_PLIB, "Point %D has %D support, expected at most 2\n", point, numSupp);
    828:       DMPlexGetSupport(dm, point, &supp);
    829:       for (s = 0; s < numSupp; s++) {
    830:         PetscInt        cell = supp[s];
    831:         PetscInt        numCone;
    832:         const PetscInt *cone, *orient;

    834:         DMPlexGetConeSize(dm, cell, &numCone);
    835:         if (numCone != coneSize) SETERRQ(PETSC_COMM_SELF, PETSC_ERR_PLIB, "Support point does not match reference element");
    836:         DMPlexGetCone(dm, cell, &cone);
    837:         DMPlexGetConeOrientation(dm, cell, &orient);
    838:         for (f = 0; f < coneSize; f++) {
    839:           if (cone[f] == point) break;
    840:         }
    841:         co[p][s][0] = f;
    842:         co[p][s][1] = orient[f];
    843:         co[p][s][2] = cell;
    844:         minOrient = PetscMin(minOrient, orient[f]);
    845:         maxOrient = PetscMax(maxOrient, orient[f]);
    846:       }
    847:       for (; s < 2; s++) {
    848:         co[p][s][0] = -1;
    849:         co[p][s][1] = -1;
    850:         co[p][s][2] = -1;
    851:       }
    852:     }
    853:     numOrient = maxOrient + 1 - minOrient;
    854:     DMPlexGetCone(K,0,&coneK);
    855:     /* count all (face,orientation) doubles that appear */
    856:     PetscCalloc2(numOrient,&orients,numOrient,&orientPoints);
    857:     for (f = 0; f < coneSize; f++) {PetscCalloc1(numOrient+1, &counts[f]);}
    858:     for (p = 0; p < numFaces; p++) {
    859:       for (s = 0; s < 2; s++) {
    860:         if (co[p][s][0] >= 0) {
    861:           counts[co[p][s][0]][co[p][s][1] - minOrient]++;
    862:           orients[co[p][s][1] - minOrient]++;
    863:         }
    864:       }
    865:     }
    866:     for (o = 0; o < numOrient; o++) {
    867:       if (orients[o]) {
    868:         PetscInt orient = o + minOrient;
    869:         PetscInt q;

    871:         PetscMalloc1(Nq * dim, &orientPoints[o]);
    872:         /* rotate the quadrature points appropriately */
    873:         switch (dim) {
    874:         case 0:
    875:           break;
    876:         case 1:
    877:           if (orient == -2 || orient == 1) {
    878:             for (q = 0; q < Nq; q++) {
    879:               orientPoints[o][q] = -geom->xi[q];
    880:             }
    881:           } else {
    882:             for (q = 0; q < Nq; q++) {
    883:               orientPoints[o][q] = geom->xi[q];
    884:             }
    885:           }
    886:           break;
    887:         case 2:
    888:           switch (coneSize) {
    889:           case 3:
    890:             for (q = 0; q < Nq; q++) {
    891:               PetscReal lambda[3];
    892:               PetscReal lambdao[3];

    894:               /* convert to barycentric */
    895:               lambda[0] = - (geom->xi[2 * q] + geom->xi[2 * q + 1]) / 2.;
    896:               lambda[1] = (geom->xi[2 * q] + 1.) / 2.;
    897:               lambda[2] = (geom->xi[2 * q + 1] + 1.) / 2.;
    898:               if (orient >= 0) {
    899:                 for (i = 0; i < 3; i++) {
    900:                   lambdao[i] = lambda[(orient + i) % 3];
    901:                 }
    902:               } else {
    903:                 for (i = 0; i < 3; i++) {
    904:                   lambdao[i] = lambda[(-(orient + i) + 3) % 3];
    905:                 }
    906:               }
    907:               /* convert to coordinates */
    908:               orientPoints[o][2 * q + 0] = -(lambdao[0] + lambdao[2]) + lambdao[1];
    909:               orientPoints[o][2 * q + 1] = -(lambdao[0] + lambdao[1]) + lambdao[2];
    910:             }
    911:             break;
    912:           case 4:
    913:             for (q = 0; q < Nq; q++) {
    914:               PetscReal xi[2], xio[2];
    915:               PetscInt oabs = (orient >= 0) ? orient : -(orient + 1);

    917:               xi[0] = geom->xi[2 * q];
    918:               xi[1] = geom->xi[2 * q + 1];
    919:               switch (oabs) {
    920:               case 1:
    921:                 xio[0] = xi[1];
    922:                 xio[1] = -xi[0];
    923:                 break;
    924:               case 2:
    925:                 xio[0] = -xi[0];
    926:                 xio[1] = -xi[1];
    927:               case 3:
    928:                 xio[0] = -xi[1];
    929:                 xio[1] = xi[0];
    930:               case 0:
    931:               default:
    932:                 xio[0] = xi[0];
    933:                 xio[1] = xi[1];
    934:                 break;
    935:               }
    936:               if (orient < 0) {
    937:                 xio[0] = -xio[0];
    938:               }
    939:               orientPoints[o][2 * q + 0] = xio[0];
    940:               orientPoints[o][2 * q + 1] = xio[1];
    941:             }
    942:             break;
    943:           default:
    944:             SETERRQ(PETSC_COMM_SELF,PETSC_ERR_PLIB,"Not implemented yet\n");
    945:           }
    946:         default:
    947:           SETERRQ(PETSC_COMM_SELF,PETSC_ERR_PLIB,"Not implemented yet\n");
    948:         }
    949:       }
    950:     }
    951:     for (f = 0; f < coneSize; f++) {
    952:       PetscInt face = coneK[f];
    953:       PetscReal v0[3];
    954:       PetscReal J[9], detJ;
    955:       PetscInt numCells, offset;
    956:       PetscInt *cells;
    957:       IS suppIS;

    959:       DMPlexComputeCellGeometryFEM(K, face, NULL, v0, J, NULL, &detJ);
    960:       for (o = 0; o <= numOrient; o++) {
    961:         PetscFEGeom *cellGeom;

    963:         if (!counts[f][o]) continue;
    964:         /* If this (face,orientation) double appears,
    965:          * convert the face quadrature points into volume quadrature points */
    966:         for (q = 0; q < Nq; q++) {
    967:           PetscReal xi0[3] = {-1., -1., -1.};

    969:           CoordinatesRefToReal(dE, dim, xi0, v0, J, &orientPoints[o][dim * q + 0], &cellPoints[dE * q + 0]);
    970:         }
    971:         for (p = 0, numCells = 0; p < numFaces; p++) {
    972:           for (s = 0; s < 2; s++) {
    973:             if (co[p][s][0] == f && co[p][s][1] == o + minOrient) numCells++;
    974:           }
    975:         }
    976:         PetscMalloc1(numCells, &cells);
    977:         for (p = 0, offset = 0; p < numFaces; p++) {
    978:           for (s = 0; s < 2; s++) {
    979:             if (co[p][s][0] == f && co[p][s][1] == o + minOrient) {
    980:               cells[offset++] = co[p][s][2];
    981:             }
    982:           }
    983:         }
    984:         ISCreateGeneral(PETSC_COMM_SELF,numCells,cells,PETSC_USE_POINTER, &suppIS);
    985:         DMFieldCreateFEGeom(field,suppIS,cellQuad,PETSC_FALSE,&cellGeom);
    986:         for (p = 0, offset = 0; p < numFaces; p++) {
    987:           for (s = 0; s < 2; s++) {
    988:             if (co[p][s][0] == f && co[p][s][1] == o + minOrient) {
    989:               for (q = 0; q < Nq * dE * dE; q++) {
    990:                 geom->suppInvJ[s][p * Nq * dE * dE + q] = cellGeom->invJ[offset * Nq * dE * dE + q];
    991:               }
    992:               offset++;
    993:             }
    994:           }
    995:         }
    996:         PetscFEGeomDestroy(&cellGeom);
    997:         ISDestroy(&suppIS);
    998:         PetscFree(cells);
    999:       }
    1000:     }
    1001:     for (o = 0; o < numOrient; o++) {
    1002:       if (orients[o]) {
    1003:         PetscFree(orientPoints[o]);
    1004:       }
    1005:     }
    1006:     PetscFree2(orients,orientPoints);
    1007:     PetscQuadratureDestroy(&cellQuad);
    1008:     PetscFree2(co,counts);
    1009:   }
    1010:   ISRestoreIndices(pointIS, &points);
    1011:   ISDestroy(&cellIS);
    1012:   return(0);
    1013: }

    1015: static PetscErrorCode DMFieldInitialize_DS(DMField field)
    1016: {
    1018:   field->ops->destroy                 = DMFieldDestroy_DS;
    1019:   field->ops->evaluate                = DMFieldEvaluate_DS;
    1020:   field->ops->evaluateFE              = DMFieldEvaluateFE_DS;
    1021:   field->ops->evaluateFV              = DMFieldEvaluateFV_DS;
    1022:   field->ops->getDegree               = DMFieldGetDegree_DS;
    1023:   field->ops->createDefaultQuadrature = DMFieldCreateDefaultQuadrature_DS;
    1024:   field->ops->view                    = DMFieldView_DS;
    1025:   field->ops->computeFaceData         = DMFieldComputeFaceData_DS;
    1026:   return(0);
    1027: }

    1029: PETSC_INTERN PetscErrorCode DMFieldCreate_DS(DMField field)
    1030: {
    1031:   DMField_DS     *dsfield;

    1035:   PetscNewLog(field,&dsfield);
    1036:   field->data = dsfield;
    1037:   DMFieldInitialize_DS(field);
    1038:   return(0);
    1039: }

    1041: PetscErrorCode DMFieldCreateDS(DM dm, PetscInt fieldNum, Vec vec,DMField *field)
    1042: {
    1043:   DMField        b;
    1044:   DMField_DS     *dsfield;
    1045:   PetscObject    disc = NULL;
    1046:   PetscBool      isContainer = PETSC_FALSE;
    1047:   PetscClassId   id = -1;
    1048:   PetscInt       numComponents = -1, dsNumFields;
    1049:   PetscSection   section;

    1053:   DMGetDefaultSection(dm,&section);
    1054:   PetscSectionGetFieldComponents(section,fieldNum,&numComponents);
    1055:   DMGetNumFields(dm,&dsNumFields);
    1056:   if (dsNumFields) {DMGetField(dm,fieldNum,&disc);}
    1057:   if (disc) {
    1058:     PetscObjectGetClassId(disc,&id);
    1059:     isContainer = (id == PETSC_CONTAINER_CLASSID) ? PETSC_TRUE : PETSC_FALSE;
    1060:   }
    1061:   if (!disc || isContainer) {
    1062:     MPI_Comm        comm = PetscObjectComm((PetscObject) dm);
    1063:     PetscInt        cStart, cEnd, dim, cellHeight;
    1064:     PetscInt        localConeSize = 0, coneSize;
    1065:     PetscFE         fe;
    1066:     PetscDualSpace  Q;
    1067:     PetscSpace      P;
    1068:     DM              K;
    1069:     PetscQuadrature quad, fquad;
    1070:     PetscBool       isSimplex;

    1072:     DMPlexGetVTKCellHeight(dm, &cellHeight);
    1073:     DMPlexGetHeightStratum(dm, cellHeight, &cStart, &cEnd);
    1074:     DMGetDimension(dm, &dim);
    1075:     if (cEnd > cStart) {
    1076:       DMPlexGetConeSize(dm, cStart, &localConeSize);
    1077:     }
    1078:     MPI_Allreduce(&localConeSize,&coneSize,1,MPIU_INT,MPI_MAX,comm);
    1079:     isSimplex = (coneSize == (dim + 1)) ? PETSC_TRUE : PETSC_FALSE;
    1080:     PetscSpaceCreate(comm, &P);
    1081:     PetscSpaceSetType(P,PETSCSPACEPOLYNOMIAL);
    1082:     PetscSpaceSetDegree(P, 1, PETSC_DETERMINE);
    1083:     PetscSpaceSetNumComponents(P, numComponents);
    1084:     PetscSpaceSetNumVariables(P, dim);
    1085:     PetscSpacePolynomialSetTensor(P, isSimplex ? PETSC_FALSE : PETSC_TRUE);
    1086:     PetscSpaceSetUp(P);
    1087:     PetscDualSpaceCreate(comm, &Q);
    1088:     PetscDualSpaceSetType(Q,PETSCDUALSPACELAGRANGE);
    1089:     PetscDualSpaceCreateReferenceCell(Q, dim, isSimplex, &K);
    1090:     PetscDualSpaceSetDM(Q, K);
    1091:     DMDestroy(&K);
    1092:     PetscDualSpaceSetNumComponents(Q, numComponents);
    1093:     PetscDualSpaceSetOrder(Q, 1);
    1094:     PetscDualSpaceLagrangeSetTensor(Q, isSimplex ? PETSC_FALSE : PETSC_TRUE);
    1095:     PetscDualSpaceSetUp(Q);
    1096:     PetscFECreate(comm, &fe);
    1097:     PetscFESetType(fe,PETSCFEBASIC);
    1098:     PetscFESetBasisSpace(fe, P);
    1099:     PetscFESetDualSpace(fe, Q);
    1100:     PetscFESetNumComponents(fe, numComponents);
    1101:     PetscFESetUp(fe);
    1102:     PetscSpaceDestroy(&P);
    1103:     PetscDualSpaceDestroy(&Q);
    1104:     if (isSimplex) {
    1105:       PetscDTGaussJacobiQuadrature(dim,   1, 1, -1.0, 1.0, &quad);
    1106:       PetscDTGaussJacobiQuadrature(dim-1, 1, 1, -1.0, 1.0, &fquad);
    1107:     }
    1108:     else {
    1109:       PetscDTGaussTensorQuadrature(dim,   1, 1, -1.0, 1.0, &quad);
    1110:       PetscDTGaussTensorQuadrature(dim-1, 1, 1, -1.0, 1.0, &fquad);
    1111:     }
    1112:     PetscFESetQuadrature(fe, quad);
    1113:     PetscFESetFaceQuadrature(fe, fquad);
    1114:     PetscQuadratureDestroy(&quad);
    1115:     PetscQuadratureDestroy(&fquad);
    1116:     disc = (PetscObject) fe;
    1117:   } else {
    1118:     PetscObjectReference(disc);
    1119:   }
    1120:   PetscObjectGetClassId(disc,&id);
    1121:   if (id == PETSCFE_CLASSID) {
    1122:     PetscFE fe = (PetscFE) disc;

    1124:     PetscFEGetNumComponents(fe,&numComponents);
    1125:   } else {SETERRQ(PetscObjectComm((PetscObject)dm),PETSC_ERR_SUP,"Not implemented");}
    1126:   DMFieldCreate(dm,numComponents,DMFIELD_VERTEX,&b);
    1127:   DMFieldSetType(b,DMFIELDDS);
    1128:   dsfield = (DMField_DS *) b->data;
    1129:   dsfield->fieldNum = fieldNum;
    1130:   DMGetDimension(dm,&dsfield->height);
    1131:   dsfield->height++;
    1132:   PetscCalloc1(dsfield->height,&dsfield->disc);
    1133:   dsfield->disc[0] = disc;
    1134:   PetscObjectReference((PetscObject)vec);
    1135:   dsfield->vec = vec;
    1136:   *field = b;

    1138:   return(0);
    1139: }