PetscErrorCode KSPReset_BCGSL(KSP ksp)
{
KSP_BCGSL *bcgsl = (KSP_BCGSL*)ksp->data;
PetscErrorCode ierr;
PetscFunctionBegin;
ierr = VecDestroyVecs(ksp->nwork,&ksp->work);CHKERRQ(ierr);
ierr = PetscFree5(AY0c,AYlc,AYtc,MZa,MZb);CHKERRQ(ierr);
ierr = PetscFree5(bcgsl->work,bcgsl->s,bcgsl->u,bcgsl->v,bcgsl->realwork);CHKERRQ(ierr);
PetscFunctionReturn(0);
}
EXTERN_C_BEGIN
/*
MatGetOrdering_1WD - Find the 1-way dissection ordering of a given matrix.
*/
#undef __FUNCT__
#define __FUNCT__ "MatGetOrdering_1WD"
PetscErrorCode MatGetOrdering_1WD(Mat mat,MatOrderingType type,IS *row,IS *col)
{
PetscErrorCode ierr;
PetscInt i,*mask,*xls,nblks,*xblk,*ls,nrow,*perm;
const PetscInt *ia,*ja;
PetscBool done;
PetscFunctionBegin;
ierr = MatGetRowIJ(mat,1,PETSC_TRUE,PETSC_TRUE,&nrow,&ia,&ja,&done);CHKERRQ(ierr);
if (!done) SETERRQ(((PetscObject)mat)->comm,PETSC_ERR_SUP,"Cannot get rows for matrix");
ierr = PetscMalloc5(nrow,PetscInt,&mask,nrow+1,PetscInt,&xls,nrow,PetscInt,&ls,nrow+1,PetscInt,&xblk,nrow,PetscInt,&perm);CHKERRQ(ierr);
SPARSEPACKgen1wd(&nrow,ia,ja,mask,&nblks,xblk,perm,xls,ls);
ierr = MatRestoreRowIJ(mat,1,PETSC_TRUE,PETSC_TRUE,&nrow,&ia,&ja,&done);CHKERRQ(ierr);
for (i=0; i<nrow; i++) perm[i]--;
ierr = ISCreateGeneral(PETSC_COMM_SELF,nrow,perm,PETSC_COPY_VALUES,row);CHKERRQ(ierr);
ierr = ISCreateGeneral(PETSC_COMM_SELF,nrow,perm,PETSC_COPY_VALUES,col);CHKERRQ(ierr);
ierr = PetscFree5(mask,xls,ls,xblk,perm);CHKERRQ(ierr);
PetscFunctionReturn(0);
}
PetscErrorCode KSPReset_GMRES(KSP ksp)
{
KSP_GMRES *gmres = (KSP_GMRES*)ksp->data;
PetscErrorCode ierr;
PetscInt i;
PetscFunctionBegin;
/* Free the Hessenberg matrices */
ierr = PetscFree5(gmres->hh_origin,gmres->hes_origin,gmres->rs_origin,gmres->cc_origin,gmres->ss_origin);CHKERRQ(ierr);
/* free work vectors */
ierr = PetscFree(gmres->vecs);CHKERRQ(ierr);
for (i=0; i<gmres->nwork_alloc; i++) {
ierr = VecDestroyVecs(gmres->mwork_alloc[i],&gmres->user_work[i]);CHKERRQ(ierr);
}
gmres->nwork_alloc = 0;
ierr = PetscFree(gmres->user_work);CHKERRQ(ierr);
ierr = PetscFree(gmres->mwork_alloc);CHKERRQ(ierr);
ierr = PetscFree(gmres->nrs);CHKERRQ(ierr);
ierr = VecDestroy(&gmres->sol_temp);CHKERRQ(ierr);
ierr = PetscFree(gmres->Rsvd);CHKERRQ(ierr);
ierr = PetscFree(gmres->Dsvd);CHKERRQ(ierr);
ierr = PetscFree(gmres->orthogwork);CHKERRQ(ierr);
gmres->sol_temp = 0;
gmres->vv_allocated = 0;
gmres->vecs_allocated = 0;
gmres->sol_temp = 0;
PetscFunctionReturn(0);
}
PetscErrorCode KSPDestroy_FCG(KSP ksp)
{
PetscErrorCode ierr;
PetscInt i;
KSP_FCG *fcg = (KSP_FCG*)ksp->data;
PetscFunctionBegin;
/* Destroy "standard" work vecs */
VecDestroyVecs(ksp->nwork,&ksp->work);
/* Destroy P and C vectors and the arrays that manage pointers to them */
if (fcg->nvecs){
for (i=0;i<fcg->nchunks;++i){
ierr = VecDestroyVecs(fcg->chunksizes[i],&fcg->pPvecs[i]);CHKERRQ(ierr);
ierr = VecDestroyVecs(fcg->chunksizes[i],&fcg->pCvecs[i]);CHKERRQ(ierr);
}
}
ierr = PetscFree5(fcg->Pvecs,fcg->Cvecs,fcg->pPvecs,fcg->pCvecs,fcg->chunksizes);CHKERRQ(ierr);
/* free space used for singular value calculations */
if (ksp->calc_sings) {
ierr = PetscFree4(fcg->e,fcg->d,fcg->ee,fcg->dd);CHKERRQ(ierr);
}
ierr = KSPDestroyDefault(ksp);CHKERRQ(ierr);
PetscFunctionReturn(0);
}
PETSC_EXTERN PetscErrorCode MatGetOrdering_QMD(Mat mat,MatOrderingType type,IS *row,IS *col)
{
PetscInt i, *deg,*marker,*rchset,*nbrhd,*qsize,*qlink,nofsub,*iperm,nrow,*perm;
PetscErrorCode ierr;
const PetscInt *ia,*ja;
PetscBool done;
PetscFunctionBegin;
ierr = MatGetRowIJ(mat,1,PETSC_TRUE,PETSC_TRUE,&nrow,&ia,&ja,&done);CHKERRQ(ierr);
if (!done) SETERRQ(PetscObjectComm((PetscObject)mat),PETSC_ERR_SUP,"Cannot get rows for matrix");
ierr = PetscMalloc(nrow * sizeof(PetscInt),&perm);CHKERRQ(ierr);
ierr = PetscMalloc5(nrow,PetscInt,&iperm,nrow,PetscInt,°,nrow,PetscInt,&marker,nrow,PetscInt,&rchset,nrow,PetscInt,&nbrhd);CHKERRQ(ierr);
ierr = PetscMalloc2(nrow,PetscInt,&qsize,nrow,PetscInt,&qlink);CHKERRQ(ierr);
/* WARNING - genqmd trashes ja */
SPARSEPACKgenqmd(&nrow,ia,ja,perm,iperm,deg,marker,rchset,nbrhd,qsize,qlink,&nofsub);
ierr = MatRestoreRowIJ(mat,1,PETSC_TRUE,PETSC_TRUE,&nrow,&ia,&ja,&done);CHKERRQ(ierr);
ierr = PetscFree2(qsize,qlink);CHKERRQ(ierr);
ierr = PetscFree5(iperm,deg,marker,rchset,nbrhd);CHKERRQ(ierr);
for (i=0; i<nrow; i++) perm[i]--;
ierr = ISCreateGeneral(PETSC_COMM_SELF,nrow,perm,PETSC_COPY_VALUES,row);CHKERRQ(ierr);
ierr = ISCreateGeneral(PETSC_COMM_SELF,nrow,perm,PETSC_OWN_POINTER,col);CHKERRQ(ierr);
PetscFunctionReturn(0);
}
PetscErrorCode KSPDestroy_BCGSL(KSP ksp)
{
KSP_BCGSL *bcgsl = (KSP_BCGSL*)ksp->data;
PetscErrorCode ierr;
PetscFunctionBegin;
ierr = PetscFree5(AY0c,AYlc,AYtc,MZa,MZb);
CHKERRQ(ierr);
ierr = KSPDefaultDestroy(ksp);
CHKERRQ(ierr);
PetscFunctionReturn(0);
}
PetscErrorCode PCBDDCSubSchursReset(PCBDDCSubSchurs sub_schurs)
{
PetscInt i;
PetscErrorCode ierr;
PetscFunctionBegin;
for (i=0;i<sub_schurs->n_subs;i++) {
ierr = ISDestroy(&sub_schurs->is_AEj_I[i]);CHKERRQ(ierr);
ierr = ISDestroy(&sub_schurs->is_AEj_B[i]);CHKERRQ(ierr);
ierr = MatDestroy(&sub_schurs->S_Ej[i]);CHKERRQ(ierr);
ierr = VecDestroy(&sub_schurs->work1[i]);CHKERRQ(ierr);
ierr = VecDestroy(&sub_schurs->work2[i]);CHKERRQ(ierr);
}
ierr = PetscFree5(sub_schurs->is_AEj_I,sub_schurs->is_AEj_B,sub_schurs->S_Ej,sub_schurs->work1,sub_schurs->work2);CHKERRQ(ierr);
sub_schurs->n_subs = 0;
PetscFunctionReturn(0);
}
/*@
KSPBCGSLSetXRes - Sets the parameter governing when
exact residuals will be used instead of computed residuals.
Collective on KSP
Input Parameters:
+ ksp - iterative context obtained from KSPCreate
- delta - computed residuals are used alone when delta is not positive
Options Database Keys:
. -ksp_bcgsl_xres delta
Level: intermediate
.keywords: KSP, BiCGStab(L), set, exact residuals
.seealso: KSPBCGSLSetEll(), KSPBCGSLSetPol()
@*/
PetscErrorCode PETSCKSP_DLLEXPORT KSPBCGSLSetXRes(KSP ksp, PetscReal delta)
{
KSP_BCGSL *bcgsl = (KSP_BCGSL *)ksp->data;
PetscErrorCode ierr;
PetscFunctionBegin;
if (ksp->setupcalled) {
if ((delta<=0 && bcgsl->delta>0) || (delta>0 && bcgsl->delta<=0)) {
ierr = KSPDefaultFreeWork(ksp);
CHKERRQ(ierr);
ierr = PetscFree5(AY0c,AYlc,AYtc,MZa,MZb);
CHKERRQ(ierr);
ksp->setupcalled = 0;
}
}
bcgsl->delta = delta;
PetscFunctionReturn(0);
}
/*@
KSPBCGSLSetXRes - Sets the parameter governing when
exact residuals will be used instead of computed residuals.
Logically Collective on KSP
Input Parameters:
+ ksp - iterative context obtained from KSPCreate
- delta - computed residuals are used alone when delta is not positive
Options Database Keys:
. -ksp_bcgsl_xres delta
Level: intermediate
.keywords: KSP, BiCGStab(L), set, exact residuals
.seealso: KSPBCGSLSetEll(), KSPBCGSLSetPol()
@*/
PetscErrorCode KSPBCGSLSetXRes(KSP ksp, PetscReal delta)
{
KSP_BCGSL *bcgsl = (KSP_BCGSL*)ksp->data;
PetscErrorCode ierr;
PetscFunctionBegin;
PetscValidLogicalCollectiveReal(ksp,delta,2);
if (ksp->setupstage) {
if ((delta<=0 && bcgsl->delta>0) || (delta>0 && bcgsl->delta<=0)) {
ierr = VecDestroyVecs(ksp->nwork,&ksp->work);CHKERRQ(ierr);
ierr = PetscFree5(AY0c,AYlc,AYtc,MZa,MZb);CHKERRQ(ierr);
ierr = PetscFree4(bcgsl->work,bcgsl->s,bcgsl->u,bcgsl->v);CHKERRQ(ierr);
ksp->setupstage = KSP_SETUP_NEW;
}
}
bcgsl->delta = delta;
PetscFunctionReturn(0);
}
PetscErrorCode PCBDDCGraphReset(PCBDDCGraph graph)
{
PetscErrorCode ierr;
PetscFunctionBegin;
if (!graph) PetscFunctionReturn(0);
ierr = ISLocalToGlobalMappingDestroy(&graph->l2gmap);CHKERRQ(ierr);
ierr = PetscFree(graph->subset_ncc);CHKERRQ(ierr);
ierr = PetscFree(graph->subset_ref_node);CHKERRQ(ierr);
if (graph->nvtxs) {
ierr = PetscFree(graph->neighbours_set[0]);CHKERRQ(ierr);
}
ierr = PetscBTDestroy(&graph->touched);CHKERRQ(ierr);
ierr = PetscFree5(graph->count,
graph->neighbours_set,
graph->subset,
graph->which_dof,
graph->special_dof);CHKERRQ(ierr);
ierr = PetscFree2(graph->cptr,graph->queue);CHKERRQ(ierr);
if (graph->mirrors) {
ierr = PetscFree(graph->mirrors_set[0]);CHKERRQ(ierr);
}
ierr = PetscFree2(graph->mirrors,graph->mirrors_set);CHKERRQ(ierr);
if (graph->subset_idxs) {
ierr = PetscFree(graph->subset_idxs[0]);CHKERRQ(ierr);
}
ierr = PetscFree2(graph->subset_size,graph->subset_idxs);CHKERRQ(ierr);
ierr = ISDestroy(&graph->dirdofs);CHKERRQ(ierr);
ierr = ISDestroy(&graph->dirdofsB);CHKERRQ(ierr);
if (graph->n_local_subs) {
ierr = PetscFree(graph->local_subs);CHKERRQ(ierr);
}
graph->has_dirichlet = PETSC_FALSE;
graph->twodimset = PETSC_FALSE;
graph->twodim = PETSC_FALSE;
graph->nvtxs = 0;
graph->nvtxs_global = 0;
graph->n_subsets = 0;
graph->custom_minimal_size = 1;
graph->n_local_subs = 0;
graph->maxcount = PETSC_MAX_INT;
graph->setupcalled = PETSC_FALSE;
PetscFunctionReturn(0);
}
static PetscErrorCode PCBDDCScalingReset_Deluxe_Solvers(PCBDDCDeluxeScaling deluxe_ctx)
{
PetscInt i;
PetscErrorCode ierr;
PetscFunctionBegin;
ierr = PetscFree(deluxe_ctx->idx_simple_B);CHKERRQ(ierr);
deluxe_ctx->n_simple = 0;
for (i=0;i<deluxe_ctx->seq_n;i++) {
ierr = VecScatterDestroy(&deluxe_ctx->seq_scctx[i]);CHKERRQ(ierr);
ierr = VecDestroy(&deluxe_ctx->seq_work1[i]);CHKERRQ(ierr);
ierr = VecDestroy(&deluxe_ctx->seq_work2[i]);CHKERRQ(ierr);
ierr = MatDestroy(&deluxe_ctx->seq_mat[i]);CHKERRQ(ierr);
ierr = MatDestroy(&deluxe_ctx->seq_mat_inv_sum[i]);CHKERRQ(ierr);
}
ierr = PetscFree5(deluxe_ctx->seq_scctx,deluxe_ctx->seq_work1,deluxe_ctx->seq_work2,deluxe_ctx->seq_mat,deluxe_ctx->seq_mat_inv_sum);CHKERRQ(ierr);
ierr = PetscFree(deluxe_ctx->workspace);CHKERRQ(ierr);
deluxe_ctx->seq_n = 0;
PetscFunctionReturn(0);
}
/*@
KSPBCGSLSetPol - Sets the type of polynomial part will
be used in the BiCGSTab(L) solver.
Collective on KSP
Input Parameters:
+ ksp - iterative context obtained from KSPCreate
- uMROR - set to PETSC_TRUE when the polynomial is a convex combination of an MR and an OR step.
Options Database Keys:
+ -ksp_bcgsl_cxpoly - use enhanced polynomial
. -ksp_bcgsl_mrpoly - use standard polynomial
Level: intermediate
.keywords: KSP, BiCGStab(L), set, polynomial
.seealso: @()
@*/
PetscErrorCode PETSCKSP_DLLEXPORT KSPBCGSLSetPol(KSP ksp, PetscTruth uMROR)
{
KSP_BCGSL *bcgsl = (KSP_BCGSL *)ksp->data;
PetscErrorCode ierr;
PetscFunctionBegin;
if (!ksp->setupcalled) {
bcgsl->bConvex = uMROR;
} else if (bcgsl->bConvex != uMROR) {
/* free the data structures,
then create them again
*/
ierr = KSPDefaultFreeWork(ksp);
CHKERRQ(ierr);
ierr = PetscFree5(AY0c,AYlc,AYtc,MZa,MZb);
CHKERRQ(ierr);
bcgsl->bConvex = uMROR;
ksp->setupcalled = 0;
}
PetscFunctionReturn(0);
}
/*@
KSPBCGSLSetEll - Sets the number of search directions in BiCGStab(L).
Logically Collective on KSP
Input Parameters:
+ ksp - iterative context obtained from KSPCreate
- ell - number of search directions
Options Database Keys:
. -ksp_bcgsl_ell ell
Level: intermediate
Notes:
For large ell it is common for the polynomial update problem to become singular (due to happy breakdown for smallish
test problems, but also for larger problems). Consequently, by default, the system is solved by pseudoinverse, which
allows the iteration to complete successfully. See KSPBCGSLSetUsePseudoinverse() to switch to a conventional solve.
.keywords: KSP, BiCGStab(L), set, exact residuals,
.seealso: KSPBCGSLSetUsePseudoinverse()
@*/
PetscErrorCode KSPBCGSLSetEll(KSP ksp, PetscInt ell)
{
KSP_BCGSL *bcgsl = (KSP_BCGSL*)ksp->data;
PetscErrorCode ierr;
PetscFunctionBegin;
if (ell < 1) SETERRQ(PetscObjectComm((PetscObject)ksp),PETSC_ERR_ARG_OUTOFRANGE, "KSPBCGSLSetEll: second argument must be positive");
PetscValidLogicalCollectiveInt(ksp,ell,2);
if (!ksp->setupstage) bcgsl->ell = ell;
else if (bcgsl->ell != ell) {
/* free the data structures, then create them again */
ierr = VecDestroyVecs(ksp->nwork,&ksp->work);CHKERRQ(ierr);
ierr = PetscFree5(AY0c,AYlc,AYtc,MZa,MZb);CHKERRQ(ierr);
ierr = PetscFree4(bcgsl->work,bcgsl->s,bcgsl->u,bcgsl->v);CHKERRQ(ierr);
bcgsl->ell = ell;
ksp->setupstage = KSP_SETUP_NEW;
}
PetscFunctionReturn(0);
}
/*@
KSPBCGSLSetEll - Sets the number of search directions in BiCGStab(L).
Collective on KSP
Input Parameters:
+ ksp - iterative context obtained from KSPCreate
- ell - number of search directions
Options Database Keys:
. -ksp_bcgsl_ell ell
Level: intermediate
.keywords: KSP, BiCGStab(L), set, exact residuals,
.seealso: @()
@*/
PetscErrorCode PETSCKSP_DLLEXPORT KSPBCGSLSetEll(KSP ksp, int ell)
{
KSP_BCGSL *bcgsl = (KSP_BCGSL *)ksp->data;
PetscErrorCode ierr;
PetscFunctionBegin;
if (ell < 1) SETERRQ(PETSC_ERR_ARG_OUTOFRANGE, "KSPBCGSLSetEll: second argument must be positive");
if (!ksp->setupcalled) {
bcgsl->ell = ell;
} else if (bcgsl->ell != ell) {
/* free the data structures, then create them again */
ierr = KSPDefaultFreeWork(ksp);
CHKERRQ(ierr);
ierr = PetscFree5(AY0c,AYlc,AYtc,MZa,MZb);
CHKERRQ(ierr);
bcgsl->ell = ell;
ksp->setupcalled = 0;
}
PetscFunctionReturn(0);
}
/*@
KSPBCGSLSetPol - Sets the type of polynomial part will
be used in the BiCGSTab(L) solver.
Logically Collective on KSP
Input Parameters:
+ ksp - iterative context obtained from KSPCreate
- uMROR - set to PETSC_TRUE when the polynomial is a convex combination of an MR and an OR step.
Options Database Keys:
+ -ksp_bcgsl_cxpoly - use enhanced polynomial
. -ksp_bcgsl_mrpoly - use standard polynomial
Level: intermediate
.keywords: KSP, BiCGStab(L), set, polynomial
.seealso: @()
@*/
PetscErrorCode KSPBCGSLSetPol(KSP ksp, PetscBool uMROR)
{
KSP_BCGSL *bcgsl = (KSP_BCGSL*)ksp->data;
PetscErrorCode ierr;
PetscFunctionBegin;
PetscValidLogicalCollectiveBool(ksp,uMROR,2);
if (!ksp->setupstage) bcgsl->bConvex = uMROR;
else if (bcgsl->bConvex != uMROR) {
/* free the data structures,
then create them again
*/
ierr = VecDestroyVecs(ksp->nwork,&ksp->work);CHKERRQ(ierr);
ierr = PetscFree5(AY0c,AYlc,AYtc,MZa,MZb);CHKERRQ(ierr);
ierr = PetscFree4(bcgsl->work,bcgsl->s,bcgsl->u,bcgsl->v);CHKERRQ(ierr);
bcgsl->bConvex = uMROR;
ksp->setupstage = KSP_SETUP_NEW;
}
PetscFunctionReturn(0);
}
/*@C
PetscSFGetMultiSF - gets the inner SF implemeting gathers and scatters
Collective
Input Argument:
. sf - star forest that may contain roots with 0 or with more than 1 vertex
Output Arguments:
. multi - star forest with split roots, such that each root has degree exactly 1
Level: developer
Notes:
In most cases, users should use PetscSFGatherBegin() and PetscSFScatterBegin() instead of manipulating multi
directly. Since multi satisfies the stronger condition that each entry in the global space has exactly one incoming
edge, it is a candidate for future optimization that might involve its removal.
.seealso: PetscSFSetGraph(), PetscSFGatherBegin(), PetscSFScatterBegin()
@*/
PetscErrorCode PetscSFGetMultiSF(PetscSF sf,PetscSF *multi)
{
PetscErrorCode ierr;
PetscFunctionBegin;
PetscValidHeaderSpecific(sf,PETSCSF_CLASSID,1);
PetscValidPointer(multi,2);
if (sf->nroots < 0) { /* Graph has not been set yet; why do we need this? */
ierr = PetscSFDuplicate(sf,PETSCSF_DUPLICATE_RANKS,&sf->multi);CHKERRQ(ierr);
*multi = sf->multi;
PetscFunctionReturn(0);
}
if (!sf->multi) {
const PetscInt *indegree;
PetscInt i,*inoffset,*outones,*outoffset,maxlocal;
PetscSFNode *remote;
ierr = PetscSFComputeDegreeBegin(sf,&indegree);CHKERRQ(ierr);
ierr = PetscSFComputeDegreeEnd(sf,&indegree);CHKERRQ(ierr);
for (i=0,maxlocal=0; i<sf->nleaves; i++) maxlocal = PetscMax(maxlocal,(sf->mine ? sf->mine[i] : i)+1);
ierr = PetscMalloc3(sf->nroots+1,&inoffset,maxlocal,&outones,maxlocal,&outoffset);CHKERRQ(ierr);
inoffset[0] = 0;
for (i=0; i<sf->nroots; i++) inoffset[i+1] = inoffset[i] + indegree[i];
for (i=0; i<maxlocal; i++) outones[i] = 1;
ierr = PetscSFFetchAndOpBegin(sf,MPIU_INT,inoffset,outones,outoffset,MPI_SUM);CHKERRQ(ierr);
ierr = PetscSFFetchAndOpEnd(sf,MPIU_INT,inoffset,outones,outoffset,MPI_SUM);CHKERRQ(ierr);
for (i=0; i<sf->nroots; i++) inoffset[i] -= indegree[i]; /* Undo the increment */
#if 0
#if defined(PETSC_USE_DEBUG) /* Check that the expected number of increments occurred */
for (i=0; i<sf->nroots; i++) {
if (inoffset[i] + indegree[i] != inoffset[i+1]) SETERRQ(PETSC_COMM_SELF,PETSC_ERR_PLIB,"Incorrect result after PetscSFFetchAndOp");
}
#endif
#endif
ierr = PetscMalloc1(sf->nleaves,&remote);CHKERRQ(ierr);
for (i=0; i<sf->nleaves; i++) {
remote[i].rank = sf->remote[i].rank;
remote[i].index = outoffset[sf->mine ? sf->mine[i] : i];
}
ierr = PetscSFDuplicate(sf,PETSCSF_DUPLICATE_RANKS,&sf->multi);CHKERRQ(ierr);
ierr = PetscSFSetGraph(sf->multi,inoffset[sf->nroots],sf->nleaves,sf->mine,PETSC_COPY_VALUES,remote,PETSC_OWN_POINTER);CHKERRQ(ierr);
if (sf->rankorder) { /* Sort the ranks */
PetscMPIInt rank;
PetscInt *inranks,*newoffset,*outranks,*newoutoffset,*tmpoffset,maxdegree;
PetscSFNode *newremote;
ierr = MPI_Comm_rank(PetscObjectComm((PetscObject)sf),&rank);CHKERRQ(ierr);
for (i=0,maxdegree=0; i<sf->nroots; i++) maxdegree = PetscMax(maxdegree,indegree[i]);
ierr = PetscMalloc5(sf->multi->nroots,&inranks,sf->multi->nroots,&newoffset,maxlocal,&outranks,maxlocal,&newoutoffset,maxdegree,&tmpoffset);CHKERRQ(ierr);
for (i=0; i<maxlocal; i++) outranks[i] = rank;
ierr = PetscSFReduceBegin(sf->multi,MPIU_INT,outranks,inranks,MPIU_REPLACE);CHKERRQ(ierr);
ierr = PetscSFReduceEnd(sf->multi,MPIU_INT,outranks,inranks,MPIU_REPLACE);CHKERRQ(ierr);
/* Sort the incoming ranks at each vertex, build the inverse map */
for (i=0; i<sf->nroots; i++) {
PetscInt j;
for (j=0; j<indegree[i]; j++) tmpoffset[j] = j;
ierr = PetscSortIntWithArray(indegree[i],inranks+inoffset[i],tmpoffset);CHKERRQ(ierr);
for (j=0; j<indegree[i]; j++) newoffset[inoffset[i] + tmpoffset[j]] = inoffset[i] + j;
}
ierr = PetscSFBcastBegin(sf->multi,MPIU_INT,newoffset,newoutoffset);CHKERRQ(ierr);
ierr = PetscSFBcastEnd(sf->multi,MPIU_INT,newoffset,newoutoffset);CHKERRQ(ierr);
ierr = PetscMalloc1(sf->nleaves,&newremote);CHKERRQ(ierr);
for (i=0; i<sf->nleaves; i++) {
newremote[i].rank = sf->remote[i].rank;
newremote[i].index = newoutoffset[sf->mine ? sf->mine[i] : i];
}
ierr = PetscSFSetGraph(sf->multi,inoffset[sf->nroots],sf->nleaves,sf->mine,PETSC_COPY_VALUES,newremote,PETSC_OWN_POINTER);CHKERRQ(ierr);
ierr = PetscFree5(inranks,newoffset,outranks,newoutoffset,tmpoffset);CHKERRQ(ierr);
}
ierr = PetscFree3(inoffset,outones,outoffset);CHKERRQ(ierr);
}
*multi = sf->multi;
PetscFunctionReturn(0);
}
/*
EPSPartialLanczos - Partial reorthogonalization.
*/
static PetscErrorCode EPSPartialLanczos(EPS eps,PetscReal *alpha,PetscReal *beta,PetscInt k,PetscInt *M,PetscBool *breakdown,PetscReal anorm)
{
PetscErrorCode ierr;
EPS_LANCZOS *lanczos = (EPS_LANCZOS*)eps->data;
PetscInt i,j,m = *M;
Vec vj,vj1;
PetscReal norm,*omega,lomega[100],*omega_old,lomega_old[100],eps1,delta,eta;
PetscBool *which,lwhich[100],*which2,lwhich2[100];
PetscBool reorth = PETSC_FALSE,force_reorth = PETSC_FALSE;
PetscBool fro = PETSC_FALSE,estimate_anorm = PETSC_FALSE;
PetscScalar *hwork,lhwork[100];
PetscFunctionBegin;
if (m>100) {
ierr = PetscMalloc5(m,&omega,m,&omega_old,m,&which,m,&which2,m,&hwork);CHKERRQ(ierr);
} else {
omega = lomega;
omega_old = lomega_old;
which = lwhich;
which2 = lwhich2;
hwork = lhwork;
}
eps1 = PetscSqrtReal((PetscReal)eps->n)*PETSC_MACHINE_EPSILON/2;
delta = PETSC_SQRT_MACHINE_EPSILON/PetscSqrtReal((PetscReal)eps->ncv);
eta = PetscPowReal(PETSC_MACHINE_EPSILON,3.0/4.0)/PetscSqrtReal((PetscReal)eps->ncv);
if (anorm < 0.0) {
anorm = 1.0;
estimate_anorm = PETSC_TRUE;
}
for (i=0;i<m-k;i++) omega[i] = omega_old[i] = 0.0;
for (i=0;i<k;i++) which[i] = PETSC_TRUE;
ierr = BVSetActiveColumns(eps->V,0,m);CHKERRQ(ierr);
for (j=k;j<m;j++) {
ierr = BVGetColumn(eps->V,j,&vj);CHKERRQ(ierr);
ierr = BVGetColumn(eps->V,j+1,&vj1);CHKERRQ(ierr);
ierr = STApply(eps->st,vj,vj1);CHKERRQ(ierr);
ierr = BVRestoreColumn(eps->V,j,&vj);CHKERRQ(ierr);
ierr = BVRestoreColumn(eps->V,j+1,&vj1);CHKERRQ(ierr);
if (fro) {
/* Lanczos step with full reorthogonalization */
ierr = BVOrthogonalizeColumn(eps->V,j+1,hwork,&norm,breakdown);CHKERRQ(ierr);
alpha[j] = PetscRealPart(hwork[j]);
} else {
/* Lanczos step */
which[j] = PETSC_TRUE;
if (j-2>=k) which[j-2] = PETSC_FALSE;
ierr = BVOrthogonalizeSomeColumn(eps->V,j+1,which,hwork,&norm,breakdown);CHKERRQ(ierr);
alpha[j] = PetscRealPart(hwork[j]);
beta[j] = norm;
/* Estimate ||A|| if needed */
if (estimate_anorm) {
if (j>k) anorm = PetscMax(anorm,PetscAbsReal(alpha[j])+norm+beta[j-1]);
else anorm = PetscMax(anorm,PetscAbsReal(alpha[j])+norm);
}
/* Check if reorthogonalization is needed */
reorth = PETSC_FALSE;
if (j>k) {
update_omega(omega,omega_old,j,alpha,beta-1,eps1,anorm);
for (i=0;i<j-k;i++) {
if (PetscAbsScalar(omega[i]) > delta) reorth = PETSC_TRUE;
}
}
if (reorth || force_reorth) {
for (i=0;i<k;i++) which2[i] = PETSC_FALSE;
for (i=k;i<=j;i++) which2[i] = PETSC_TRUE;
if (lanczos->reorthog == EPS_LANCZOS_REORTHOG_PERIODIC) {
/* Periodic reorthogonalization */
if (force_reorth) force_reorth = PETSC_FALSE;
else force_reorth = PETSC_TRUE;
for (i=0;i<j-k;i++) omega[i] = eps1;
} else {
/* Partial reorthogonalization */
if (force_reorth) force_reorth = PETSC_FALSE;
else {
force_reorth = PETSC_TRUE;
compute_int(which2+k,omega,j-k,delta,eta);
for (i=0;i<j-k;i++) {
if (which2[i+k]) omega[i] = eps1;
}
}
}
ierr = BVOrthogonalizeSomeColumn(eps->V,j+1,which2,hwork,&norm,breakdown);CHKERRQ(ierr);
}
}
if (*breakdown || norm < eps->n*anorm*PETSC_MACHINE_EPSILON) {
*M = j+1;
break;
}
if (!fro && norm*delta < anorm*eps1) {
fro = PETSC_TRUE;
ierr = PetscInfo1(eps,"Switching to full reorthogonalization at iteration %D\n",eps->its);CHKERRQ(ierr);
}
beta[j] = norm;
ierr = BVScaleColumn(eps->V,j+1,1.0/norm);CHKERRQ(ierr);
}
if (m>100) {
ierr = PetscFree5(omega,omega_old,which,which2,hwork);CHKERRQ(ierr);
}
PetscFunctionReturn(0);
}
int main(int argc, char *args[])
{
PFLOTRANMesh data;
Mat Adj; /* The adjacency matrix of the mesh */
PetscInt bs = 3;
PetscScalar values[9],*cc;
PetscMPIInt size;
PetscInt i;
PetscErrorCode ierr;
PetscViewer binaryviewer;
Vec cellCenters;
PetscViewer hdf5viewer;
hid_t file_id, dataset_id, dataspace_id;
herr_t status;
PetscFunctionBegin;
ierr = PetscInitialize(&argc, &args, (char *) 0, help);
ierr = MPI_Comm_size(PETSC_COMM_WORLD, &size);CHKERRQ(ierr);
if (size > 1) SETERRQ(PETSC_ERR_SUP,"This preprocessor runs only on one process");
/* Open Glenn's file */
ierr = PetscViewerCreate(PETSC_COMM_SELF, &hdf5viewer);CHKERRQ(ierr);
ierr = PetscViewerSetType(hdf5viewer, PETSC_VIEWER_HDF5);CHKERRQ(ierr);
ierr = PetscViewerFileSetMode(hdf5viewer, FILE_MODE_READ);CHKERRQ(ierr);
ierr = PetscViewerFileSetName(hdf5viewer, "mesh.h5");CHKERRQ(ierr);
ierr = PetscViewerHDF5GetFileId(hdf5viewer, &file_id);CHKERRQ(ierr);
/* get number of cells and then number of edges */
dataset_id = H5Dopen(file_id, "/Cells/Natural IDs");
dataspace_id = H5Dget_space(dataset_id);
status = H5Sget_simple_extent_dims(dataspace_id, &data.numCells, NULL);if (status < 0) SETERRQ(PETSC_ERR_LIB,"Bad dimension");
status = H5Sclose(dataspace_id);CHKERRQ(status);
status = H5Dclose(dataset_id);CHKERRQ(status);
dataset_id = H5Dopen(file_id, "/Connections/Areas");
dataspace_id = H5Dget_space(dataset_id);
status = H5Sget_simple_extent_dims(dataspace_id, &data.numFaces, NULL);if (status < 0) SETERRQ(PETSC_ERR_LIB,"Bad dimension");
status = H5Sclose(dataspace_id);CHKERRQ(status);
status = H5Dclose(dataset_id);CHKERRQ(status);
ierr = PetscPrintf(PETSC_COMM_SELF, "Number of cells %D Number of faces %D \n",(PetscInt)data.numCells,(PetscInt)data.numFaces);CHKERRQ(ierr);
/* read face data */
ierr = PetscMalloc5(data.numFaces,double,&data.faceAreas,data.numFaces,int,&data.downCells,data.numFaces,double,&data.downX,data.numFaces,double,&data.downY,data.numFaces,double,&data.downZ);CHKERRQ(ierr);
dataset_id = H5Dopen(file_id, "/Connections/Areas");
status = H5Dread(dataset_id, H5T_IEEE_F64LE, H5S_ALL, H5S_ALL, H5P_DEFAULT, data.faceAreas);CHKERRQ(status);
status = H5Dclose(dataset_id);CHKERRQ(status);
dataset_id = H5Dopen(file_id, "/Connections/Downwind Cell IDs");
status = H5Dread(dataset_id, H5T_STD_I32LE, H5S_ALL, H5S_ALL, H5P_DEFAULT, data.downCells);CHKERRQ(status);
status = H5Dclose(dataset_id);CHKERRQ(status);
dataset_id = H5Dopen(file_id, "/Connections/Downwind Distance X");
status = H5Dread(dataset_id, H5T_IEEE_F64LE, H5S_ALL, H5S_ALL, H5P_DEFAULT, data.downX);CHKERRQ(status);
status = H5Dclose(dataset_id);CHKERRQ(status);
dataset_id = H5Dopen(file_id, "/Connections/Downwind Distance Y");
status = H5Dread(dataset_id, H5T_IEEE_F64LE, H5S_ALL, H5S_ALL, H5P_DEFAULT, data.downY);CHKERRQ(status);
status = H5Dclose(dataset_id);CHKERRQ(status);
dataset_id = H5Dopen(file_id, "/Connections/Downwind Distance Z");
status = H5Dread(dataset_id, H5T_IEEE_F64LE, H5S_ALL, H5S_ALL, H5P_DEFAULT, data.downZ);CHKERRQ(status);
status = H5Dclose(dataset_id);CHKERRQ(status);
ierr = PetscMalloc4(data.numFaces,int,&data.upCells,data.numFaces,double,&data.upX,data.numFaces,double,&data.upY,data.numFaces,double,&data.upZ);CHKERRQ(ierr);
dataset_id = H5Dopen(file_id, "/Connections/Upwind Cell IDs");
status = H5Dread(dataset_id, H5T_STD_I32LE, H5S_ALL, H5S_ALL, H5P_DEFAULT, data.upCells);CHKERRQ(status);
status = H5Dclose(dataset_id);CHKERRQ(status);
dataset_id = H5Dopen(file_id, "/Connections/Upwind Distance X");
status = H5Dread(dataset_id, H5T_IEEE_F64LE, H5S_ALL, H5S_ALL, H5P_DEFAULT, data.upX);CHKERRQ(status);
status = H5Dclose(dataset_id);CHKERRQ(status);
dataset_id = H5Dopen(file_id, "/Connections/Upwind Distance Y");
status = H5Dread(dataset_id, H5T_IEEE_F64LE, H5S_ALL, H5S_ALL, H5P_DEFAULT, data.upY);CHKERRQ(status);
status = H5Dclose(dataset_id);CHKERRQ(status);
dataset_id = H5Dopen(file_id, "/Connections/Upwind Distance Z");
status = H5Dread(dataset_id, H5T_IEEE_F64LE, H5S_ALL, H5S_ALL, H5P_DEFAULT, data.upZ);CHKERRQ(status);
status = H5Dclose(dataset_id);CHKERRQ(status);
// Put face data into matrix
ierr = MatCreate(PETSC_COMM_WORLD, &Adj);CHKERRQ(ierr);
ierr = MatSetSizes(Adj, data.numCells*bs, data.numCells*bs, PETSC_DECIDE, PETSC_DECIDE);CHKERRQ(ierr);
ierr = MatSetFromOptions(Adj);CHKERRQ(ierr);
ierr = MatSetType(Adj,MATSEQBAIJ);CHKERRQ(ierr);
ierr = MatSeqBAIJSetPreallocation(Adj, bs, 6,PETSC_NULL);CHKERRQ(ierr);
//ierr = MatSetType(Adj,MATSEQAIJ);CHKERRQ(ierr);
//ierr = MatSeqAIJSetPreallocation(Adj, 6,PETSC_NULL);CHKERRQ(ierr);
for(i = 0; i < data.numFaces; ++i) {
values[0] = data.faceAreas[i];
values[1] = data.downCells[i];
values[2] = data.downX[i];
values[3] = data.downY[i];
values[4] = data.downZ[i];
values[5] = data.upCells[i];
values[6] = data.upX[i];
values[7] = data.upY[i];
values[8] = data.upZ[i];
ierr = MatSetValuesBlocked(Adj, 1, &data.downCells[i], 1, &data.upCells[i], values, INSERT_VALUES);CHKERRQ(ierr);
ierr = MatSetValuesBlocked(Adj, 1, &data.upCells[i], 1, &data.downCells[i], values, INSERT_VALUES);CHKERRQ(ierr);
//ierr = MatSetValues(Adj, 1, &data.downCells[i], 1, &data.upCells[i], values, INSERT_VALUES);CHKERRQ(ierr);
//ierr = MatSetValues(Adj, 1, &data.upCells[i], 1, &data.downCells[i], values, INSERT_VALUES);CHKERRQ(ierr);
}
ierr = MatAssemblyBegin(Adj, MAT_FINAL_ASSEMBLY);CHKERRQ(ierr);
ierr = MatAssemblyEnd(Adj, MAT_FINAL_ASSEMBLY);CHKERRQ(ierr);
ierr = PetscFree5(data.faceAreas, data.downCells, data.downX, data.downY, data.downZ);CHKERRQ(ierr);
ierr = PetscFree4(data.upCells, data.upX, data.upY, data.upZ);CHKERRQ(ierr);
ierr = PetscViewerBinaryOpen(PETSC_COMM_SELF,"mesh.petsc", FILE_MODE_WRITE,&binaryviewer);CHKERRQ(ierr);
ierr = MatView(Adj, binaryviewer);CHKERRQ(ierr);
ierr = MatDestroy(Adj);CHKERRQ(ierr);
/* read cell information */
ierr = PetscMalloc5(data.numCells,int,&data.cellIds,data.numCells,double,&data.cellVols,data.numCells,double,&data.cellX,data.numCells,double,&data.cellY,data.numCells,double,&data.cellZ);CHKERRQ(ierr);
dataset_id = H5Dopen(file_id, "/Cells/Natural IDs");
status = H5Dread(dataset_id, H5T_STD_I32LE, H5S_ALL, H5S_ALL, H5P_DEFAULT, data.cellIds);CHKERRQ(status);
status = H5Dclose(dataset_id);CHKERRQ(status);
dataset_id = H5Dopen(file_id, "/Cells/Volumes");
status = H5Dread(dataset_id, H5T_IEEE_F64LE, H5S_ALL, H5S_ALL, H5P_DEFAULT, data.cellVols);CHKERRQ(status);
status = H5Dclose(dataset_id);CHKERRQ(status);
dataset_id = H5Dopen(file_id, "/Cells/X-Coordinates");
status = H5Dread(dataset_id, H5T_IEEE_F64LE, H5S_ALL, H5S_ALL, H5P_DEFAULT, data.cellX);CHKERRQ(status);
status = H5Dclose(dataset_id);CHKERRQ(status);
dataset_id = H5Dopen(file_id, "/Cells/Y-Coordinates");
status = H5Dread(dataset_id, H5T_IEEE_F64LE, H5S_ALL, H5S_ALL, H5P_DEFAULT, data.cellY);CHKERRQ(status);
status = H5Dclose(dataset_id);CHKERRQ(status);
dataset_id = H5Dopen(file_id, "/Cells/Z-Coordinates");
status = H5Dread(dataset_id, H5T_IEEE_F64LE, H5S_ALL, H5S_ALL, H5P_DEFAULT, data.cellZ);CHKERRQ(status);
status = H5Dclose(dataset_id);CHKERRQ(status);
ierr = PetscViewerDestroy(hdf5viewer);CHKERRQ(ierr);
/* put cell information into vectors */
ierr = VecCreateSeq(PETSC_COMM_SELF,3*data.numCells,&cellCenters);CHKERRQ(ierr);
ierr = VecSetBlockSize(cellCenters,3);CHKERRQ(ierr);
ierr = VecGetArray(cellCenters,&cc);CHKERRQ(ierr);
for (i=0; i<data.numCells; i++) {
cc[3*i] = data.cellX[i];
cc[3*i+1] = data.cellY[i];
cc[3*i+2] = data.cellZ[i];
}
ierr = VecRestoreArray(cellCenters,&cc);CHKERRQ(ierr);
ierr = VecView(cellCenters,binaryviewer);CHKERRQ(ierr);
ierr = VecGetArray(cellCenters,&cc);CHKERRQ(ierr);
for (i=0; i<data.numCells; i++) {
cc[3*i] = data.cellIds[i];
cc[3*i+1] = data.cellVols[i];
cc[3*i+2] = 0.0;
}
ierr = VecRestoreArray(cellCenters,&cc);CHKERRQ(ierr);
ierr = VecView(cellCenters,binaryviewer);CHKERRQ(ierr);
ierr = PetscFree5(data.cellIds, data.cellVols, data.cellX, data.cellY, data.cellZ);CHKERRQ(ierr);
ierr = VecDestroy(cellCenters);
ierr = PetscViewerDestroy(binaryviewer);CHKERRQ(ierr);
ierr = PetscFinalize();CHKERRQ(ierr);
PetscFunctionReturn(0);
}
PetscErrorCode DMCreateInterpolation_Cartesian(DM fineMesh, DM coarseMesh, Mat *interpolation, Vec *scaling)
{
ALE::Obj<ALE::CartesianMesh> coarse;
ALE::Obj<ALE::CartesianMesh> fine;
Mat P;
PetscErrorCode ierr;
PetscFunctionBegin;
ierr = DMCartesianGetMesh(fineMesh, fine);
CHKERRQ(ierr);
ierr = DMCartesianGetMesh(coarseMesh, coarse);
CHKERRQ(ierr);
#if 0
const ALE::Obj<ALE::Mesh::real_section_type>& coarseCoordinates = coarse->getRealSection("coordinates");
const ALE::Obj<ALE::Mesh::real_section_type>& fineCoordinates = fine->getRealSection("coordinates");
const ALE::Obj<ALE::Mesh::label_sequence>& vertices = fine->depthStratum(0);
const ALE::Obj<ALE::Mesh::real_section_type>& sCoarse = coarse->getRealSection("default");
const ALE::Obj<ALE::Mesh::real_section_type>& sFine = fine->getRealSection("default");
const ALE::Obj<ALE::Mesh::order_type>& coarseOrder = coarse->getFactory()->getGlobalOrder(coarse, "default", sCoarse);
const ALE::Obj<ALE::Mesh::order_type>& fineOrder = fine->getFactory()->getGlobalOrder(fine, "default", sFine);
const int dim = coarse->getDimension();
double *v0, *J, *invJ, detJ, *refCoords, *values;
#endif
ierr = MatCreate(fine->comm(), &P);
CHKERRQ(ierr);
#if 0
ierr = MatSetSizes(P, sFine->size(), sCoarse->size(), PETSC_DETERMINE, PETSC_DETERMINE);
CHKERRQ(ierr);
ierr = MatSetFromOptions(P);
CHKERRQ(ierr);
ierr = PetscMalloc5(dim,double,&v0,dim*dim,double,&J,dim*dim,double,&invJ,dim,double,&refCoords,dim+1,double,&values);
CHKERRQ(ierr);
for(ALE::Mesh::label_sequence::iterator v_iter = vertices->begin(); v_iter != vertices->end(); ++v_iter) {
const ALE::Mesh::real_section_type::value_type *coords = fineCoordinates->restrictPoint(*v_iter);
const ALE::Mesh::point_type coarseCell = coarse->locatePoint(coords);
coarse->computeElementGeometry(coarseCoordinates, coarseCell, v0, J, invJ, detJ);
for(int d = 0; d < dim; ++d) {
refCoords[d] = 0.0;
for(int e = 0; e < dim; ++e) {
refCoords[d] += invJ[d*dim+e]*(coords[e] - v0[e]);
}
refCoords[d] -= 1.0;
}
values[0] = 1.0/3.0 - (refCoords[0] + refCoords[1])/3.0;
values[1] = 0.5*(refCoords[0] + 1.0);
values[2] = 0.5*(refCoords[1] + 1.0);
ierr = updateOperatorGeneral(P, fine, sFine, fineOrder, *v_iter, sCoarse, coarseOrder, coarseCell, values, INSERT_VALUES);
CHKERRQ(ierr);
}
ierr = PetscFree5(v0,J,invJ,refCoords,values);
CHKERRQ(ierr);
#endif
ierr = MatAssemblyBegin(P, MAT_FINAL_ASSEMBLY);
CHKERRQ(ierr);
ierr = MatAssemblyEnd(P, MAT_FINAL_ASSEMBLY);
CHKERRQ(ierr);
*interpolation = P;
PetscFunctionReturn(0);
}
PetscErrorCode MatGetSubMatrices_MPIDense_Local(Mat C,PetscInt ismax,const IS isrow[],const IS iscol[],MatReuse scall,Mat *submats)
{
Mat_MPIDense *c = (Mat_MPIDense*)C->data;
Mat A = c->A;
Mat_SeqDense *a = (Mat_SeqDense*)A->data,*mat;
PetscErrorCode ierr;
PetscMPIInt rank,size,tag0,tag1,idex,end,i;
PetscInt N = C->cmap->N,rstart = C->rmap->rstart,count;
const PetscInt **irow,**icol,*irow_i;
PetscInt *nrow,*ncol,*w1,*w3,*w4,*rtable,start;
PetscInt **sbuf1,m,j,k,l,ct1,**rbuf1,row,proc;
PetscInt nrqs,msz,**ptr,*ctr,*pa,*tmp,bsz,nrqr;
PetscInt is_no,jmax,**rmap,*rmap_i;
PetscInt ctr_j,*sbuf1_j,*rbuf1_i;
MPI_Request *s_waits1,*r_waits1,*s_waits2,*r_waits2;
MPI_Status *r_status1,*r_status2,*s_status1,*s_status2;
MPI_Comm comm;
PetscScalar **rbuf2,**sbuf2;
PetscBool sorted;
PetscFunctionBegin;
comm = ((PetscObject)C)->comm;
tag0 = ((PetscObject)C)->tag;
size = c->size;
rank = c->rank;
m = C->rmap->N;
/* Get some new tags to keep the communication clean */
ierr = PetscObjectGetNewTag((PetscObject)C,&tag1);CHKERRQ(ierr);
/* Check if the col indices are sorted */
for (i=0; i<ismax; i++) {
ierr = ISSorted(isrow[i],&sorted);CHKERRQ(ierr);
if (!sorted) SETERRQ(PETSC_COMM_SELF,PETSC_ERR_ARG_WRONGSTATE,"ISrow is not sorted");
ierr = ISSorted(iscol[i],&sorted);CHKERRQ(ierr);
if (!sorted) SETERRQ(PETSC_COMM_SELF,PETSC_ERR_ARG_WRONGSTATE,"IScol is not sorted");
}
ierr = PetscMalloc5(ismax,const PetscInt*,&irow,ismax,const PetscInt*,&icol,ismax,PetscInt,&nrow,ismax,PetscInt,&ncol,m,PetscInt,&rtable);CHKERRQ(ierr);
for (i=0; i<ismax; i++) {
ierr = ISGetIndices(isrow[i],&irow[i]);CHKERRQ(ierr);
ierr = ISGetIndices(iscol[i],&icol[i]);CHKERRQ(ierr);
ierr = ISGetLocalSize(isrow[i],&nrow[i]);CHKERRQ(ierr);
ierr = ISGetLocalSize(iscol[i],&ncol[i]);CHKERRQ(ierr);
}
/* Create hash table for the mapping :row -> proc*/
for (i=0,j=0; i<size; i++) {
jmax = C->rmap->range[i+1];
for (; j<jmax; j++) {
rtable[j] = i;
}
}
/* evaluate communication - mesg to who,length of mesg, and buffer space
required. Based on this, buffers are allocated, and data copied into them*/
ierr = PetscMalloc3(2*size,PetscInt,&w1,size,PetscInt,&w3,size,PetscInt,&w4);CHKERRQ(ierr);
ierr = PetscMemzero(w1,size*2*sizeof(PetscInt));CHKERRQ(ierr); /* initialize work vector*/
ierr = PetscMemzero(w3,size*sizeof(PetscInt));CHKERRQ(ierr); /* initialize work vector*/
for (i=0; i<ismax; i++) {
ierr = PetscMemzero(w4,size*sizeof(PetscInt));CHKERRQ(ierr); /* initialize work vector*/
jmax = nrow[i];
irow_i = irow[i];
for (j=0; j<jmax; j++) {
row = irow_i[j];
proc = rtable[row];
w4[proc]++;
}
for (j=0; j<size; j++) {
if (w4[j]) { w1[2*j] += w4[j]; w3[j]++;}
}
}
nrqs = 0; /* no of outgoing messages */
msz = 0; /* total mesg length (for all procs) */
w1[2*rank] = 0; /* no mesg sent to self */
w3[rank] = 0;
for (i=0; i<size; i++) {
if (w1[2*i]) { w1[2*i+1] = 1; nrqs++;} /* there exists a message to proc i */
}
ierr = PetscMalloc((nrqs+1)*sizeof(PetscInt),&pa);CHKERRQ(ierr); /*(proc -array)*/
for (i=0,j=0; i<size; i++) {
if (w1[2*i]) { pa[j] = i; j++; }
}
/* Each message would have a header = 1 + 2*(no of IS) + data */
for (i=0; i<nrqs; i++) {
j = pa[i];
w1[2*j] += w1[2*j+1] + 2* w3[j];
msz += w1[2*j];
}
/* Do a global reduction to determine how many messages to expect*/
ierr = PetscMaxSum(comm,w1,&bsz,&nrqr);CHKERRQ(ierr);
/* Allocate memory for recv buffers . Make sure rbuf1[0] exists by adding 1 to the buffer length */
ierr = PetscMalloc((nrqr+1)*sizeof(PetscInt*),&rbuf1);CHKERRQ(ierr);
ierr = PetscMalloc(nrqr*bsz*sizeof(PetscInt),&rbuf1[0]);CHKERRQ(ierr);
for (i=1; i<nrqr; ++i) rbuf1[i] = rbuf1[i-1] + bsz;
/* Post the receives */
ierr = PetscMalloc((nrqr+1)*sizeof(MPI_Request),&r_waits1);CHKERRQ(ierr);
for (i=0; i<nrqr; ++i) {
ierr = MPI_Irecv(rbuf1[i],bsz,MPIU_INT,MPI_ANY_SOURCE,tag0,comm,r_waits1+i);CHKERRQ(ierr);
}
/* Allocate Memory for outgoing messages */
ierr = PetscMalloc4(size,PetscInt*,&sbuf1,size,PetscInt*,&ptr,2*msz,PetscInt,&tmp,size,PetscInt,&ctr);CHKERRQ(ierr);
ierr = PetscMemzero(sbuf1,size*sizeof(PetscInt*));CHKERRQ(ierr);
ierr = PetscMemzero(ptr,size*sizeof(PetscInt*));CHKERRQ(ierr);
{
PetscInt *iptr = tmp,ict = 0;
for (i=0; i<nrqs; i++) {
j = pa[i];
iptr += ict;
sbuf1[j] = iptr;
ict = w1[2*j];
}
}
/* Form the outgoing messages */
/* Initialize the header space */
for (i=0; i<nrqs; i++) {
j = pa[i];
sbuf1[j][0] = 0;
ierr = PetscMemzero(sbuf1[j]+1,2*w3[j]*sizeof(PetscInt));CHKERRQ(ierr);
ptr[j] = sbuf1[j] + 2*w3[j] + 1;
}
/* Parse the isrow and copy data into outbuf */
for (i=0; i<ismax; i++) {
ierr = PetscMemzero(ctr,size*sizeof(PetscInt));CHKERRQ(ierr);
irow_i = irow[i];
jmax = nrow[i];
for (j=0; j<jmax; j++) { /* parse the indices of each IS */
row = irow_i[j];
proc = rtable[row];
if (proc != rank) { /* copy to the outgoing buf*/
ctr[proc]++;
*ptr[proc] = row;
ptr[proc]++;
}
}
/* Update the headers for the current IS */
for (j=0; j<size; j++) { /* Can Optimise this loop too */
if ((ctr_j = ctr[j])) {
sbuf1_j = sbuf1[j];
k = ++sbuf1_j[0];
sbuf1_j[2*k] = ctr_j;
sbuf1_j[2*k-1] = i;
}
}
}
/* Now post the sends */
ierr = PetscMalloc((nrqs+1)*sizeof(MPI_Request),&s_waits1);CHKERRQ(ierr);
for (i=0; i<nrqs; ++i) {
j = pa[i];
ierr = MPI_Isend(sbuf1[j],w1[2*j],MPIU_INT,j,tag0,comm,s_waits1+i);CHKERRQ(ierr);
}
/* Post recieves to capture the row_data from other procs */
ierr = PetscMalloc((nrqs+1)*sizeof(MPI_Request),&r_waits2);CHKERRQ(ierr);
ierr = PetscMalloc((nrqs+1)*sizeof(PetscScalar*),&rbuf2);CHKERRQ(ierr);
for (i=0; i<nrqs; i++) {
j = pa[i];
count = (w1[2*j] - (2*sbuf1[j][0] + 1))*N;
ierr = PetscMalloc((count+1)*sizeof(PetscScalar),&rbuf2[i]);CHKERRQ(ierr);
ierr = MPI_Irecv(rbuf2[i],count,MPIU_SCALAR,j,tag1,comm,r_waits2+i);CHKERRQ(ierr);
}
/* Receive messages(row_nos) and then, pack and send off the rowvalues
to the correct processors */
ierr = PetscMalloc((nrqr+1)*sizeof(MPI_Request),&s_waits2);CHKERRQ(ierr);
ierr = PetscMalloc((nrqr+1)*sizeof(MPI_Status),&r_status1);CHKERRQ(ierr);
ierr = PetscMalloc((nrqr+1)*sizeof(PetscScalar*),&sbuf2);CHKERRQ(ierr);
{
PetscScalar *sbuf2_i,*v_start;
PetscInt s_proc;
for (i=0; i<nrqr; ++i) {
ierr = MPI_Waitany(nrqr,r_waits1,&idex,r_status1+i);CHKERRQ(ierr);
s_proc = r_status1[i].MPI_SOURCE; /* send processor */
rbuf1_i = rbuf1[idex]; /* Actual message from s_proc */
/* no of rows = end - start; since start is array idex[], 0idex, whel end
is length of the buffer - which is 1idex */
start = 2*rbuf1_i[0] + 1;
ierr = MPI_Get_count(r_status1+i,MPIU_INT,&end);CHKERRQ(ierr);
/* allocate memory sufficinet to hold all the row values */
ierr = PetscMalloc((end-start)*N*sizeof(PetscScalar),&sbuf2[idex]);CHKERRQ(ierr);
sbuf2_i = sbuf2[idex];
/* Now pack the data */
for (j=start; j<end; j++) {
row = rbuf1_i[j] - rstart;
v_start = a->v + row;
for (k=0; k<N; k++) {
sbuf2_i[0] = v_start[0];
sbuf2_i++; v_start += C->rmap->n;
}
}
/* Now send off the data */
ierr = MPI_Isend(sbuf2[idex],(end-start)*N,MPIU_SCALAR,s_proc,tag1,comm,s_waits2+i);CHKERRQ(ierr);
}
}
/* End Send-Recv of IS + row_numbers */
ierr = PetscFree(r_status1);CHKERRQ(ierr);
ierr = PetscFree(r_waits1);CHKERRQ(ierr);
ierr = PetscMalloc((nrqs+1)*sizeof(MPI_Status),&s_status1);CHKERRQ(ierr);
if (nrqs) {ierr = MPI_Waitall(nrqs,s_waits1,s_status1);CHKERRQ(ierr);}
ierr = PetscFree(s_status1);CHKERRQ(ierr);
ierr = PetscFree(s_waits1);CHKERRQ(ierr);
/* Create the submatrices */
if (scall == MAT_REUSE_MATRIX) {
for (i=0; i<ismax; i++) {
mat = (Mat_SeqDense *)(submats[i]->data);
if ((submats[i]->rmap->n != nrow[i]) || (submats[i]->cmap->n != ncol[i])) SETERRQ(PETSC_COMM_SELF,PETSC_ERR_ARG_SIZ,"Cannot reuse matrix. wrong size");
ierr = PetscMemzero(mat->v,submats[i]->rmap->n*submats[i]->cmap->n*sizeof(PetscScalar));CHKERRQ(ierr);
submats[i]->factortype = C->factortype;
}
} else {
for (i=0; i<ismax; i++) {
ierr = MatCreate(PETSC_COMM_SELF,submats+i);CHKERRQ(ierr);
ierr = MatSetSizes(submats[i],nrow[i],ncol[i],nrow[i],ncol[i]);CHKERRQ(ierr);
ierr = MatSetType(submats[i],((PetscObject)A)->type_name);CHKERRQ(ierr);
ierr = MatSeqDenseSetPreallocation(submats[i],PETSC_NULL);CHKERRQ(ierr);
}
}
/* Assemble the matrices */
{
PetscInt col;
PetscScalar *imat_v,*mat_v,*imat_vi,*mat_vi;
for (i=0; i<ismax; i++) {
mat = (Mat_SeqDense*)submats[i]->data;
mat_v = a->v;
imat_v = mat->v;
irow_i = irow[i];
m = nrow[i];
for (j=0; j<m; j++) {
row = irow_i[j] ;
proc = rtable[row];
if (proc == rank) {
row = row - rstart;
mat_vi = mat_v + row;
imat_vi = imat_v + j;
for (k=0; k<ncol[i]; k++) {
col = icol[i][k];
imat_vi[k*m] = mat_vi[col*C->rmap->n];
}
}
}
}
}
/* Create row map-> This maps c->row to submat->row for each submat*/
/* this is a very expensive operation wrt memory usage */
ierr = PetscMalloc(ismax*sizeof(PetscInt*),&rmap);CHKERRQ(ierr);
ierr = PetscMalloc(ismax*C->rmap->N*sizeof(PetscInt),&rmap[0]);CHKERRQ(ierr);
ierr = PetscMemzero(rmap[0],ismax*C->rmap->N*sizeof(PetscInt));CHKERRQ(ierr);
for (i=1; i<ismax; i++) { rmap[i] = rmap[i-1] + C->rmap->N;}
for (i=0; i<ismax; i++) {
rmap_i = rmap[i];
irow_i = irow[i];
jmax = nrow[i];
for (j=0; j<jmax; j++) {
rmap_i[irow_i[j]] = j;
}
}
/* Now Receive the row_values and assemble the rest of the matrix */
ierr = PetscMalloc((nrqs+1)*sizeof(MPI_Status),&r_status2);CHKERRQ(ierr);
{
PetscInt is_max,tmp1,col,*sbuf1_i,is_sz;
PetscScalar *rbuf2_i,*imat_v,*imat_vi;
for (tmp1=0; tmp1<nrqs; tmp1++) { /* For each message */
ierr = MPI_Waitany(nrqs,r_waits2,&i,r_status2+tmp1);CHKERRQ(ierr);
/* Now dig out the corresponding sbuf1, which contains the IS data_structure */
sbuf1_i = sbuf1[pa[i]];
is_max = sbuf1_i[0];
ct1 = 2*is_max+1;
rbuf2_i = rbuf2[i];
for (j=1; j<=is_max; j++) { /* For each IS belonging to the message */
is_no = sbuf1_i[2*j-1];
is_sz = sbuf1_i[2*j];
mat = (Mat_SeqDense*)submats[is_no]->data;
imat_v = mat->v;
rmap_i = rmap[is_no];
m = nrow[is_no];
for (k=0; k<is_sz; k++,rbuf2_i+=N) { /* For each row */
row = sbuf1_i[ct1]; ct1++;
row = rmap_i[row];
imat_vi = imat_v + row;
for (l=0; l<ncol[is_no]; l++) { /* For each col */
col = icol[is_no][l];
imat_vi[l*m] = rbuf2_i[col];
}
}
}
}
}
/* End Send-Recv of row_values */
ierr = PetscFree(r_status2);CHKERRQ(ierr);
ierr = PetscFree(r_waits2);CHKERRQ(ierr);
ierr = PetscMalloc((nrqr+1)*sizeof(MPI_Status),&s_status2);CHKERRQ(ierr);
if (nrqr) {ierr = MPI_Waitall(nrqr,s_waits2,s_status2);CHKERRQ(ierr);}
ierr = PetscFree(s_status2);CHKERRQ(ierr);
ierr = PetscFree(s_waits2);CHKERRQ(ierr);
/* Restore the indices */
for (i=0; i<ismax; i++) {
ierr = ISRestoreIndices(isrow[i],irow+i);CHKERRQ(ierr);
ierr = ISRestoreIndices(iscol[i],icol+i);CHKERRQ(ierr);
}
/* Destroy allocated memory */
ierr = PetscFree5(irow,icol,nrow,ncol,rtable);CHKERRQ(ierr);
ierr = PetscFree3(w1,w3,w4);CHKERRQ(ierr);
ierr = PetscFree(pa);CHKERRQ(ierr);
for (i=0; i<nrqs; ++i) {
ierr = PetscFree(rbuf2[i]);CHKERRQ(ierr);
}
ierr = PetscFree(rbuf2);CHKERRQ(ierr);
ierr = PetscFree4(sbuf1,ptr,tmp,ctr);CHKERRQ(ierr);
ierr = PetscFree(rbuf1[0]);CHKERRQ(ierr);
ierr = PetscFree(rbuf1);CHKERRQ(ierr);
for (i=0; i<nrqr; ++i) {
ierr = PetscFree(sbuf2[i]);CHKERRQ(ierr);
}
ierr = PetscFree(sbuf2);CHKERRQ(ierr);
ierr = PetscFree(rmap[0]);CHKERRQ(ierr);
ierr = PetscFree(rmap);CHKERRQ(ierr);
for (i=0; i<ismax; i++) {
ierr = MatAssemblyBegin(submats[i],MAT_FINAL_ASSEMBLY);CHKERRQ(ierr);
ierr = MatAssemblyEnd(submats[i],MAT_FINAL_ASSEMBLY);CHKERRQ(ierr);
}
PetscFunctionReturn(0);
}
PetscErrorCode MCJPInitialLocalColor_Private(MatColoring mc,PetscInt *lperm,ISColoringValue *colors)
{
PetscInt j,i,s,e,n,bidx,cidx,idx,dist,distance=mc->dist;
Mat G=mc->mat,dG,oG;
PetscErrorCode ierr;
PetscInt *seen;
PetscInt *idxbuf;
PetscBool *boundary;
PetscInt *distbuf;
PetscInt *colormask;
PetscInt ncols;
const PetscInt *cols;
PetscBool isSeq,isMPI;
Mat_MPIAIJ *aij;
Mat_SeqAIJ *daij,*oaij;
PetscInt *di,*dj,dn;
PetscInt *oi;
PetscFunctionBegin;
ierr = PetscLogEventBegin(Mat_Coloring_Local,mc,0,0,0);CHKERRQ(ierr);
ierr = MatGetOwnershipRange(G,&s,&e);CHKERRQ(ierr);
n=e-s;
ierr = PetscObjectTypeCompare((PetscObject)G,MATSEQAIJ,&isSeq);CHKERRQ(ierr);
ierr = PetscObjectTypeCompare((PetscObject)G,MATMPIAIJ,&isMPI);CHKERRQ(ierr);
if (!isSeq && !isMPI) SETERRQ(PetscObjectComm((PetscObject)G),PETSC_ERR_ARG_WRONGSTATE,"MatColoringDegrees requires an MPI/SEQAIJ Matrix");
/* get the inner matrix structure */
oG = NULL;
oi = NULL;
if (isMPI) {
aij = (Mat_MPIAIJ*)G->data;
dG = aij->A;
oG = aij->B;
daij = (Mat_SeqAIJ*)dG->data;
oaij = (Mat_SeqAIJ*)oG->data;
di = daij->i;
dj = daij->j;
oi = oaij->i;
ierr = MatGetSize(oG,&dn,NULL);CHKERRQ(ierr);
} else {
dG = G;
ierr = MatGetSize(dG,NULL,&dn);CHKERRQ(ierr);
daij = (Mat_SeqAIJ*)dG->data;
di = daij->i;
dj = daij->j;
}
ierr = PetscMalloc5(n,&colormask,n,&seen,n,&idxbuf,n,&distbuf,n,&boundary);CHKERRQ(ierr);
for (i=0;i<dn;i++) {
seen[i]=-1;
colormask[i] = -1;
boundary[i] = PETSC_FALSE;
}
/* pass one -- figure out which ones are off-boundary in the distance-n sense */
if (oG) {
for (i=0;i<dn;i++) {
bidx=-1;
/* nonempty off-diagonal, so this one is on the boundary */
if (oi[i]!=oi[i+1]) {
boundary[i] = PETSC_TRUE;
continue;
}
ncols = di[i+1]-di[i];
cols = &(dj[di[i]]);
for (j=0;j<ncols;j++) {
bidx++;
seen[cols[j]] = i;
distbuf[bidx] = 1;
idxbuf[bidx] = cols[j];
}
while (bidx >= 0) {
idx = idxbuf[bidx];
dist = distbuf[bidx];
bidx--;
if (dist < distance) {
if (oi[idx+1]!=oi[idx]) {
boundary[i] = PETSC_TRUE;
break;
}
ncols = di[idx+1]-di[idx];
cols = &(dj[di[idx]]);
for (j=0;j<ncols;j++) {
if (seen[cols[j]] != i) {
bidx++;
seen[cols[j]] = i;
idxbuf[bidx] = cols[j];
distbuf[bidx] = dist+1;
}
}
}
}
}
for (i=0;i<dn;i++) {
seen[i]=-1;
}
}
/* pass two -- color it by looking at nearby vertices and building a mask */
for (i=0;i<dn;i++) {
cidx = lperm[i];
if (!boundary[cidx]) {
bidx=-1;
ncols = di[cidx+1]-di[cidx];
cols = &(dj[di[cidx]]);
for (j=0;j<ncols;j++) {
bidx++;
seen[cols[j]] = cidx;
distbuf[bidx] = 1;
idxbuf[bidx] = cols[j];
}
while (bidx >= 0) {
idx = idxbuf[bidx];
dist = distbuf[bidx];
bidx--;
/* mask this color */
if (colors[idx] < IS_COLORING_MAX) {
colormask[colors[idx]] = cidx;
}
if (dist < distance) {
ncols = di[idx+1]-di[idx];
cols = &(dj[di[idx]]);
for (j=0;j<ncols;j++) {
if (seen[cols[j]] != cidx) {
bidx++;
seen[cols[j]] = cidx;
idxbuf[bidx] = cols[j];
distbuf[bidx] = dist+1;
}
}
}
}
/* find the lowest untaken color */
for (j=0;j<n;j++) {
if (colormask[j] != cidx || j >= mc->maxcolors) {
colors[cidx] = j;
break;
}
}
}
}
ierr = PetscFree5(colormask,seen,idxbuf,distbuf,boundary);CHKERRQ(ierr);
ierr = PetscLogEventEnd(Mat_Coloring_Local,mc,0,0,0);CHKERRQ(ierr);
PetscFunctionReturn(0);
}
PetscErrorCode DMCoarsen_Plex(DM dm, MPI_Comm comm, DM *dmCoarsened)
{
DM_Plex *mesh = (DM_Plex*) dm->data;
#ifdef PETSC_HAVE_PRAGMATIC
DM udm, coordDM;
DMLabel bd;
Mat A;
Vec coordinates, mb, mx;
PetscSection coordSection;
const PetscScalar *coords;
double *coarseCoords;
IS bdIS;
PetscReal *x, *y, *z, *eqns, *metric;
PetscReal coarseRatio = PetscSqr(0.5);
const PetscInt *faces;
PetscInt *cells, *bdFaces, *bdFaceIds;
PetscInt dim, numCorners, cStart, cEnd, numCells, numCoarseCells, c, vStart, vEnd, numVertices, numCoarseVertices, v, numBdFaces, f, maxConeSize, size, bdSize, coff;
#endif
PetscErrorCode ierr;
PetscFunctionBegin;
#ifdef PETSC_HAVE_PRAGMATIC
if (!mesh->coarseMesh) {
ierr = DMGetDimension(dm, &dim);CHKERRQ(ierr);
ierr = DMGetCoordinateDM(dm, &coordDM);CHKERRQ(ierr);
ierr = DMGetDefaultSection(coordDM, &coordSection);CHKERRQ(ierr);
ierr = DMGetCoordinatesLocal(dm, &coordinates);CHKERRQ(ierr);
ierr = DMPlexGetHeightStratum(dm, 0, &cStart, &cEnd);CHKERRQ(ierr);
ierr = DMPlexGetDepthStratum(dm, 0, &vStart, &vEnd);CHKERRQ(ierr);
ierr = DMPlexUninterpolate(dm, &udm);CHKERRQ(ierr);
ierr = DMPlexGetMaxSizes(udm, &maxConeSize, NULL);CHKERRQ(ierr);
numCells = cEnd - cStart;
numVertices = vEnd - vStart;
ierr = PetscCalloc5(numVertices, &x, numVertices, &y, numVertices, &z, numVertices*PetscSqr(dim), &metric, numCells*maxConeSize, &cells);CHKERRQ(ierr);
ierr = VecGetArrayRead(coordinates, &coords);CHKERRQ(ierr);
for (v = vStart; v < vEnd; ++v) {
PetscInt off;
ierr = PetscSectionGetOffset(coordSection, v, &off);CHKERRQ(ierr);
x[v-vStart] = coords[off+0];
y[v-vStart] = coords[off+1];
if (dim > 2) z[v-vStart] = coords[off+2];
}
ierr = VecRestoreArrayRead(coordinates, &coords);CHKERRQ(ierr);
for (c = 0, coff = 0; c < numCells; ++c) {
const PetscInt *cone;
PetscInt coneSize, cl;
ierr = DMPlexGetConeSize(udm, c, &coneSize);CHKERRQ(ierr);
ierr = DMPlexGetCone(udm, c, &cone);CHKERRQ(ierr);
for (cl = 0; cl < coneSize; ++cl) cells[coff++] = cone[cl] - vStart;
}
switch (dim) {
case 2:
pragmatic_2d_init(&numVertices, &numCells, cells, x, y);
break;
case 3:
pragmatic_3d_init(&numVertices, &numCells, cells, x, y, z);
break;
default:
SETERRQ1(PetscObjectComm((PetscObject) dm), PETSC_ERR_ARG_OUTOFRANGE, "No Pragmatic coarsening defined for dimension %d", dim);
}
/* Create boundary mesh */
ierr = DMLabelCreate("boundary", &bd);CHKERRQ(ierr);
ierr = DMPlexMarkBoundaryFaces(dm, bd);CHKERRQ(ierr);
ierr = DMLabelGetStratumIS(bd, 1, &bdIS);CHKERRQ(ierr);
ierr = DMLabelGetStratumSize(bd, 1, &numBdFaces);CHKERRQ(ierr);
ierr = ISGetIndices(bdIS, &faces);CHKERRQ(ierr);
for (f = 0, bdSize = 0; f < numBdFaces; ++f) {
PetscInt *closure = NULL;
PetscInt closureSize, cl;
ierr = DMPlexGetTransitiveClosure(dm, faces[f], PETSC_TRUE, &closureSize, &closure);CHKERRQ(ierr);
for (cl = 0; cl < closureSize*2; cl += 2) {
if ((closure[cl] >= vStart) && (closure[cl] < vEnd)) ++bdSize;
}
ierr = DMPlexRestoreTransitiveClosure(dm, f, PETSC_TRUE, &closureSize, &closure);CHKERRQ(ierr);
}
ierr = PetscMalloc2(bdSize, &bdFaces, numBdFaces, &bdFaceIds);CHKERRQ(ierr);
for (f = 0, bdSize = 0; f < numBdFaces; ++f) {
PetscInt *closure = NULL;
PetscInt closureSize, cl;
ierr = DMPlexGetTransitiveClosure(dm, faces[f], PETSC_TRUE, &closureSize, &closure);CHKERRQ(ierr);
for (cl = 0; cl < closureSize*2; cl += 2) {
if ((closure[cl] >= vStart) && (closure[cl] < vEnd)) bdFaces[bdSize++] = closure[cl] - vStart;
}
/* TODO Fix */
bdFaceIds[f] = 1;
ierr = DMPlexRestoreTransitiveClosure(dm, f, PETSC_TRUE, &closureSize, &closure);CHKERRQ(ierr);
}
ierr = ISDestroy(&bdIS);CHKERRQ(ierr);
ierr = DMLabelDestroy(&bd);CHKERRQ(ierr);
pragmatic_set_boundary(&numBdFaces, bdFaces, bdFaceIds);
/* Create metric */
size = (dim*(dim+1))/2;
ierr = PetscMalloc1(PetscSqr(size), &eqns);CHKERRQ(ierr);
ierr = MatCreateSeqDense(PETSC_COMM_SELF, size, size, eqns, &A);CHKERRQ(ierr);
ierr = MatCreateVecs(A, &mx, &mb);CHKERRQ(ierr);
ierr = VecSet(mb, 1.0);CHKERRQ(ierr);
for (c = 0; c < numCells; ++c) {
const PetscScalar *sol;
PetscScalar *cellCoords = NULL;
PetscReal e[3], vol;
const PetscInt *cone;
PetscInt coneSize, cl, i, j, d, r;
ierr = DMPlexVecGetClosure(dm, coordSection, coordinates, c, NULL, &cellCoords);CHKERRQ(ierr);
/* Only works for simplices */
for (i = 0, r = 0; i < dim+1; ++i) {
for (j = 0; j < i; ++j, ++r) {
for (d = 0; d < dim; ++d) e[d] = cellCoords[i*dim+d] - cellCoords[j*dim+d];
/* FORTRAN ORDERING */
if (dim == 2) {
eqns[0*size+r] = PetscSqr(e[0]);
eqns[1*size+r] = 2.0*e[0]*e[1];
eqns[2*size+r] = PetscSqr(e[1]);
} else {
eqns[0*size+r] = PetscSqr(e[0]);
eqns[1*size+r] = 2.0*e[0]*e[1];
eqns[2*size+r] = 2.0*e[0]*e[2];
eqns[3*size+r] = PetscSqr(e[1]);
eqns[4*size+r] = 2.0*e[1]*e[2];
eqns[5*size+r] = PetscSqr(e[2]);
}
}
}
ierr = MatSetUnfactored(A);CHKERRQ(ierr);
ierr = DMPlexVecRestoreClosure(dm, coordSection, coordinates, c, NULL, &cellCoords);CHKERRQ(ierr);
ierr = MatLUFactor(A, NULL, NULL, NULL);CHKERRQ(ierr);
ierr = MatSolve(A, mb, mx);CHKERRQ(ierr);
ierr = VecGetArrayRead(mx, &sol);CHKERRQ(ierr);
ierr = DMPlexComputeCellGeometryFVM(dm, c, &vol, NULL, NULL);CHKERRQ(ierr);
ierr = DMPlexGetCone(udm, c, &cone);CHKERRQ(ierr);
ierr = DMPlexGetConeSize(udm, c, &coneSize);CHKERRQ(ierr);
for (cl = 0; cl < coneSize; ++cl) {
const PetscInt v = cone[cl] - vStart;
if (dim == 2) {
metric[v*4+0] += vol*coarseRatio*sol[0];
metric[v*4+1] += vol*coarseRatio*sol[1];
metric[v*4+2] += vol*coarseRatio*sol[1];
metric[v*4+3] += vol*coarseRatio*sol[2];
} else {
metric[v*9+0] += vol*coarseRatio*sol[0];
metric[v*9+1] += vol*coarseRatio*sol[1];
metric[v*9+3] += vol*coarseRatio*sol[1];
metric[v*9+2] += vol*coarseRatio*sol[2];
metric[v*9+6] += vol*coarseRatio*sol[2];
metric[v*9+4] += vol*coarseRatio*sol[3];
metric[v*9+5] += vol*coarseRatio*sol[4];
metric[v*9+7] += vol*coarseRatio*sol[4];
metric[v*9+8] += vol*coarseRatio*sol[5];
}
}
ierr = VecRestoreArrayRead(mx, &sol);CHKERRQ(ierr);
}
for (v = 0; v < numVertices; ++v) {
const PetscInt *support;
PetscInt supportSize, s;
PetscReal vol, totVol = 0.0;
ierr = DMPlexGetSupport(udm, v+vStart, &support);CHKERRQ(ierr);
ierr = DMPlexGetSupportSize(udm, v+vStart, &supportSize);CHKERRQ(ierr);
for (s = 0; s < supportSize; ++s) {ierr = DMPlexComputeCellGeometryFVM(dm, support[s], &vol, NULL, NULL);CHKERRQ(ierr); totVol += vol;}
for (s = 0; s < PetscSqr(dim); ++s) metric[v*PetscSqr(dim)+s] /= totVol;
}
ierr = VecDestroy(&mx);CHKERRQ(ierr);
ierr = VecDestroy(&mb);CHKERRQ(ierr);
ierr = MatDestroy(&A);CHKERRQ(ierr);
ierr = DMDestroy(&udm);CHKERRQ(ierr);
ierr = PetscFree(eqns);CHKERRQ(ierr);
pragmatic_set_metric(metric);
pragmatic_adapt();
/* Read out mesh */
pragmatic_get_info(&numCoarseVertices, &numCoarseCells);
ierr = PetscMalloc1(numCoarseVertices*dim, &coarseCoords);CHKERRQ(ierr);
switch (dim) {
case 2:
pragmatic_get_coords_2d(x, y);
numCorners = 3;
for (v = 0; v < numCoarseVertices; ++v) {coarseCoords[v*2+0] = x[v]; coarseCoords[v*2+1] = y[v];}
break;
case 3:
pragmatic_get_coords_3d(x, y, z);
numCorners = 4;
for (v = 0; v < numCoarseVertices; ++v) {coarseCoords[v*3+0] = x[v]; coarseCoords[v*3+1] = y[v]; coarseCoords[v*3+2] = z[v];}
break;
default:
SETERRQ1(PetscObjectComm((PetscObject) dm), PETSC_ERR_ARG_OUTOFRANGE, "No Pragmatic coarsening defined for dimension %d", dim);
}
pragmatic_get_elements(cells);
/* TODO Read out markers for boundary */
ierr = DMPlexCreateFromCellList(PetscObjectComm((PetscObject) dm), dim, numCoarseCells, numCoarseVertices, numCorners, PETSC_TRUE, cells, dim, coarseCoords, &mesh->coarseMesh);CHKERRQ(ierr);
pragmatic_finalize();
ierr = PetscFree5(x, y, z, metric, cells);CHKERRQ(ierr);
ierr = PetscFree2(bdFaces, bdFaceIds);CHKERRQ(ierr);
ierr = PetscFree(coarseCoords);CHKERRQ(ierr);
}
#endif
ierr = PetscObjectReference((PetscObject) mesh->coarseMesh);CHKERRQ(ierr);
*dmCoarsened = mesh->coarseMesh;
PetscFunctionReturn(0);
}
