static PetscErrorCode TSAdjointStep_RK(TS ts)
{
TS_RK *rk = (TS_RK*)ts->data;
RKTableau tab = rk->tableau;
const PetscInt s = tab->s;
const PetscReal *A = tab->A,*b = tab->b,*c = tab->c;
PetscScalar *w = rk->work;
Vec *Y = rk->Y,*VecDeltaLam = rk->VecDeltaLam,*VecDeltaMu = rk->VecDeltaMu,*VecSensiTemp = rk->VecSensiTemp;
PetscInt i,j,nadj;
PetscReal t;
PetscErrorCode ierr;
PetscReal h = ts->time_step;
Mat J,Jp;
PetscFunctionBegin;
t = ts->ptime;
rk->status = TS_STEP_INCOMPLETE;
h = ts->time_step;
ierr = TSPreStep(ts);CHKERRQ(ierr);
for (i=s-1; i>=0; i--) {
rk->stage_time = t + h*(1.0-c[i]);
for (nadj=0; nadj<ts->numcost; nadj++) {
ierr = VecCopy(ts->vecs_sensi[nadj],VecSensiTemp[nadj]);CHKERRQ(ierr);
ierr = VecScale(VecSensiTemp[nadj],-h*b[i]);
for (j=i+1; j<s; j++) {
ierr = VecAXPY(VecSensiTemp[nadj],-h*A[j*s+i],VecDeltaLam[nadj*s+j]);
}
}
/* Stage values of lambda */
ierr = TSGetRHSJacobian(ts,&J,&Jp,NULL,NULL);CHKERRQ(ierr);
ierr = TSComputeRHSJacobian(ts,rk->stage_time,Y[i],J,Jp);CHKERRQ(ierr);
for (nadj=0; nadj<ts->numcost; nadj++) {
ierr = MatMultTranspose(J,VecSensiTemp[nadj],VecDeltaLam[nadj*s+i]);CHKERRQ(ierr);
}
/* Stage values of mu */
if(ts->vecs_sensip) {
ierr = TSAdjointComputeRHSJacobian(ts,rk->stage_time,Y[i],ts->Jacp);CHKERRQ(ierr);
for (nadj=0; nadj<ts->numcost; nadj++) {
ierr = MatMultTranspose(ts->Jacp,VecSensiTemp[nadj],VecDeltaMu[nadj*s+i]);CHKERRQ(ierr);
}
}
}
for (j=0; j<s; j++) w[j] = 1.0;
for (nadj=0; nadj<ts->numcost; nadj++) {
ierr = VecMAXPY(ts->vecs_sensi[nadj],s,w,&VecDeltaLam[nadj*s]);CHKERRQ(ierr);
if(ts->vecs_sensip) {
ierr = VecMAXPY(ts->vecs_sensip[nadj],s,w,&VecDeltaMu[nadj*s]);CHKERRQ(ierr);
}
}
ts->ptime += ts->time_step;
ts->steps++;
rk->status = TS_STEP_COMPLETE;
PetscFunctionReturn(0);
}
/*
X - initial state, updated in-place.
F - residual, computed at the initial X on input
*/
static PetscErrorCode SNESMSStep_3Sstar(SNES snes,Vec X,Vec F)
{
PetscErrorCode ierr;
SNES_MS *ms = (SNES_MS*)snes->data;
SNESMSTableau t = ms->tableau;
const PetscReal *gamma = t->gamma,*delta = t->delta,*betasub = t->betasub;
Vec S1,S2,S3,Y;
PetscInt i,nstages = t->nstages;;
PetscFunctionBegin;
Y = snes->work[0];
S1 = X;
S2 = snes->work[1];
S3 = snes->work[2];
ierr = VecZeroEntries(S2);CHKERRQ(ierr);
ierr = VecCopy(X,S3);CHKERRQ(ierr);
for (i=0; i<nstages; i++) {
Vec Ss[4] = {S1,S2,S3,Y};
PetscScalar scoeff[4] = {gamma[0*nstages+i]-1.0,gamma[1*nstages+i],gamma[2*nstages+i],-betasub[i]*ms->damping};
ierr = VecAXPY(S2,delta[i],S1);CHKERRQ(ierr);
if (i>0) {
ierr = SNESComputeFunction(snes,S1,F);CHKERRQ(ierr);
if (snes->domainerror) {
snes->reason = SNES_DIVERGED_FUNCTION_DOMAIN;
PetscFunctionReturn(0);
}
}
ierr = SNES_KSPSolve(snes,snes->ksp,F,Y);CHKERRQ(ierr);
ierr = VecMAXPY(S1,4,scoeff,Ss);CHKERRQ(ierr);
}
PetscFunctionReturn(0);
}
static PetscErrorCode TSEvaluateWLTE_Theta(TS ts,NormType wnormtype,PetscInt *order,PetscReal *wlte)
{
TS_Theta *th = (TS_Theta*)ts->data;
Vec X = ts->vec_sol; /* X = solution */
Vec Y = th->vec_lte_work; /* Y = X + LTE */
PetscReal wltea,wlter;
PetscErrorCode ierr;
PetscFunctionBegin;
/* Cannot compute LTE in first step or in restart after event */
if (ts->steprestart) {*wlte = -1; PetscFunctionReturn(0);}
/* Compute LTE using backward differences with non-constant time step */
{
PetscReal h = ts->time_step, h_prev = ts->ptime - ts->ptime_prev;
PetscReal a = 1 + h_prev/h;
PetscScalar scal[3]; Vec vecs[3];
scal[0] = +1/a; scal[1] = -1/(a-1); scal[2] = +1/(a*(a-1));
vecs[0] = X; vecs[1] = th->X0; vecs[2] = th->vec_sol_prev;
ierr = VecCopy(X,Y);CHKERRQ(ierr);
ierr = VecMAXPY(Y,3,scal,vecs);CHKERRQ(ierr);
ierr = TSErrorWeightedNorm(ts,X,Y,wnormtype,wlte,&wltea,&wlter);CHKERRQ(ierr);
}
if (order) *order = 2;
PetscFunctionReturn(0);
}
static PetscErrorCode TSRollBack_RK(TS ts)
{
TS_RK *rk = (TS_RK*)ts->data;
RKTableau tab = rk->tableau;
const PetscInt s = tab->s;
const PetscReal *b = tab->b;
PetscScalar *w = rk->work;
Vec *YdotRHS = rk->YdotRHS;
PetscInt j;
PetscReal h;
PetscErrorCode ierr;
PetscFunctionBegin;
switch (rk->status) {
case TS_STEP_INCOMPLETE:
case TS_STEP_PENDING:
h = ts->time_step; break;
case TS_STEP_COMPLETE:
h = ts->ptime - ts->ptime_prev; break;
default: SETERRQ(PetscObjectComm((PetscObject)ts),PETSC_ERR_PLIB,"Invalid TSStepStatus");
}
for (j=0; j<s; j++) w[j] = -h*b[j];
ierr = VecMAXPY(ts->vec_sol,s,w,YdotRHS);CHKERRQ(ierr);
PetscFunctionReturn(0);
}
/*@C
MatNullSpaceRemove - Removes all the components of a null space from a vector.
Collective on MatNullSpace
Input Parameters:
+ sp - the null space context (if this is NULL then no null space is removed)
- vec - the vector from which the null space is to be removed
Level: advanced
.keywords: PC, null space, remove
.seealso: MatNullSpaceCreate(), MatNullSpaceDestroy(), MatNullSpaceSetFunction()
@*/
PetscErrorCode MatNullSpaceRemove(MatNullSpace sp,Vec vec)
{
PetscScalar sum;
PetscInt i,N;
PetscErrorCode ierr;
PetscFunctionBegin;
if (!sp) PetscFunctionReturn(0);
PetscValidHeaderSpecific(sp,MAT_NULLSPACE_CLASSID,1);
PetscValidHeaderSpecific(vec,VEC_CLASSID,2);
if (sp->has_cnst) {
ierr = VecGetSize(vec,&N);CHKERRQ(ierr);
if (N > 0) {
ierr = VecSum(vec,&sum);CHKERRQ(ierr);
sum = sum/((PetscScalar)(-1.0*N));
ierr = VecShift(vec,sum);CHKERRQ(ierr);
}
}
if (sp->n) {
ierr = VecMDot(vec,sp->n,sp->vecs,sp->alpha);CHKERRQ(ierr);
for (i=0; i<sp->n; i++) sp->alpha[i] = -sp->alpha[i];
ierr = VecMAXPY(vec,sp->n,sp->alpha,sp->vecs);CHKERRQ(ierr);
}
if (sp->remove) {
ierr = (*sp->remove)(sp,vec,sp->rmctx);CHKERRQ(ierr);
}
PetscFunctionReturn(0);
}
/*
The step completion formula is
x1 = x0 + h b^T YdotRHS
This function can be called before or after ts->vec_sol has been updated.
Suppose we have a completion formula (b) and an embedded formula (be) of different order.
We can write
x1e = x0 + h be^T YdotRHS
= x1 - h b^T YdotRHS + h be^T YdotRHS
= x1 + h (be - b)^T YdotRHS
so we can evaluate the method with different order even after the step has been optimistically completed.
*/
static PetscErrorCode TSEvaluateStep_RK(TS ts,PetscInt order,Vec X,PetscBool *done)
{
TS_RK *rk = (TS_RK*)ts->data;
RKTableau tab = rk->tableau;
PetscScalar *w = rk->work;
PetscReal h;
PetscInt s = tab->s,j;
PetscErrorCode ierr;
PetscFunctionBegin;
switch (rk->status) {
case TS_STEP_INCOMPLETE:
case TS_STEP_PENDING:
h = ts->time_step; break;
case TS_STEP_COMPLETE:
h = ts->ptime - ts->ptime_prev; break;
default: SETERRQ(PetscObjectComm((PetscObject)ts),PETSC_ERR_PLIB,"Invalid TSStepStatus");
}
if (order == tab->order) {
if (rk->status == TS_STEP_INCOMPLETE) {
ierr = VecCopy(ts->vec_sol,X);CHKERRQ(ierr);
for (j=0; j<s; j++) w[j] = h*tab->b[j];
ierr = VecMAXPY(X,s,w,rk->YdotRHS);CHKERRQ(ierr);
} else {ierr = VecCopy(ts->vec_sol,X);CHKERRQ(ierr);}
PetscFunctionReturn(0);
} else if (order == tab->order-1) {
if (!tab->bembed) goto unavailable;
if (rk->status == TS_STEP_INCOMPLETE) { /* Complete with the embedded method (be) */
ierr = VecCopy(ts->vec_sol,X);CHKERRQ(ierr);
for (j=0; j<s; j++) w[j] = h*tab->bembed[j];
ierr = VecMAXPY(X,s,w,rk->YdotRHS);CHKERRQ(ierr);
} else { /* Rollback and re-complete using (be-b) */
ierr = VecCopy(ts->vec_sol,X);CHKERRQ(ierr);
for (j=0; j<s; j++) w[j] = h*(tab->bembed[j] - tab->b[j]);
ierr = VecMAXPY(X,s,w,rk->YdotRHS);CHKERRQ(ierr);
if (ts->vec_costintegral && ts->costintegralfwd) {
ierr = VecCopy(rk->VecCostIntegral0,ts->vec_costintegral);CHKERRQ(ierr);
}
}
if (done) *done = PETSC_TRUE;
PetscFunctionReturn(0);
}
unavailable:
if (done) *done = PETSC_FALSE;
else SETERRQ3(PetscObjectComm((PetscObject)ts),PETSC_ERR_SUP,"RK '%s' of order %D cannot evaluate step at order %D. Consider using -ts_adapt_type none or a different method that has an embedded estimate.",tab->name,tab->order,order);
PetscFunctionReturn(0);
}
static PetscErrorCode TSEvaluateWLTE_Alpha(TS ts,NormType wnormtype,PetscInt *order,PetscReal *wlte)
{
TS_Alpha *th = (TS_Alpha*)ts->data;
Vec X = th->X1; /* X = solution */
Vec V = th->V1; /* V = solution */
Vec Y = th->vec_lte_work[0]; /* Y = X + LTE */
Vec Z = th->vec_lte_work[1]; /* Z = V + LTE */
PetscReal enormX,enormV;
PetscErrorCode ierr;
PetscFunctionBegin;
if (ts->steprestart) {
/* th->vec_{sol|dot}_prev is set to the LTE in TSAlpha_Restart() */
ierr = VecAXPY(Y,1,X);CHKERRQ(ierr);
ierr = VecAXPY(Z,1,V);CHKERRQ(ierr);
} else {
/* Compute LTE using backward differences with non-constant time step */
PetscReal h = ts->time_step, h_prev = ts->ptime - ts->ptime_prev;
PetscReal a = 1 + h_prev/h;
PetscScalar scal[3]; Vec vecX[3],vecV[3];
scal[0] = +1/a; scal[1] = -1/(a-1); scal[2] = +1/(a*(a-1));
vecX[0] = th->X1; vecX[1] = th->X0; vecX[2] = th->vec_sol_prev;
vecV[0] = th->V1; vecV[1] = th->V0; vecV[2] = th->vec_dot_prev;
ierr = VecCopy(X,Y);CHKERRQ(ierr);
ierr = VecMAXPY(Y,3,scal,vecX);CHKERRQ(ierr);
ierr = VecCopy(V,Z);CHKERRQ(ierr);
ierr = VecMAXPY(Z,3,scal,vecV);CHKERRQ(ierr);
}
/* XXX ts->atol and ts->vatol are not appropriate for computing enormV */
ierr = TSErrorWeightedNorm(ts,X,Y,wnormtype,&enormX);CHKERRQ(ierr);
ierr = TSErrorWeightedNorm(ts,V,Z,wnormtype,&enormV);CHKERRQ(ierr);
if (wnormtype == NORM_2)
*wlte = PetscSqrtReal(PetscSqr(enormX)/2 + PetscSqr(enormV)/2);
else
*wlte = PetscMax(enormX,enormV);
if (order) *order = 2;
PetscFunctionReturn(0);
}
PetscErrorCode KSPFischerGuessUpdate_Method1(KSPFischerGuess_Method1 *itg,Vec x)
{
PetscReal norm;
PetscErrorCode ierr;
int curl = itg->curl,i;
PetscFunctionBegin;
PetscValidHeaderSpecific(x,VEC_CLASSID,2);
PetscValidPointer(itg,3);
if (curl == itg->maxl) {
ierr = KSP_MatMult(itg->ksp,itg->mat,x,itg->btilde[0]);CHKERRQ(ierr);
ierr = VecNormalize(itg->btilde[0],&norm);CHKERRQ(ierr);
ierr = VecCopy(x,itg->xtilde[0]);CHKERRQ(ierr);
ierr = VecScale(itg->xtilde[0],1.0/norm);CHKERRQ(ierr);
itg->curl = 1;
} else {
if (!curl) {
ierr = VecCopy(x,itg->xtilde[curl]);CHKERRQ(ierr);
} else {
ierr = VecWAXPY(itg->xtilde[curl],-1.0,itg->guess,x);CHKERRQ(ierr);
}
ierr = KSP_MatMult(itg->ksp,itg->mat,itg->xtilde[curl],itg->btilde[curl]);CHKERRQ(ierr);
ierr = VecMDot(itg->btilde[curl],curl,itg->btilde,itg->alpha);CHKERRQ(ierr);
for (i=0; i<curl; i++) itg->alpha[i] = -itg->alpha[i];
ierr = VecMAXPY(itg->btilde[curl],curl,itg->alpha,itg->btilde);CHKERRQ(ierr);
ierr = VecMAXPY(itg->xtilde[curl],curl,itg->alpha,itg->xtilde);CHKERRQ(ierr);
ierr = VecNormalize(itg->btilde[curl],&norm);CHKERRQ(ierr);
if (norm) {
ierr = VecScale(itg->xtilde[curl],1.0/norm);CHKERRQ(ierr);
itg->curl++;
} else {
ierr = PetscInfo(itg->ksp,"Not increasing dimension of Fischer space because new direction is identical to previous\n");CHKERRQ(ierr);
}
}
PetscFunctionReturn(0);
}
static PetscErrorCode KSPGMRESBuildSoln(PetscScalar *nrs,Vec vs,Vec vdest,KSP ksp,PetscInt it)
{
PetscScalar tt;
PetscErrorCode ierr;
PetscInt ii,k,j;
KSP_GMRES *gmres = (KSP_GMRES*)(ksp->data);
PetscFunctionBegin;
/* Solve for solution vector that minimizes the residual */
/* If it is < 0, no gmres steps have been performed */
if (it < 0) {
ierr = VecCopy(vs,vdest);CHKERRQ(ierr); /* VecCopy() is smart, exists immediately if vguess == vdest */
PetscFunctionReturn(0);
}
if (*HH(it,it) != 0.0) {
nrs[it] = *GRS(it) / *HH(it,it);
} else {
ksp->reason = KSP_DIVERGED_BREAKDOWN;
ierr = PetscInfo2(ksp,"Likely your matrix or preconditioner is singular. HH(it,it) is identically zero; it = %D GRS(it) = %G",it,PetscAbsScalar(*GRS(it)));CHKERRQ(ierr);
PetscFunctionReturn(0);
}
for (ii=1; ii<=it; ii++) {
k = it - ii;
tt = *GRS(k);
for (j=k+1; j<=it; j++) tt = tt - *HH(k,j) * nrs[j];
if (*HH(k,k) == 0.0) {
ksp->reason = KSP_DIVERGED_BREAKDOWN;
ierr = PetscInfo1(ksp,"Likely your matrix or preconditioner is singular. HH(k,k) is identically zero; k = %D",k);CHKERRQ(ierr);
PetscFunctionReturn(0);
}
nrs[k] = tt / *HH(k,k);
}
/* Accumulate the correction to the solution of the preconditioned problem in TEMP */
ierr = VecSet(VEC_TEMP,0.0);CHKERRQ(ierr);
ierr = VecMAXPY(VEC_TEMP,it+1,nrs,&VEC_VV(0));CHKERRQ(ierr);
ierr = KSPUnwindPreconditioner(ksp,VEC_TEMP,VEC_TEMP_MATOP);CHKERRQ(ierr);
/* add solution to previous solution */
if (vdest != vs) {
ierr = VecCopy(vs,vdest);CHKERRQ(ierr);
}
ierr = VecAXPY(vdest,1.0,VEC_TEMP);CHKERRQ(ierr);
PetscFunctionReturn(0);
}
static PetscErrorCode KSPFGMRESBuildSoln(PetscScalar *nrs,Vec vguess,Vec vdest,KSP ksp,PetscInt it)
{
PetscScalar tt;
PetscErrorCode ierr;
PetscInt ii,k,j;
KSP_FGMRES *fgmres = (KSP_FGMRES*)(ksp->data);
PetscFunctionBegin;
/* Solve for solution vector that minimizes the residual */
/* If it is < 0, no fgmres steps have been performed */
if (it < 0) {
ierr = VecCopy(vguess,vdest);CHKERRQ(ierr); /* VecCopy() is smart, exists immediately if vguess == vdest */
PetscFunctionReturn(0);
}
/* so fgmres steps HAVE been performed */
/* solve the upper triangular system - RS is the right side and HH is
the upper triangular matrix - put soln in nrs */
if (*HH(it,it) != 0.0) {
nrs[it] = *RS(it) / *HH(it,it);
} else {
nrs[it] = 0.0;
}
for (ii=1; ii<=it; ii++) {
k = it - ii;
tt = *RS(k);
for (j=k+1; j<=it; j++) tt = tt - *HH(k,j) * nrs[j];
nrs[k] = tt / *HH(k,k);
}
/* Accumulate the correction to the soln of the preconditioned prob. in
VEC_TEMP - note that we use the preconditioned vectors */
ierr = VecSet(VEC_TEMP,0.0);CHKERRQ(ierr); /* set VEC_TEMP components to 0 */
ierr = VecMAXPY(VEC_TEMP,it+1,nrs,&PREVEC(0));CHKERRQ(ierr);
/* put updated solution into vdest.*/
if (vdest != vguess) {
ierr = VecCopy(VEC_TEMP,vdest);CHKERRQ(ierr);
ierr = VecAXPY(vdest,1.0,vguess);CHKERRQ(ierr);
} else { /* replace guess with solution */
ierr = VecAXPY(vdest,1.0,VEC_TEMP);CHKERRQ(ierr);
}
PetscFunctionReturn(0);
}
void FETI_Operations::apply_RB_projection(Vec vec_in, Vec vec_out)
{
homemade_assert_msg(m_bNullVecsSet,"Null space vectors not set yet!");
homemade_assert_msg(m_binvRITRIMatSet,"Null space matrices not set yet!");
// vec_out = [ I - RC * (inv_RITRI_mat) * RC^t ] * vec_in
// Declaration of Vecs with size 'm_null_nb_vecs'
Vec dummy_seq_vec;
Vec dummy_seq_vec_bis;
VecCreateSeq(PETSC_COMM_SELF,m_null_nb_vecs,&dummy_seq_vec);
VecZeroEntries(dummy_seq_vec);
VecDuplicate(dummy_seq_vec,&dummy_seq_vec_bis);
// dummy_seq_vec = RC^t * vec_in
// -> All the communications are done here!
PetscScalar *dummy_seq_array;
VecGetArray(dummy_seq_vec,&dummy_seq_array);
VecMDot(vec_in,m_null_nb_vecs,m_null_coupled_vecs,dummy_seq_array);
VecRestoreArray(dummy_seq_vec,&dummy_seq_array);
// dummy_seq_vec_bis = - inv_RITRI_mat * dummy_seq_vec
// -> Calculate dummy_seq_vec_bis on the first proc, and then broadcast the value
/*
* Originally, this operation was done locally, but due to a syncing issue,
* we have to do it this way to avoid a "Value must the same in all processors" error
* when calling VecMAXPY below.
*/
PETSC_MatMultScale_Bcast(m_inv_RITRI_mat,dummy_seq_vec,dummy_seq_vec_bis,-1);
m_comm.barrier();
// vec_out = vec_in + sum ( dummy_seq_vec_bis[i] * vec_RC[i])
// -> This should have no communications at all!
VecCopy(vec_in,vec_out);
VecGetArray(dummy_seq_vec_bis,&dummy_seq_array);
VecMAXPY(vec_out,m_null_nb_vecs,dummy_seq_array,m_null_coupled_vecs);
VecRestoreArray(dummy_seq_vec_bis,&dummy_seq_array);
// Cleanup
VecDestroy(&dummy_seq_vec);
VecDestroy(&dummy_seq_vec_bis);
}
static PetscErrorCode TSInterpolate_RK(TS ts,PetscReal itime,Vec X)
{
TS_RK *rk = (TS_RK*)ts->data;
PetscInt s = rk->tableau->s,pinterp = rk->tableau->pinterp,i,j;
PetscReal h;
PetscReal tt,t;
PetscScalar *b;
const PetscReal *B = rk->tableau->binterp;
PetscErrorCode ierr;
PetscFunctionBegin;
if (!B) SETERRQ1(PetscObjectComm((PetscObject)ts),PETSC_ERR_SUP,"TSRK %s does not have an interpolation formula",rk->tableau->name);
switch (rk->status) {
case TS_STEP_INCOMPLETE:
case TS_STEP_PENDING:
h = ts->time_step;
t = (itime - ts->ptime)/h;
break;
case TS_STEP_COMPLETE:
h = ts->ptime - ts->ptime_prev;
t = (itime - ts->ptime)/h + 1; /* In the interval [0,1] */
break;
default: SETERRQ(PetscObjectComm((PetscObject)ts),PETSC_ERR_PLIB,"Invalid TSStepStatus");
}
ierr = PetscMalloc1(s,&b);CHKERRQ(ierr);
for (i=0; i<s; i++) b[i] = 0;
for (j=0,tt=t; j<pinterp; j++,tt*=t) {
for (i=0; i<s; i++) {
b[i] += h * B[i*pinterp+j] * tt;
}
}
ierr = VecCopy(rk->Y[0],X);CHKERRQ(ierr);
ierr = VecMAXPY(X,s,b,rk->YdotRHS);CHKERRQ(ierr);
ierr = PetscFree(b);CHKERRQ(ierr);
PetscFunctionReturn(0);
}
PetscErrorCode KSPFischerGuessFormGuess_Method1(KSPFischerGuess_Method1 *itg,Vec b,Vec x)
{
PetscErrorCode ierr;
PetscInt i;
PetscFunctionBegin;
PetscValidPointer(itg,2);
PetscValidHeaderSpecific(x,VEC_CLASSID,3);
ierr = VecSet(x,0.0);CHKERRQ(ierr);
ierr = VecMDot(b,itg->curl,itg->btilde,itg->alpha);CHKERRQ(ierr);
if (itg->monitor) {
ierr = PetscPrintf(((PetscObject)itg->ksp)->comm,"KSPFischerGuess alphas = ");CHKERRQ(ierr);
for (i=0; i<itg->curl; i++) {
ierr = PetscPrintf(((PetscObject)itg->ksp)->comm,"%g ",(double)PetscAbsScalar(itg->alpha[i]));CHKERRQ(ierr);
}
ierr = PetscPrintf(((PetscObject)itg->ksp)->comm,"\n");CHKERRQ(ierr);
}
ierr = VecMAXPY(x,itg->curl,itg->alpha,itg->xtilde);CHKERRQ(ierr);
ierr = VecCopy(x,itg->guess);CHKERRQ(ierr);
/* Note: do not change the b right hand side as is done in the publication */
PetscFunctionReturn(0);
}
static PetscErrorCode KSPPGMRESBuildSoln(PetscScalar *nrs,Vec vguess,Vec vdest,KSP ksp,PetscInt it)
{
PetscScalar tt;
PetscErrorCode ierr;
PetscInt k,j;
KSP_PGMRES *pgmres = (KSP_PGMRES*)(ksp->data);
PetscFunctionBegin;
/* Solve for solution vector that minimizes the residual */
if (it < 0) { /* no pgmres steps have been performed */
ierr = VecCopy(vguess,vdest);CHKERRQ(ierr); /* VecCopy() is smart, exits immediately if vguess == vdest */
PetscFunctionReturn(0);
}
/* solve the upper triangular system - RS is the right side and HH is
the upper triangular matrix - put soln in nrs */
if (*HH(it,it) != 0.0) nrs[it] = *RS(it) / *HH(it,it);
else nrs[it] = 0.0;
for (k=it-1; k>=0; k--) {
tt = *RS(k);
for (j=k+1; j<=it; j++) tt -= *HH(k,j) * nrs[j];
nrs[k] = tt / *HH(k,k);
}
/* Accumulate the correction to the solution of the preconditioned problem in TEMP */
ierr = VecZeroEntries(VEC_TEMP);CHKERRQ(ierr);
ierr = VecMAXPY(VEC_TEMP,it+1,nrs,&VEC_VV(0));CHKERRQ(ierr);
ierr = KSPUnwindPreconditioner(ksp,VEC_TEMP,VEC_TEMP_MATOP);CHKERRQ(ierr);
/* add solution to previous solution */
if (vdest == vguess) {
ierr = VecAXPY(vdest,1.0,VEC_TEMP);CHKERRQ(ierr);
} else {
ierr = VecWAXPY(vdest,1.0,VEC_TEMP,vguess);CHKERRQ(ierr);
}
PetscFunctionReturn(0);
}
/*
X - initial state, updated in-place.
F - residual, computed at the initial X on input
*/
static PetscErrorCode SNESMSStep_3Sstar(SNES snes,Vec X,Vec F)
{
PetscErrorCode ierr;
SNES_MS *ms = (SNES_MS*)snes->data;
SNESMSTableau t = ms->tableau;
const PetscReal *gamma = t->gamma,*delta = t->delta,*betasub = t->betasub;
Vec S1,S2,S3,Y;
PetscInt i,nstages = t->nstages;;
PetscFunctionBegin;
Y = snes->work[0];
S1 = X;
S2 = snes->work[1];
S3 = snes->work[2];
ierr = VecZeroEntries(S2);CHKERRQ(ierr);
ierr = VecCopy(X,S3);CHKERRQ(ierr);
for (i=0; i<nstages; i++) {
Vec Ss[4];
PetscScalar scoeff[4];
Ss[0] = S1; Ss[1] = S2; Ss[2] = S3; Ss[3] = Y;
scoeff[0] = gamma[0*nstages+i]-(PetscReal)1.0;
scoeff[1] = gamma[1*nstages+i];
scoeff[2] = gamma[2*nstages+i];
scoeff[3] = -betasub[i]*ms->damping;
ierr = VecAXPY(S2,delta[i],S1);CHKERRQ(ierr);
if (i>0) {
ierr = SNESComputeFunction(snes,S1,F);CHKERRQ(ierr);
}
ierr = KSPSolve(snes->ksp,F,Y);CHKERRQ(ierr);
ierr = VecMAXPY(S1,4,scoeff,Ss);CHKERRQ(ierr);
}
PetscFunctionReturn(0);
}
PetscErrorCode interpTimeDependentVector(PetscScalar tc, Vec *u, PetscInt numTracers,
PetscInt nt, PetscScalar *t, Vec **ut)
{
PetscInt itf, itr;
PetscErrorCode ierr;
PetscScalar alpha[2];
PetscScalar zero=0.0;
for (itr=0; itr<numTracers; itr++) {
ierr = VecSet(u[itr],zero); CHKERRQ(ierr);
}
if (tc>=t[0]) {
ierr = calcInterpFactor(nt,tc,t,&itf,&alpha[0]); CHKERRQ(ierr);
alpha[1]=1.0-alpha[0];
for (itr=0; itr<numTracers; itr++) {
VecMAXPY(u[itr],2,alpha,&ut[itr][itf]);
}
} else {
ierr = PetscPrintf(PETSC_COMM_WORLD,"Warning: time < %10.5f. Assuming u=0\n", t[0]);CHKERRQ(ierr);
}
return 0;
}
PetscErrorCode KSPSolve_GCR_cycle( KSP ksp )
{
KSP_GCR *ctx = (KSP_GCR*)ksp->data;
PetscErrorCode ierr;
PetscScalar r_dot_v;
Mat A, B;
PC pc;
Vec s,v,r;
PetscReal norm_r,nrm;
PetscInt k, i, restart;
Vec x;
PetscReal res;
PetscFunctionBegin;
restart = ctx->restart;
ierr = KSPGetPC( ksp, &pc );CHKERRQ(ierr);
ierr = KSPGetOperators( ksp, &A, &B, 0 );CHKERRQ(ierr);
x = ksp->vec_sol;
r = ctx->R;
for ( k=0; k<restart; k++ ) {
v = ctx->VV[k];
s = ctx->SS[k];
if (ctx->modifypc) {
ierr = (*ctx->modifypc)(ksp,ksp->its,ksp->rnorm,ctx->modifypc_ctx);CHKERRQ(ierr);
}
ierr = PCApply( pc, r, s );CHKERRQ(ierr); /* s = B^{-1} r */
ierr = MatMult( A, s, v );CHKERRQ(ierr); /* v = A s */
ierr = VecMDot( v,k, ctx->VV, ctx->val );CHKERRQ(ierr);
for (i=0; i<k; i++) ctx->val[i] = -ctx->val[i];
ierr = VecMAXPY(v,k,ctx->val,ctx->VV);CHKERRQ(ierr); /* v = v - sum_{i=0}^{k-1} alpha_i v_i */
ierr = VecMAXPY(s,k,ctx->val,ctx->SS);CHKERRQ(ierr); /* s = s - sum_{i=0}^{k-1} alpha_i s_i */
ierr = VecDotNorm2(r,v,&r_dot_v,&nrm);CHKERRQ(ierr);
nrm = PetscSqrtReal(nrm);
r_dot_v = r_dot_v/nrm;
ierr = VecScale( v, 1.0/nrm );CHKERRQ(ierr);
ierr = VecScale( s, 1.0/nrm );CHKERRQ(ierr);
ierr = VecAXPY( x, r_dot_v, s );CHKERRQ(ierr);
ierr = VecAXPY( r, -r_dot_v, v );CHKERRQ(ierr);
if (ksp->its > ksp->chknorm ) {
ierr = VecNorm( r, NORM_2, &norm_r );CHKERRQ(ierr);
}
/* update the local counter and the global counter */
ksp->its++;
res = norm_r;
ksp->rnorm = res;
KSPLogResidualHistory(ksp,res);
ierr = KSPMonitor(ksp,ksp->its,res);CHKERRQ(ierr);
if ( ksp->its > ksp->chknorm ) {
ierr = (*ksp->converged)(ksp,ksp->its,res,&ksp->reason,ksp->cnvP);CHKERRQ(ierr);
if (ksp->reason) break;
}
if ( ksp->its >= ksp->max_it ) {
ksp->reason = KSP_CONVERGED_ITS;
break;
}
}
ctx->n_restarts++;
PetscFunctionReturn(0);
}
int main(int argc,char **argv)
{
Vec x,y,w; /* vectors */
Vec *z; /* array of vectors */
PetscReal norm,v,v1,v2,maxval;
PetscInt n = 20,maxind;
PetscErrorCode ierr;
PetscScalar one = 1.0,two = 2.0,three = 3.0,dots[3],dot;
ierr = PetscInitialize(&argc,&argv,(char*)0,help);if (ierr) return ierr;
ierr = PetscOptionsGetInt(NULL,NULL,"-n",&n,NULL);CHKERRQ(ierr);
/*
Create a vector, specifying only its global dimension.
When using VecCreate(), VecSetSizes() and VecSetFromOptions(), the vector format
(currently parallel, shared, or sequential) is determined at runtime. Also, the
parallel partitioning of the vector is determined by PETSc at runtime.
Routines for creating particular vector types directly are:
VecCreateSeq() - uniprocessor vector
VecCreateMPI() - distributed vector, where the user can
determine the parallel partitioning
VecCreateShared() - parallel vector that uses shared memory
(available only on the SGI); otherwise,
is the same as VecCreateMPI()
With VecCreate(), VecSetSizes() and VecSetFromOptions() the option -vec_type mpi or
-vec_type shared causes the particular type of vector to be formed.
*/
ierr = VecCreate(PETSC_COMM_WORLD,&x);CHKERRQ(ierr);
ierr = VecSetSizes(x,PETSC_DECIDE,n);CHKERRQ(ierr);
ierr = VecSetFromOptions(x);CHKERRQ(ierr);
/*
Duplicate some work vectors (of the same format and
partitioning as the initial vector).
*/
ierr = VecDuplicate(x,&y);CHKERRQ(ierr);
ierr = VecDuplicate(x,&w);CHKERRQ(ierr);
/*
Duplicate more work vectors (of the same format and
partitioning as the initial vector). Here we duplicate
an array of vectors, which is often more convenient than
duplicating individual ones.
*/
ierr = VecDuplicateVecs(x,3,&z);CHKERRQ(ierr);
/*
Set the vectors to entries to a constant value.
*/
ierr = VecSet(x,one);CHKERRQ(ierr);
ierr = VecSet(y,two);CHKERRQ(ierr);
ierr = VecSet(z[0],one);CHKERRQ(ierr);
ierr = VecSet(z[1],two);CHKERRQ(ierr);
ierr = VecSet(z[2],three);CHKERRQ(ierr);
/*
Demonstrate various basic vector routines.
*/
ierr = VecDot(x,y,&dot);CHKERRQ(ierr);
ierr = VecMDot(x,3,z,dots);CHKERRQ(ierr);
/*
Note: If using a complex numbers version of PETSc, then
PETSC_USE_COMPLEX is defined in the makefiles; otherwise,
(when using real numbers) it is undefined.
*/
ierr = PetscPrintf(PETSC_COMM_WORLD,"Vector length %D\n",n);CHKERRQ(ierr);
ierr = VecMax(x,&maxind,&maxval);CHKERRQ(ierr);
ierr = PetscPrintf(PETSC_COMM_WORLD,"VecMax %g, VecInd %D\n",(double)maxval,maxind);CHKERRQ(ierr);
ierr = VecMin(x,&maxind,&maxval);CHKERRQ(ierr);
ierr = PetscPrintf(PETSC_COMM_WORLD,"VecMin %g, VecInd %D\n",(double)maxval,maxind);CHKERRQ(ierr);
ierr = PetscPrintf(PETSC_COMM_WORLD,"All other values should be near zero\n");CHKERRQ(ierr);
ierr = VecScale(x,two);CHKERRQ(ierr);
ierr = VecNorm(x,NORM_2,&norm);CHKERRQ(ierr);
v = norm-2.0*PetscSqrtReal((PetscReal)n); if (v > -PETSC_SMALL && v < PETSC_SMALL) v = 0.0;
ierr = PetscPrintf(PETSC_COMM_WORLD,"VecScale %g\n",(double)v);CHKERRQ(ierr);
ierr = VecCopy(x,w);CHKERRQ(ierr);
ierr = VecNorm(w,NORM_2,&norm);CHKERRQ(ierr);
v = norm-2.0*PetscSqrtReal((PetscReal)n); if (v > -PETSC_SMALL && v < PETSC_SMALL) v = 0.0;
ierr = PetscPrintf(PETSC_COMM_WORLD,"VecCopy %g\n",(double)v);CHKERRQ(ierr);
ierr = VecAXPY(y,three,x);CHKERRQ(ierr);
ierr = VecNorm(y,NORM_2,&norm);CHKERRQ(ierr);
v = norm-8.0*PetscSqrtReal((PetscReal)n); if (v > -PETSC_SMALL && v < PETSC_SMALL) v = 0.0;
ierr = PetscPrintf(PETSC_COMM_WORLD,"VecAXPY %g\n",(double)v);CHKERRQ(ierr);
ierr = VecAYPX(y,two,x);CHKERRQ(ierr);
ierr = VecNorm(y,NORM_2,&norm);CHKERRQ(ierr);
v = norm-18.0*PetscSqrtReal((PetscReal)n); if (v > -PETSC_SMALL && v < PETSC_SMALL) v = 0.0;
ierr = PetscPrintf(PETSC_COMM_WORLD,"VecAYPX %g\n",(double)v);CHKERRQ(ierr);
ierr = VecSwap(x,y);CHKERRQ(ierr);
ierr = VecNorm(y,NORM_2,&norm);CHKERRQ(ierr);
v = norm-2.0*PetscSqrtReal((PetscReal)n); if (v > -PETSC_SMALL && v < PETSC_SMALL) v = 0.0;
ierr = PetscPrintf(PETSC_COMM_WORLD,"VecSwap %g\n",(double)v);CHKERRQ(ierr);
ierr = VecNorm(x,NORM_2,&norm);CHKERRQ(ierr);
v = norm-18.0*PetscSqrtReal((PetscReal)n); if (v > -PETSC_SMALL && v < PETSC_SMALL) v = 0.0;
ierr = PetscPrintf(PETSC_COMM_WORLD,"VecSwap %g\n",(double)v);CHKERRQ(ierr);
ierr = VecWAXPY(w,two,x,y);CHKERRQ(ierr);
ierr = VecNorm(w,NORM_2,&norm);CHKERRQ(ierr);
v = norm-38.0*PetscSqrtReal((PetscReal)n); if (v > -PETSC_SMALL && v < PETSC_SMALL) v = 0.0;
ierr = PetscPrintf(PETSC_COMM_WORLD,"VecWAXPY %g\n",(double)v);CHKERRQ(ierr);
ierr = VecPointwiseMult(w,y,x);CHKERRQ(ierr);
ierr = VecNorm(w,NORM_2,&norm);CHKERRQ(ierr);
v = norm-36.0*PetscSqrtReal((PetscReal)n); if (v > -PETSC_SMALL && v < PETSC_SMALL) v = 0.0;
ierr = PetscPrintf(PETSC_COMM_WORLD,"VecPointwiseMult %g\n",(double)v);CHKERRQ(ierr);
ierr = VecPointwiseDivide(w,x,y);CHKERRQ(ierr);
ierr = VecNorm(w,NORM_2,&norm);CHKERRQ(ierr);
v = norm-9.0*PetscSqrtReal((PetscReal)n); if (v > -PETSC_SMALL && v < PETSC_SMALL) v = 0.0;
ierr = PetscPrintf(PETSC_COMM_WORLD,"VecPointwiseDivide %g\n",(double)v);CHKERRQ(ierr);
dots[0] = one;
dots[1] = three;
dots[2] = two;
ierr = VecSet(x,one);CHKERRQ(ierr);
ierr = VecMAXPY(x,3,dots,z);CHKERRQ(ierr);
ierr = VecNorm(z[0],NORM_2,&norm);CHKERRQ(ierr);
v = norm-PetscSqrtReal((PetscReal)n); if (v > -PETSC_SMALL && v < PETSC_SMALL) v = 0.0;
ierr = VecNorm(z[1],NORM_2,&norm);CHKERRQ(ierr);
v1 = norm-2.0*PetscSqrtReal((PetscReal)n); if (v1 > -PETSC_SMALL && v1 < PETSC_SMALL) v1 = 0.0;
ierr = VecNorm(z[2],NORM_2,&norm);CHKERRQ(ierr);
v2 = norm-3.0*PetscSqrtReal((PetscReal)n); if (v2 > -PETSC_SMALL && v2 < PETSC_SMALL) v2 = 0.0;
ierr = PetscPrintf(PETSC_COMM_WORLD,"VecMAXPY %g %g %g \n",(double)v,(double)v1,(double)v2);CHKERRQ(ierr);
/*
Free work space. All PETSc objects should be destroyed when they
are no longer needed.
*/
ierr = VecDestroy(&x);CHKERRQ(ierr);
ierr = VecDestroy(&y);CHKERRQ(ierr);
ierr = VecDestroy(&w);CHKERRQ(ierr);
ierr = VecDestroyVecs(3,&z);CHKERRQ(ierr);
ierr = PetscFinalize();
return ierr;
}
static PetscErrorCode KSPSolve_PIPEFCG_cycle(KSP ksp)
{
PetscErrorCode ierr;
PetscInt i,j,k,idx,kdx,mi;
KSP_PIPEFCG *pipefcg;
PetscScalar alpha=0.0,gamma,*betas,*dots;
PetscReal dp=0.0, delta,*eta,*etas;
Vec B,R,Z,X,Qcurr,W,ZETAcurr,M,N,Pcurr,Scurr,*redux;
Mat Amat,Pmat;
PetscFunctionBegin;
/* We have not checked these routines for use with complex numbers. The inner products
are likely not defined correctly for that case */
#if (defined(PETSC_USE_COMPLEX) && !defined(PETSC_SKIP_COMPLEX))
SETERRQ(PETSC_COMM_WORLD,PETSC_ERR_SUP,"PIPEFGMRES has not been implemented for use with complex scalars");
#endif
#define VecXDot(x,y,a) (((pipefcg->type) == (KSP_CG_HERMITIAN)) ? VecDot (x,y,a) : VecTDot (x,y,a))
#define VecXDotBegin(x,y,a) (((pipefcg->type) == (KSP_CG_HERMITIAN)) ? VecDotBegin (x,y,a) : VecTDotBegin (x,y,a))
#define VecXDotEnd(x,y,a) (((pipefcg->type) == (KSP_CG_HERMITIAN)) ? VecDotEnd (x,y,a) : VecTDotEnd (x,y,a))
#define VecMXDot(x,n,y,a) (((pipefcg->type) == (KSP_CG_HERMITIAN)) ? VecMDot (x,n,y,a) : VecMTDot (x,n,y,a))
#define VecMXDotBegin(x,n,y,a) (((pipefcg->type) == (KSP_CG_HERMITIAN)) ? VecMDotBegin (x,n,y,a) : VecMTDotBegin (x,n,y,a))
#define VecMXDotEnd(x,n,y,a) (((pipefcg->type) == (KSP_CG_HERMITIAN)) ? VecMDotEnd (x,n,y,a) : VecMTDotEnd (x,n,y,a))
pipefcg = (KSP_PIPEFCG*)ksp->data;
X = ksp->vec_sol;
B = ksp->vec_rhs;
R = ksp->work[0];
Z = ksp->work[1];
W = ksp->work[2];
M = ksp->work[3];
N = ksp->work[4];
redux = pipefcg->redux;
dots = pipefcg->dots;
etas = pipefcg->etas;
betas = dots; /* dots takes the result of all dot products of which the betas are a subset */
ierr = PCGetOperators(ksp->pc,&Amat,&Pmat);CHKERRQ(ierr);
/* Compute cycle initial residual */
ierr = KSP_MatMult(ksp,Amat,X,R);CHKERRQ(ierr);
ierr = VecAYPX(R,-1.0,B);CHKERRQ(ierr); /* r <- b - Ax */
ierr = KSP_PCApply(ksp,R,Z);CHKERRQ(ierr); /* z <- Br */
Pcurr = pipefcg->Pvecs[0];
Scurr = pipefcg->Svecs[0];
Qcurr = pipefcg->Qvecs[0];
ZETAcurr = pipefcg->ZETAvecs[0];
ierr = VecCopy(Z,Pcurr);CHKERRQ(ierr);
ierr = KSP_MatMult(ksp,Amat,Pcurr,Scurr);CHKERRQ(ierr); /* S = Ap */
ierr = VecCopy(Scurr,W);CHKERRQ(ierr); /* w = s = Az */
/* Initial state of pipelining intermediates */
redux[0] = R;
redux[1] = W;
ierr = VecMXDotBegin(Z,2,redux,dots);CHKERRQ(ierr);
ierr = PetscCommSplitReductionBegin(PetscObjectComm((PetscObject)Z));CHKERRQ(ierr); /* perform asynchronous reduction */
ierr = KSP_PCApply(ksp,W,M);CHKERRQ(ierr); /* m = B(w) */
ierr = KSP_MatMult(ksp,Amat,M,N);CHKERRQ(ierr); /* n = Am */
ierr = VecCopy(M,Qcurr);CHKERRQ(ierr); /* q = m */
ierr = VecCopy(N,ZETAcurr);CHKERRQ(ierr); /* zeta = n */
ierr = VecMXDotEnd(Z,2,redux,dots);CHKERRQ(ierr);
gamma = dots[0];
delta = PetscRealPart(dots[1]);
etas[0] = delta;
alpha = gamma/delta;
i = 0;
do {
ksp->its++;
/* Update X, R, Z, W */
ierr = VecAXPY(X,+alpha,Pcurr);CHKERRQ(ierr); /* x <- x + alpha * pi */
ierr = VecAXPY(R,-alpha,Scurr);CHKERRQ(ierr); /* r <- r - alpha * si */
ierr = VecAXPY(Z,-alpha,Qcurr);CHKERRQ(ierr); /* z <- z - alpha * qi */
ierr = VecAXPY(W,-alpha,ZETAcurr);CHKERRQ(ierr); /* w <- w - alpha * zetai */
/* Compute norm for convergence check */
switch (ksp->normtype) {
case KSP_NORM_PRECONDITIONED:
ierr = VecNorm(Z,NORM_2,&dp);CHKERRQ(ierr); /* dp <- sqrt(z'*z) = sqrt(e'*A'*B'*B*A*e) */
break;
case KSP_NORM_UNPRECONDITIONED:
ierr = VecNorm(R,NORM_2,&dp);CHKERRQ(ierr); /* dp <- sqrt(r'*r) = sqrt(e'*A'*A*e) */
break;
case KSP_NORM_NATURAL:
dp = PetscSqrtReal(PetscAbsScalar(gamma)); /* dp <- sqrt(r'*z) = sqrt(e'*A'*B*A*e) */
break;
case KSP_NORM_NONE:
dp = 0.0;
break;
default: SETERRQ1(PetscObjectComm((PetscObject)ksp),PETSC_ERR_SUP,"%s",KSPNormTypes[ksp->normtype]);
}
/* Check for convergence */
ksp->rnorm = dp;
KSPLogResidualHistory(ksp,dp);CHKERRQ(ierr);
ierr = KSPMonitor(ksp,ksp->its,dp);CHKERRQ(ierr);
ierr = (*ksp->converged)(ksp,ksp->its+1,dp,&ksp->reason,ksp->cnvP);CHKERRQ(ierr);
if (ksp->reason) break;
/* Computations of current iteration done */
++i;
/* If needbe, allocate a new chunk of vectors in P and C */
ierr = KSPAllocateVectors_PIPEFCG(ksp,i+1,pipefcg->vecb);CHKERRQ(ierr);
/* Note that we wrap around and start clobbering old vectors */
idx = i % (pipefcg->mmax+1);
Pcurr = pipefcg->Pvecs[idx];
Scurr = pipefcg->Svecs[idx];
Qcurr = pipefcg->Qvecs[idx];
ZETAcurr = pipefcg->ZETAvecs[idx];
eta = pipefcg->etas+idx;
/* number of old directions to orthogonalize against */
switch(pipefcg->truncstrat){
case KSP_FCD_TRUNC_TYPE_STANDARD:
mi = pipefcg->mmax;
break;
case KSP_FCD_TRUNC_TYPE_NOTAY:
mi = ((i-1) % pipefcg->mmax)+1;
break;
default:
SETERRQ(PETSC_COMM_SELF,PETSC_ERR_ARG_WRONG,"Unrecognized Truncation Strategy");
}
/* Pick old p,s,q,zeta in a way suitable for VecMDot */
ierr = VecCopy(Z,Pcurr);CHKERRQ(ierr);
for(k=PetscMax(0,i-mi),j=0;k<i;++j,++k){
kdx = k % (pipefcg->mmax+1);
pipefcg->Pold[j] = pipefcg->Pvecs[kdx];
pipefcg->Sold[j] = pipefcg->Svecs[kdx];
pipefcg->Qold[j] = pipefcg->Qvecs[kdx];
pipefcg->ZETAold[j] = pipefcg->ZETAvecs[kdx];
redux[j] = pipefcg->Svecs[kdx];
}
redux[j] = R; /* If the above loop is not executed redux contains only R => all beta_k = 0, only gamma, delta != 0 */
redux[j+1] = W;
ierr = VecMXDotBegin(Z,j+2,redux,betas);CHKERRQ(ierr); /* Start split reductions for beta_k = (z,s_k), gamma = (z,r), delta = (z,w) */
ierr = PetscCommSplitReductionBegin(PetscObjectComm((PetscObject)Z));CHKERRQ(ierr); /* perform asynchronous reduction */
ierr = VecWAXPY(N,-1.0,R,W);CHKERRQ(ierr); /* m = u + B(w-r): (a) ntmp = w-r */
ierr = KSP_PCApply(ksp,N,M);CHKERRQ(ierr); /* m = u + B(w-r): (b) mtmp = B(ntmp) = B(w-r) */
ierr = VecAXPY(M,1.0,Z);CHKERRQ(ierr); /* m = u + B(w-r): (c) m = z + mtmp */
ierr = KSP_MatMult(ksp,Amat,M,N);CHKERRQ(ierr); /* n = Am */
ierr = VecMXDotEnd(Z,j+2,redux,betas);CHKERRQ(ierr); /* Finish split reductions */
gamma = betas[j];
delta = PetscRealPart(betas[j+1]);
*eta = 0.;
for(k=PetscMax(0,i-mi),j=0;k<i;++j,++k){
kdx = k % (pipefcg->mmax+1);
betas[j] /= -etas[kdx]; /* betak /= etak */
*eta -= ((PetscReal)(PetscAbsScalar(betas[j])*PetscAbsScalar(betas[j]))) * etas[kdx];
/* etaitmp = -betaik^2 * etak */
}
*eta += delta; /* etai = delta -betaik^2 * etak */
if(*eta < 0.) {
pipefcg->norm_breakdown = PETSC_TRUE;
ierr = PetscInfo1(ksp,"Restart due to square root breakdown at it = \n",ksp->its);CHKERRQ(ierr);
break;
} else {
alpha= gamma/(*eta); /* alpha = gamma/etai */
}
/* project out stored search directions using classical G-S */
ierr = VecCopy(Z,Pcurr);CHKERRQ(ierr);
ierr = VecCopy(W,Scurr);CHKERRQ(ierr);
ierr = VecCopy(M,Qcurr);CHKERRQ(ierr);
ierr = VecCopy(N,ZETAcurr);CHKERRQ(ierr);
ierr = VecMAXPY(Pcurr ,j,betas,pipefcg->Pold);CHKERRQ(ierr); /* pi <- ui - sum_k beta_k p_k */
ierr = VecMAXPY(Scurr ,j,betas,pipefcg->Sold);CHKERRQ(ierr); /* si <- wi - sum_k beta_k s_k */
ierr = VecMAXPY(Qcurr ,j,betas,pipefcg->Qold);CHKERRQ(ierr); /* qi <- m - sum_k beta_k q_k */
ierr = VecMAXPY(ZETAcurr,j,betas,pipefcg->ZETAold);CHKERRQ(ierr); /* zetai <- n - sum_k beta_k zeta_k */
} while (ksp->its < ksp->max_it);
PetscFunctionReturn(0);
}
/* approximately solve the overdetermined system:
2*F(x_i)\cdot F(\x_j)\alpha_i = 0
\alpha_i = 1
Which minimizes the L2 norm of the linearization of:
||F(\sum_i \alpha_i*x_i)||^2
With the constraint that \sum_i\alpha_i = 1
Where x_i is the solution from the ith subsolver.
*/
static PetscErrorCode SNESCompositeApply_AdditiveOptimal(SNES snes,Vec X,Vec B,Vec F,PetscReal *fnorm)
{
PetscErrorCode ierr;
SNES_Composite *jac = (SNES_Composite*)snes->data;
SNES_CompositeLink next = jac->head;
Vec *Xes = jac->Xes,*Fes = jac->Fes;
PetscInt i,j;
PetscScalar tot,total,ftf;
PetscReal min_fnorm;
PetscInt min_i;
SNESConvergedReason reason;
PetscFunctionBegin;
if (!next) SETERRQ(PetscObjectComm((PetscObject)snes),PETSC_ERR_ARG_WRONGSTATE,"No composite SNESes supplied via SNESCompositeAddSNES() or -snes_composite_sneses");
if (snes->normschedule == SNES_NORM_ALWAYS) {
next = jac->head;
ierr = SNESSetInitialFunction(next->snes,F);CHKERRQ(ierr);
while (next->next) {
next = next->next;
ierr = SNESSetInitialFunction(next->snes,F);CHKERRQ(ierr);
}
}
next = jac->head;
i = 0;
ierr = VecCopy(X,Xes[i]);CHKERRQ(ierr);
ierr = SNESSolve(next->snes,B,Xes[i]);CHKERRQ(ierr);
ierr = SNESGetConvergedReason(next->snes,&reason);CHKERRQ(ierr);
if (reason < 0 && reason != SNES_DIVERGED_MAX_IT) {
jac->innerFailures++;
if (jac->innerFailures >= snes->maxFailures) {
snes->reason = SNES_DIVERGED_INNER;
PetscFunctionReturn(0);
}
}
while (next->next) {
i++;
next = next->next;
ierr = VecCopy(X,Xes[i]);CHKERRQ(ierr);
ierr = SNESSolve(next->snes,B,Xes[i]);CHKERRQ(ierr);
ierr = SNESGetConvergedReason(next->snes,&reason);CHKERRQ(ierr);
if (reason < 0 && reason != SNES_DIVERGED_MAX_IT) {
jac->innerFailures++;
if (jac->innerFailures >= snes->maxFailures) {
snes->reason = SNES_DIVERGED_INNER;
PetscFunctionReturn(0);
}
}
}
/* all the solutions are collected; combine optimally */
for (i=0;i<jac->n;i++) {
for (j=0;j<i+1;j++) {
ierr = VecDotBegin(Fes[i],Fes[j],&jac->h[i + j*jac->n]);CHKERRQ(ierr);
}
ierr = VecDotBegin(Fes[i],F,&jac->g[i]);CHKERRQ(ierr);
}
for (i=0;i<jac->n;i++) {
for (j=0;j<i+1;j++) {
ierr = VecDotEnd(Fes[i],Fes[j],&jac->h[i + j*jac->n]);CHKERRQ(ierr);
if (i == j) jac->fnorms[i] = PetscSqrtReal(PetscRealPart(jac->h[i + j*jac->n]));
}
ierr = VecDotEnd(Fes[i],F,&jac->g[i]);CHKERRQ(ierr);
}
ftf = (*fnorm)*(*fnorm);
for (i=0; i<jac->n; i++) {
for (j=i+1;j<jac->n;j++) {
jac->h[i + j*jac->n] = jac->h[j + i*jac->n];
}
}
for (i=0; i<jac->n; i++) {
for (j=0; j<jac->n; j++) {
jac->h[i + j*jac->n] = jac->h[i + j*jac->n] - jac->g[j] - jac->g[i] + ftf;
}
jac->beta[i] = ftf - jac->g[i];
}
#if defined(PETSC_MISSING_LAPACK_GELSS)
SETERRQ(PetscObjectComm((PetscObject)snes),PETSC_ERR_SUP,"SNESCOMPOSITE with ADDITIVEOPTIMAL requires the LAPACK GELSS routine.");
#else
jac->info = 0;
jac->rcond = -1.;
ierr = PetscFPTrapPush(PETSC_FP_TRAP_OFF);CHKERRQ(ierr);
#if defined(PETSC_USE_COMPLEX)
PetscStackCall("LAPACKgelss",LAPACKgelss_(&jac->n,&jac->n,&jac->nrhs,jac->h,&jac->lda,jac->beta,&jac->lda,jac->s,&jac->rcond,&jac->rank,jac->work,&jac->lwork,jac->rwork,&jac->info));
#else
PetscStackCall("LAPACKgelss",LAPACKgelss_(&jac->n,&jac->n,&jac->nrhs,jac->h,&jac->lda,jac->beta,&jac->lda,jac->s,&jac->rcond,&jac->rank,jac->work,&jac->lwork,&jac->info));
#endif
ierr = PetscFPTrapPop();CHKERRQ(ierr);
if (jac->info < 0) SETERRQ(PetscObjectComm((PetscObject)snes),PETSC_ERR_LIB,"Bad argument to GELSS");
if (jac->info > 0) SETERRQ(PetscObjectComm((PetscObject)snes),PETSC_ERR_LIB,"SVD failed to converge");
#endif
tot = 0.;
total = 0.;
for (i=0; i<jac->n; i++) {
if (snes->errorifnotconverged && PetscIsInfOrNanScalar(jac->beta[i])) SETERRQ(PetscObjectComm((PetscObject)snes),PETSC_ERR_LIB,"SVD generated inconsistent output");
ierr = PetscInfo2(snes,"%D: %g\n",i,(double)PetscRealPart(jac->beta[i]));CHKERRQ(ierr);
tot += jac->beta[i];
total += PetscAbsScalar(jac->beta[i]);
}
ierr = VecScale(X,(1. - tot));CHKERRQ(ierr);
ierr = VecMAXPY(X,jac->n,jac->beta,Xes);CHKERRQ(ierr);
ierr = SNESComputeFunction(snes,X,F);CHKERRQ(ierr);
if (snes->xl && snes->xu) {
ierr = SNESVIComputeInactiveSetFnorm(snes, F, X, fnorm);CHKERRQ(ierr);
} else {
ierr = VecNorm(F, NORM_2, fnorm);CHKERRQ(ierr);
}
/* take the minimum-normed candidate if it beats the combination by a factor of rtol or the combination has stagnated */
min_fnorm = jac->fnorms[0];
min_i = 0;
for (i=0; i<jac->n; i++) {
if (jac->fnorms[i] < min_fnorm) {
min_fnorm = jac->fnorms[i];
min_i = i;
}
}
/* stagnation or divergence restart to the solution of the solver that failed the least */
if (PetscRealPart(total) < jac->stol || min_fnorm*jac->rtol < *fnorm) {
ierr = VecCopy(jac->Xes[min_i],X);CHKERRQ(ierr);
ierr = VecCopy(jac->Fes[min_i],F);CHKERRQ(ierr);
*fnorm = min_fnorm;
}
PetscFunctionReturn(0);
}
PetscErrorCode SNESNGMRESFormCombinedSolution_Private(SNES snes,PetscInt l,Vec XM,Vec FM,PetscReal fMnorm,Vec X,Vec XA,Vec FA)
{
SNES_NGMRES *ngmres = (SNES_NGMRES*) snes->data;
PetscInt i,j;
Vec *Fdot = ngmres->Fdot;
Vec *Xdot = ngmres->Xdot;
PetscScalar *beta = ngmres->beta;
PetscScalar *xi = ngmres->xi;
PetscScalar alph_total = 0.;
PetscErrorCode ierr;
PetscReal nu;
Vec Y = snes->work[2];
PetscBool changed_y,changed_w;
PetscFunctionBegin;
nu = fMnorm*fMnorm;
/* construct the right hand side and xi factors */
ierr = VecMDot(FM,l,Fdot,xi);CHKERRQ(ierr);
for (i = 0; i < l; i++) beta[i] = nu - xi[i];
/* construct h */
for (j = 0; j < l; j++) {
for (i = 0; i < l; i++) {
H(i,j) = Q(i,j)-xi[i]-xi[j]+nu;
}
}
if (l == 1) {
/* simply set alpha[0] = beta[0] / H[0, 0] */
if (H(0,0) != 0.) beta[0] = beta[0]/H(0,0);
else beta[0] = 0.;
} else {
#if defined(PETSC_MISSING_LAPACK_GELSS)
SETERRQ(PetscObjectComm((PetscObject)snes),PETSC_ERR_SUP,"NGMRES with LS requires the LAPACK GELSS routine.");
#else
ierr = PetscBLASIntCast(l,&ngmres->m);CHKERRQ(ierr);
ierr = PetscBLASIntCast(l,&ngmres->n);CHKERRQ(ierr);
ngmres->info = 0;
ngmres->rcond = -1.;
ierr = PetscFPTrapPush(PETSC_FP_TRAP_OFF);CHKERRQ(ierr);
#if defined(PETSC_USE_COMPLEX)
PetscStackCall("LAPACKgelss",LAPACKgelss_(&ngmres->m,&ngmres->n,&ngmres->nrhs,ngmres->h,&ngmres->lda,ngmres->beta,&ngmres->ldb,ngmres->s,&ngmres->rcond,&ngmres->rank,ngmres->work,&ngmres->lwork,ngmres->rwork,&ngmres->info));
#else
PetscStackCall("LAPACKgelss",LAPACKgelss_(&ngmres->m,&ngmres->n,&ngmres->nrhs,ngmres->h,&ngmres->lda,ngmres->beta,&ngmres->ldb,ngmres->s,&ngmres->rcond,&ngmres->rank,ngmres->work,&ngmres->lwork,&ngmres->info));
#endif
ierr = PetscFPTrapPop();CHKERRQ(ierr);
if (ngmres->info < 0) SETERRQ(PetscObjectComm((PetscObject)snes),PETSC_ERR_LIB,"Bad argument to GELSS");
if (ngmres->info > 0) SETERRQ(PetscObjectComm((PetscObject)snes),PETSC_ERR_LIB,"SVD failed to converge");
#endif
}
for (i=0; i<l; i++) {
if (PetscIsInfOrNanScalar(beta[i])) SETERRQ(PetscObjectComm((PetscObject)snes),PETSC_ERR_LIB,"SVD generated inconsistent output");
}
alph_total = 0.;
for (i = 0; i < l; i++) alph_total += beta[i];
ierr = VecCopy(XM,XA);CHKERRQ(ierr);
ierr = VecScale(XA,1.-alph_total);CHKERRQ(ierr);
ierr = VecMAXPY(XA,l,beta,Xdot);CHKERRQ(ierr);
/* check the validity of the step */
ierr = VecCopy(XA,Y);CHKERRQ(ierr);
ierr = VecAXPY(Y,-1.0,X);CHKERRQ(ierr);
ierr = SNESLineSearchPostCheck(snes->linesearch,X,Y,XA,&changed_y,&changed_w);CHKERRQ(ierr);
if (!ngmres->approxfunc) {ierr = SNESComputeFunction(snes,XA,FA);CHKERRQ(ierr);}
else {
ierr = VecCopy(FM,FA);CHKERRQ(ierr);
ierr = VecScale(FA,1.-alph_total);CHKERRQ(ierr);
ierr = VecMAXPY(FA,l,beta,Fdot);CHKERRQ(ierr);
}
PetscFunctionReturn(0);
}
PetscErrorCode KSPLGMRESCycle(PetscInt *itcount,KSP ksp)
{
KSP_LGMRES *lgmres = (KSP_LGMRES*)(ksp->data);
PetscReal res_norm, res;
PetscReal hapbnd, tt;
PetscScalar tmp;
PetscBool hapend = PETSC_FALSE; /* indicates happy breakdown ending */
PetscErrorCode ierr;
PetscInt loc_it; /* local count of # of dir. in Krylov space */
PetscInt max_k = lgmres->max_k; /* max approx space size */
PetscInt max_it = ksp->max_it; /* max # of overall iterations for the method */
/* LGMRES_MOD - new variables*/
PetscInt aug_dim = lgmres->aug_dim;
PetscInt spot = 0;
PetscInt order = 0;
PetscInt it_arnoldi; /* number of arnoldi steps to take */
PetscInt it_total; /* total number of its to take (=approx space size)*/
PetscInt ii, jj;
PetscReal tmp_norm;
PetscScalar inv_tmp_norm;
PetscScalar *avec;
PetscFunctionBegin;
/* Number of pseudo iterations since last restart is the number
of prestart directions */
loc_it = 0;
/* LGMRES_MOD: determine number of arnoldi steps to take */
/* if approx_constant then we keep the space the same size even if
we don't have the full number of aug vectors yet*/
if (lgmres->approx_constant) it_arnoldi = max_k - lgmres->aug_ct;
else it_arnoldi = max_k - aug_dim;
it_total = it_arnoldi + lgmres->aug_ct;
/* initial residual is in VEC_VV(0) - compute its norm*/
ierr = VecNorm(VEC_VV(0),NORM_2,&res_norm);CHKERRQ(ierr);
res = res_norm;
/* first entry in right-hand-side of hessenberg system is just
the initial residual norm */
*GRS(0) = res_norm;
/* check for the convergence */
if (!res) {
if (itcount) *itcount = 0;
ksp->reason = KSP_CONVERGED_ATOL;
ierr = PetscInfo(ksp,"Converged due to zero residual norm on entry\n");CHKERRQ(ierr);
PetscFunctionReturn(0);
}
/* scale VEC_VV (the initial residual) */
tmp = 1.0/res_norm; ierr = VecScale(VEC_VV(0),tmp);CHKERRQ(ierr);
ksp->rnorm = res;
/* note: (lgmres->it) is always set one less than (loc_it) It is used in
KSPBUILDSolution_LGMRES, where it is passed to KSPLGMRESBuildSoln.
Note that when KSPLGMRESBuildSoln is called from this function,
(loc_it -1) is passed, so the two are equivalent */
lgmres->it = (loc_it - 1);
/* MAIN ITERATION LOOP BEGINNING*/
/* keep iterating until we have converged OR generated the max number
of directions OR reached the max number of iterations for the method */
ierr = (*ksp->converged)(ksp,ksp->its,res,&ksp->reason,ksp->cnvP);CHKERRQ(ierr);
while (!ksp->reason && loc_it < it_total && ksp->its < max_it) { /* LGMRES_MOD: changed to it_total */
ierr = KSPLogResidualHistory(ksp,res);CHKERRQ(ierr);
lgmres->it = (loc_it - 1);
ierr = KSPMonitor(ksp,ksp->its,res);CHKERRQ(ierr);
/* see if more space is needed for work vectors */
if (lgmres->vv_allocated <= loc_it + VEC_OFFSET + 1) {
ierr = KSPLGMRESGetNewVectors(ksp,loc_it+1);CHKERRQ(ierr);
/* (loc_it+1) is passed in as number of the first vector that should
be allocated */
}
/*LGMRES_MOD: decide whether this is an arnoldi step or an aug step */
if (loc_it < it_arnoldi) { /* Arnoldi */
ierr = KSP_PCApplyBAorAB(ksp,VEC_VV(loc_it),VEC_VV(1+loc_it),VEC_TEMP_MATOP);CHKERRQ(ierr);
} else { /*aug step */
order = loc_it - it_arnoldi + 1; /* which aug step */
for (ii=0; ii<aug_dim; ii++) {
if (lgmres->aug_order[ii] == order) {
spot = ii;
break; /* must have this because there will be duplicates before aug_ct = aug_dim */
}
}
ierr = VecCopy(A_AUGVEC(spot), VEC_VV(1+loc_it));CHKERRQ(ierr);
/*note: an alternate implementation choice would be to only save the AUGVECS and
not A_AUGVEC and then apply the PC here to the augvec */
}
/* update hessenberg matrix and do Gram-Schmidt - new direction is in
VEC_VV(1+loc_it)*/
ierr = (*lgmres->orthog)(ksp,loc_it);CHKERRQ(ierr);
/* new entry in hessenburg is the 2-norm of our new direction */
ierr = VecNorm(VEC_VV(loc_it+1),NORM_2,&tt);CHKERRQ(ierr);
*HH(loc_it+1,loc_it) = tt;
*HES(loc_it+1,loc_it) = tt;
/* check for the happy breakdown */
hapbnd = PetscAbsScalar(tt / *GRS(loc_it)); /* GRS(loc_it) contains the res_norm from the last iteration */
if (hapbnd > lgmres->haptol) hapbnd = lgmres->haptol;
if (tt > hapbnd) {
tmp = 1.0/tt;
ierr = VecScale(VEC_VV(loc_it+1),tmp);CHKERRQ(ierr); /* scale new direction by its norm */
} else {
ierr = PetscInfo2(ksp,"Detected happy breakdown, current hapbnd = %G tt = %G\n",hapbnd,tt);CHKERRQ(ierr);
hapend = PETSC_TRUE;
}
/* Now apply rotations to new col of hessenberg (and right side of system),
calculate new rotation, and get new residual norm at the same time*/
ierr = KSPLGMRESUpdateHessenberg(ksp,loc_it,hapend,&res);CHKERRQ(ierr);
if (ksp->reason) break;
loc_it++;
lgmres->it = (loc_it-1); /* Add this here in case it has converged */
ierr = PetscObjectSAWsTakeAccess((PetscObject)ksp);CHKERRQ(ierr);
ksp->its++;
ksp->rnorm = res;
ierr = PetscObjectSAWsGrantAccess((PetscObject)ksp);CHKERRQ(ierr);
ierr = (*ksp->converged)(ksp,ksp->its,res,&ksp->reason,ksp->cnvP);CHKERRQ(ierr);
/* Catch error in happy breakdown and signal convergence and break from loop */
if (hapend) {
if (!ksp->reason) {
if (ksp->errorifnotconverged) SETERRQ1(PetscObjectComm((PetscObject)ksp),PETSC_ERR_NOT_CONVERGED,"You reached the happy break down, but convergence was not indicated. Residual norm = %G",res);
else {
ksp->reason = KSP_DIVERGED_BREAKDOWN;
break;
}
}
}
}
/* END OF ITERATION LOOP */
ierr = KSPLogResidualHistory(ksp,res);CHKERRQ(ierr);
/* Monitor if we know that we will not return for a restart */
if (ksp->reason || ksp->its >= max_it) {
ierr = KSPMonitor(ksp, ksp->its, res);CHKERRQ(ierr);
}
if (itcount) *itcount = loc_it;
/*
Down here we have to solve for the "best" coefficients of the Krylov
columns, add the solution values together, and possibly unwind the
preconditioning from the solution
*/
/* Form the solution (or the solution so far) */
/* Note: must pass in (loc_it-1) for iteration count so that KSPLGMRESBuildSoln
properly navigates */
ierr = KSPLGMRESBuildSoln(GRS(0),ksp->vec_sol,ksp->vec_sol,ksp,loc_it-1);CHKERRQ(ierr);
/* LGMRES_MOD collect aug vector and A*augvector for future restarts -
only if we will be restarting (i.e. this cycle performed it_total
iterations) */
if (!ksp->reason && ksp->its < max_it && aug_dim > 0) {
/*AUG_TEMP contains the new augmentation vector (assigned in KSPLGMRESBuildSoln) */
if (!lgmres->aug_ct) {
spot = 0;
lgmres->aug_ct++;
} else if (lgmres->aug_ct < aug_dim) {
spot = lgmres->aug_ct;
lgmres->aug_ct++;
} else { /* truncate */
for (ii=0; ii<aug_dim; ii++) {
if (lgmres->aug_order[ii] == aug_dim) spot = ii;
}
}
ierr = VecCopy(AUG_TEMP, AUGVEC(spot));CHKERRQ(ierr);
/*need to normalize */
ierr = VecNorm(AUGVEC(spot), NORM_2, &tmp_norm);CHKERRQ(ierr);
inv_tmp_norm = 1.0/tmp_norm;
ierr = VecScale(AUGVEC(spot),inv_tmp_norm);CHKERRQ(ierr);
/*set new aug vector to order 1 - move all others back one */
for (ii=0; ii < aug_dim; ii++) AUG_ORDER(ii)++;
AUG_ORDER(spot) = 1;
/*now add the A*aug vector to A_AUGVEC(spot) - this is independ. of preconditioning type*/
/* want V*H*y - y is in GRS, V is in VEC_VV and H is in HES */
/* first do H+*y */
avec = lgmres->hwork;
ierr = PetscMemzero(avec,(it_total+1)*sizeof(*avec));CHKERRQ(ierr);
for (ii=0; ii < it_total + 1; ii++) {
for (jj=0; jj <= ii+1 && jj < it_total+1; jj++) {
avec[jj] += *HES(jj ,ii) * *GRS(ii);
}
}
/*now multiply result by V+ */
ierr = VecSet(VEC_TEMP,0.0);CHKERRQ(ierr);
ierr = VecMAXPY(VEC_TEMP, it_total+1, avec, &VEC_VV(0));CHKERRQ(ierr); /*answer is in VEC_TEMP*/
/*copy answer to aug location and scale*/
ierr = VecCopy(VEC_TEMP, A_AUGVEC(spot));CHKERRQ(ierr);
ierr = VecScale(A_AUGVEC(spot),inv_tmp_norm);CHKERRQ(ierr);
}
PetscFunctionReturn(0);
}
static PetscErrorCode KSPPGMRESCycle(PetscInt *itcount,KSP ksp)
{
KSP_PGMRES *pgmres = (KSP_PGMRES*)(ksp->data);
PetscReal res_norm,res,newnorm;
PetscErrorCode ierr;
PetscInt it = 0,j,k;
PetscBool hapend = PETSC_FALSE;
PetscFunctionBegin;
if (itcount) *itcount = 0;
ierr = VecNormalize(VEC_VV(0),&res_norm);CHKERRQ(ierr);
res = res_norm;
*RS(0) = res_norm;
/* check for the convergence */
ierr = PetscObjectAMSTakeAccess((PetscObject)ksp);CHKERRQ(ierr);
ksp->rnorm = res;
ierr = PetscObjectAMSGrantAccess((PetscObject)ksp);CHKERRQ(ierr);
pgmres->it = it-2;
ierr = KSPLogResidualHistory(ksp,res);CHKERRQ(ierr);
ierr = KSPMonitor(ksp,ksp->its,res);CHKERRQ(ierr);
if (!res) {
ksp->reason = KSP_CONVERGED_ATOL;
ierr = PetscInfo(ksp,"Converged due to zero residual norm on entry\n");CHKERRQ(ierr);
PetscFunctionReturn(0);
}
ierr = (*ksp->converged)(ksp,ksp->its,res,&ksp->reason,ksp->cnvP);CHKERRQ(ierr);
for (; !ksp->reason; it++) {
Vec Zcur,Znext;
if (pgmres->vv_allocated <= it + VEC_OFFSET + 1) {
ierr = KSPGMRESGetNewVectors(ksp,it+1);CHKERRQ(ierr);
}
/* VEC_VV(it-1) is orthogonal, it will be normalized once the VecNorm arrives. */
Zcur = VEC_VV(it); /* Zcur is not yet orthogonal, but the VecMDot to orthogonalize it has been started. */
Znext = VEC_VV(it+1); /* This iteration will compute Znext, update with a deferred correction once we know how
* Zcur relates to the previous vectors, and start the reduction to orthogonalize it. */
if (it < pgmres->max_k+1 && ksp->its+1 < PetscMax(2,ksp->max_it)) { /* We don't know whether what we have computed is enough, so apply the matrix. */
ierr = KSP_PCApplyBAorAB(ksp,Zcur,Znext,VEC_TEMP_MATOP);CHKERRQ(ierr);
}
if (it > 1) { /* Complete the pending reduction */
ierr = VecNormEnd(VEC_VV(it-1),NORM_2,&newnorm);CHKERRQ(ierr);
*HH(it-1,it-2) = newnorm;
}
if (it > 0) { /* Finish the reduction computing the latest column of H */
ierr = VecMDotEnd(Zcur,it,&(VEC_VV(0)),HH(0,it-1));CHKERRQ(ierr);
}
if (it > 1) {
/* normalize the base vector from two iterations ago, basis is complete up to here */
ierr = VecScale(VEC_VV(it-1),1./ *HH(it-1,it-2));CHKERRQ(ierr);
ierr = KSPPGMRESUpdateHessenberg(ksp,it-2,&hapend,&res);CHKERRQ(ierr);
pgmres->it = it-2;
ksp->its++;
ksp->rnorm = res;
ierr = (*ksp->converged)(ksp,ksp->its,res,&ksp->reason,ksp->cnvP);CHKERRQ(ierr);
if (it < pgmres->max_k+1 || ksp->reason || ksp->its == ksp->max_it) { /* Monitor if we are done or still iterating, but not before a restart. */
ierr = KSPLogResidualHistory(ksp,res);CHKERRQ(ierr);
ierr = KSPMonitor(ksp,ksp->its,res);CHKERRQ(ierr);
}
if (ksp->reason) break;
/* Catch error in happy breakdown and signal convergence and break from loop */
if (hapend) {
if (ksp->errorifnotconverged) SETERRQ1(PetscObjectComm((PetscObject)ksp),PETSC_ERR_NOT_CONVERGED,"You reached the happy break down, but convergence was not indicated. Residual norm = %G",res);
else {
ksp->reason = KSP_DIVERGED_BREAKDOWN;
break;
}
}
if (!(it < pgmres->max_k+1 && ksp->its < ksp->max_it)) break;
/* The it-2 column of H was not scaled when we computed Zcur, apply correction */
ierr = VecScale(Zcur,1./ *HH(it-1,it-2));CHKERRQ(ierr);
/* And Znext computed in this iteration was computed using the under-scaled Zcur */
ierr = VecScale(Znext,1./ *HH(it-1,it-2));CHKERRQ(ierr);
/* In the previous iteration, we projected an unnormalized Zcur against the Krylov basis, so we need to fix the column of H resulting from that projection. */
for (k=0; k<it; k++) *HH(k,it-1) /= *HH(it-1,it-2);
/* When Zcur was projected against the Krylov basis, VV(it-1) was still not normalized, so fix that too. This
* column is complete except for HH(it,it-1) which we won't know until the next iteration. */
*HH(it-1,it-1) /= *HH(it-1,it-2);
}
if (it > 0) {
PetscScalar *work;
if (!pgmres->orthogwork) {ierr = PetscMalloc((pgmres->max_k + 2)*sizeof(PetscScalar),&pgmres->orthogwork);CHKERRQ(ierr);}
work = pgmres->orthogwork;
/* Apply correction computed by the VecMDot in the last iteration to Znext. The original form is
*
* Znext -= sum_{j=0}^{i-1} Z[j+1] * H[j,i-1]
*
* where
*
* Z[j] = sum_{k=0}^j V[k] * H[k,j-1]
*
* substituting
*
* Znext -= sum_{j=0}^{i-1} sum_{k=0}^{j+1} V[k] * H[k,j] * H[j,i-1]
*
* rearranging the iteration space from row-column to column-row
*
* Znext -= sum_{k=0}^i sum_{j=k-1}^{i-1} V[k] * H[k,j] * H[j,i-1]
*
* Note that column it-1 of HH is correct. For all previous columns, we must look at HES because HH has already
* been transformed to upper triangular form.
*/
for (k=0; k<it+1; k++) {
work[k] = 0;
for (j=PetscMax(0,k-1); j<it-1; j++) work[k] -= *HES(k,j) * *HH(j,it-1);
}
ierr = VecMAXPY(Znext,it+1,work,&VEC_VV(0));CHKERRQ(ierr);
ierr = VecAXPY(Znext,-*HH(it-1,it-1),Zcur);CHKERRQ(ierr);
/* Orthogonalize Zcur against existing basis vectors. */
for (k=0; k<it; k++) work[k] = -*HH(k,it-1);
ierr = VecMAXPY(Zcur,it,work,&VEC_VV(0));CHKERRQ(ierr);
/* Zcur is now orthogonal, and will be referred to as VEC_VV(it) again, though it is still not normalized. */
/* Begin computing the norm of the new vector, will be normalized after the MatMult in the next iteration. */
ierr = VecNormBegin(VEC_VV(it),NORM_2,&newnorm);CHKERRQ(ierr);
}
/* Compute column of H (to the diagonal, but not the subdiagonal) to be able to orthogonalize the newest vector. */
ierr = VecMDotBegin(Znext,it+1,&VEC_VV(0),HH(0,it));CHKERRQ(ierr);
/* Start an asynchronous split-mode reduction, the result of the MDot and Norm will be collected on the next iteration. */
ierr = PetscCommSplitReductionBegin(PetscObjectComm((PetscObject)Znext));CHKERRQ(ierr);
}
if (itcount) *itcount = it-1; /* Number of iterations actually completed. */
/*
Down here we have to solve for the "best" coefficients of the Krylov
columns, add the solution values together, and possibly unwind the
preconditioning from the solution
*/
/* Form the solution (or the solution so far) */
ierr = KSPPGMRESBuildSoln(RS(0),ksp->vec_sol,ksp->vec_sol,ksp,it-2);CHKERRQ(ierr);
PetscFunctionReturn(0);
}
static PetscErrorCode KSPLGMRESBuildSoln(PetscScalar *nrs,Vec vguess,Vec vdest,KSP ksp,PetscInt it)
{
PetscScalar tt;
PetscErrorCode ierr;
PetscInt ii,k,j;
KSP_LGMRES *lgmres = (KSP_LGMRES*)(ksp->data);
/*LGMRES_MOD */
PetscInt it_arnoldi, it_aug;
PetscInt jj, spot = 0;
PetscFunctionBegin;
/* Solve for solution vector that minimizes the residual */
/* If it is < 0, no lgmres steps have been performed */
if (it < 0) {
ierr = VecCopy(vguess,vdest);CHKERRQ(ierr); /* VecCopy() is smart, exists immediately if vguess == vdest */
PetscFunctionReturn(0);
}
/* so (it+1) lgmres steps HAVE been performed */
/* LGMRES_MOD - determine if we need to use augvecs for the soln - do not assume that
this is called after the total its allowed for an approx space */
if (lgmres->approx_constant) {
it_arnoldi = lgmres->max_k - lgmres->aug_ct;
} else {
it_arnoldi = lgmres->max_k - lgmres->aug_dim;
}
if (it_arnoldi >= it +1) {
it_aug = 0;
it_arnoldi = it+1;
} else {
it_aug = (it + 1) - it_arnoldi;
}
/* now it_arnoldi indicates the number of matvecs that took place */
lgmres->matvecs += it_arnoldi;
/* solve the upper triangular system - GRS is the right side and HH is
the upper triangular matrix - put soln in nrs */
if (*HH(it,it) == 0.0) SETERRQ2(PETSC_COMM_SELF,PETSC_ERR_CONV_FAILED,"HH(it,it) is identically zero; it = %D GRS(it) = %G",it,PetscAbsScalar(*GRS(it)));
if (*HH(it,it) != 0.0) {
nrs[it] = *GRS(it) / *HH(it,it);
} else {
nrs[it] = 0.0;
}
for (ii=1; ii<=it; ii++) {
k = it - ii;
tt = *GRS(k);
for (j=k+1; j<=it; j++) tt = tt - *HH(k,j) * nrs[j];
nrs[k] = tt / *HH(k,k);
}
/* Accumulate the correction to the soln of the preconditioned prob. in VEC_TEMP */
ierr = VecSet(VEC_TEMP,0.0);CHKERRQ(ierr); /* set VEC_TEMP components to 0 */
/*LGMRES_MOD - if augmenting has happened we need to form the solution
using the augvecs */
if (!it_aug) { /* all its are from arnoldi */
ierr = VecMAXPY(VEC_TEMP,it+1,nrs,&VEC_VV(0));CHKERRQ(ierr);
} else { /*use aug vecs */
/*first do regular krylov directions */
ierr = VecMAXPY(VEC_TEMP,it_arnoldi,nrs,&VEC_VV(0));CHKERRQ(ierr);
/*now add augmented portions - add contribution of aug vectors one at a time*/
for (ii=0; ii<it_aug; ii++) {
for (jj=0; jj<lgmres->aug_dim; jj++) {
if (lgmres->aug_order[jj] == (ii+1)) {
spot = jj;
break; /* must have this because there will be duplicates before aug_ct = aug_dim */
}
}
ierr = VecAXPY(VEC_TEMP,nrs[it_arnoldi+ii],AUGVEC(spot));CHKERRQ(ierr);
}
}
/* now VEC_TEMP is what we want to keep for augmenting purposes - grab before the
preconditioner is "unwound" from right-precondtioning*/
ierr = VecCopy(VEC_TEMP, AUG_TEMP);CHKERRQ(ierr);
ierr = KSPUnwindPreconditioner(ksp,VEC_TEMP,VEC_TEMP_MATOP);CHKERRQ(ierr);
/* add solution to previous solution */
/* put updated solution into vdest.*/
ierr = VecCopy(vguess,vdest);CHKERRQ(ierr);
ierr = VecAXPY(vdest,1.0,VEC_TEMP);CHKERRQ(ierr);
PetscFunctionReturn(0);
}
void
PetscNonlinearSolver<T>::build_mat_null_space(NonlinearImplicitSystem::ComputeVectorSubspace* computeSubspaceObject,
void (*computeSubspace)(std::vector<NumericVector<Number>*>&, sys_type&),
MatNullSpace *msp)
{
PetscErrorCode ierr;
std::vector<NumericVector<Number>* > sp;
if (computeSubspaceObject)
(*computeSubspaceObject)(sp, this->system());
else
(*computeSubspace)(sp, this->system());
*msp = PETSC_NULL;
if (sp.size())
{
Vec *modes;
PetscScalar *dots;
PetscInt nmodes = sp.size();
ierr = PetscMalloc2(nmodes,Vec,&modes,nmodes,PetscScalar,&dots);
LIBMESH_CHKERRABORT(ierr);
for (PetscInt i=0; i<nmodes; ++i)
{
PetscVector<T>* pv = libmesh_cast_ptr<PetscVector<T>*>(sp[i]);
Vec v = pv->vec();
ierr = VecDuplicate(v, modes+i);
LIBMESH_CHKERRABORT(ierr);
ierr = VecCopy(v,modes[i]);
LIBMESH_CHKERRABORT(ierr);
}
// Normalize.
ierr = VecNormalize(modes[0],PETSC_NULL);
LIBMESH_CHKERRABORT(ierr);
for (PetscInt i=1; i<nmodes; i++)
{
// Orthonormalize vec[i] against vec[0:i-1]
ierr = VecMDot(modes[i],i,modes,dots);
LIBMESH_CHKERRABORT(ierr);
for (PetscInt j=0; j<i; j++)
dots[j] *= -1.;
ierr = VecMAXPY(modes[i],i,dots,modes);
LIBMESH_CHKERRABORT(ierr);
ierr = VecNormalize(modes[i],PETSC_NULL);
LIBMESH_CHKERRABORT(ierr);
}
ierr = MatNullSpaceCreate(this->comm().get(), PETSC_FALSE, nmodes, modes, msp);
LIBMESH_CHKERRABORT(ierr);
for (PetscInt i=0; i<nmodes; ++i)
{
ierr = VecDestroy(modes+i);
LIBMESH_CHKERRABORT(ierr);
}
ierr = PetscFree2(modes,dots);
LIBMESH_CHKERRABORT(ierr);
}
}
static PetscErrorCode KSPPIPEFGMRESCycle(PetscInt *itcount,KSP ksp)
{
KSP_PIPEFGMRES *pipefgmres = (KSP_PIPEFGMRES*)(ksp->data);
PetscReal res_norm;
PetscReal hapbnd,tt;
PetscScalar *hh,*hes,*lhh,shift = pipefgmres->shift;
PetscBool hapend = PETSC_FALSE; /* indicates happy breakdown ending */
PetscErrorCode ierr;
PetscInt loc_it; /* local count of # of dir. in Krylov space */
PetscInt max_k = pipefgmres->max_k; /* max # of directions Krylov space */
PetscInt i,j,k;
Mat Amat,Pmat;
Vec Q,W; /* Pipelining vectors */
Vec *redux = pipefgmres->redux; /* workspace for single reduction */
PetscFunctionBegin;
if (itcount) *itcount = 0;
/* Assign simpler names to these vectors, allocated as pipelining workspace */
Q = VEC_Q;
W = VEC_W;
/* Allocate memory for orthogonalization work (freed in the GMRES Destroy routine)*/
/* Note that we add an extra value here to allow for a single reduction */
if (!pipefgmres->orthogwork) { ierr = PetscMalloc1(pipefgmres->max_k + 2 ,&pipefgmres->orthogwork);CHKERRQ(ierr);
}
lhh = pipefgmres->orthogwork;
/* Number of pseudo iterations since last restart is the number
of prestart directions */
loc_it = 0;
/* note: (pipefgmres->it) is always set one less than (loc_it) It is used in
KSPBUILDSolution_PIPEFGMRES, where it is passed to KSPPIPEFGMRESBuildSoln.
Note that when KSPPIPEFGMRESBuildSoln is called from this function,
(loc_it -1) is passed, so the two are equivalent */
pipefgmres->it = (loc_it - 1);
/* initial residual is in VEC_VV(0) - compute its norm*/
ierr = VecNorm(VEC_VV(0),NORM_2,&res_norm);CHKERRQ(ierr);
/* first entry in right-hand-side of hessenberg system is just
the initial residual norm */
*RS(0) = res_norm;
ksp->rnorm = res_norm;
ierr = KSPLogResidualHistory(ksp,res_norm);CHKERRQ(ierr);
ierr = KSPMonitor(ksp,ksp->its,res_norm);CHKERRQ(ierr);
/* check for the convergence - maybe the current guess is good enough */
ierr = (*ksp->converged)(ksp,ksp->its,res_norm,&ksp->reason,ksp->cnvP);CHKERRQ(ierr);
if (ksp->reason) {
if (itcount) *itcount = 0;
PetscFunctionReturn(0);
}
/* scale VEC_VV (the initial residual) */
ierr = VecScale(VEC_VV(0),1.0/res_norm);CHKERRQ(ierr);
/* Fill the pipeline */
ierr = KSP_PCApply(ksp,VEC_VV(loc_it),PREVEC(loc_it));CHKERRQ(ierr);
ierr = PCGetOperators(ksp->pc,&Amat,&Pmat);CHKERRQ(ierr);
ierr = KSP_MatMult(ksp,Amat,PREVEC(loc_it),ZVEC(loc_it));CHKERRQ(ierr);
ierr = VecAXPY(ZVEC(loc_it),-shift,VEC_VV(loc_it));CHKERRQ(ierr); /* Note shift */
/* MAIN ITERATION LOOP BEGINNING*/
/* keep iterating until we have converged OR generated the max number
of directions OR reached the max number of iterations for the method */
while (!ksp->reason && loc_it < max_k && ksp->its < ksp->max_it) {
if (loc_it) {
ierr = KSPLogResidualHistory(ksp,res_norm);CHKERRQ(ierr);
ierr = KSPMonitor(ksp,ksp->its,res_norm);CHKERRQ(ierr);
}
pipefgmres->it = (loc_it - 1);
/* see if more space is needed for work vectors */
if (pipefgmres->vv_allocated <= loc_it + VEC_OFFSET + 1) {
ierr = KSPPIPEFGMRESGetNewVectors(ksp,loc_it+1);CHKERRQ(ierr);
/* (loc_it+1) is passed in as number of the first vector that should
be allocated */
}
/* Note that these inner products are with "Z" now, so
in particular, lhh[loc_it] is the 'barred' or 'shifted' value,
not the value from the equivalent FGMRES run (even in exact arithmetic)
That is, the H we need for the Arnoldi relation is different from the
coefficients we use in the orthogonalization process,because of the shift */
/* Do some local twiddling to allow for a single reduction */
for(i=0;i<loc_it+1;i++){
redux[i] = VEC_VV(i);
}
redux[loc_it+1] = ZVEC(loc_it);
/* note the extra dot product which ends up in lh[loc_it+1], which computes ||z||^2 */
ierr = VecMDotBegin(ZVEC(loc_it),loc_it+2,redux,lhh);CHKERRQ(ierr);
/* Start the split reduction (This actually calls the MPI_Iallreduce, otherwise, the reduction is simply delayed until the "end" call)*/
ierr = PetscCommSplitReductionBegin(PetscObjectComm((PetscObject)ZVEC(loc_it)));CHKERRQ(ierr);
/* The work to be overlapped with the inner products follows.
This is application of the preconditioner and the operator
to compute intermediate quantites which will be combined (locally)
with the results of the inner products.
*/
ierr = KSP_PCApply(ksp,ZVEC(loc_it),Q);CHKERRQ(ierr);
ierr = PCGetOperators(ksp->pc,&Amat,&Pmat);CHKERRQ(ierr);
ierr = KSP_MatMult(ksp,Amat,Q,W);CHKERRQ(ierr);
/* Compute inner products of the new direction with previous directions,
and the norm of the to-be-orthogonalized direction "Z".
This information is enough to build the required entries
of H. The inner product with VEC_VV(it_loc) is
*different* than in the standard FGMRES and need to be dealt with specially.
That is, for standard FGMRES the orthogonalization coefficients are the same
as the coefficients used in the Arnoldi relation to reconstruct, but here this
is not true (albeit only for the one entry of H which we "unshift" below. */
/* Finish the dot product, retrieving the extra entry */
ierr = VecMDotEnd(ZVEC(loc_it),loc_it+2,redux,lhh);CHKERRQ(ierr);
tt = PetscRealPart(lhh[loc_it+1]);
/* Hessenberg entries, and entries for (naive) classical Graham-Schmidt
Note that the Hessenberg entries require a shift, as these are for the
relation AU = VH, which is wrt unshifted basis vectors */
hh = HH(0,loc_it); hes=HES(0,loc_it);
for (j=0; j<loc_it; j++) {
hh[j] = lhh[j];
hes[j] = lhh[j];
}
hh[loc_it] = lhh[loc_it] + shift;
hes[loc_it] = lhh[loc_it] + shift;
/* we delay applying the shift here */
for (j=0; j<=loc_it; j++) {
lhh[j] = -lhh[j]; /* flip sign */
}
/* Compute the norm of the un-normalized new direction using the rearranged formula
Note that these are shifted ("barred") quantities */
for(k=0;k<=loc_it;k++) tt -= ((PetscReal)(PetscAbsScalar(lhh[k]) * PetscAbsScalar(lhh[k])));
/* On AVX512 this is accumulating roundoff errors for eg: tt=-2.22045e-16 */
if ((tt < 0.0) && tt > -PETSC_SMALL) tt = 0.0 ;
if (tt < 0.0) {
/* If we detect square root breakdown in the norm, we must restart the algorithm.
Here this means we simply break the current loop and reconstruct the solution
using the basis we have computed thus far. Note that by breaking immediately,
we do not update the iteration count, so computation done in this iteration
should be disregarded.
*/
ierr = PetscInfo2(ksp,"Restart due to square root breakdown at it = %D, tt=%g\n",ksp->its,(double)tt);CHKERRQ(ierr);
break;
} else {
tt = PetscSqrtReal(tt);
}
/* new entry in hessenburg is the 2-norm of our new direction */
hh[loc_it+1] = tt;
hes[loc_it+1] = tt;
/* The recurred computation for the new direction
The division by tt is delayed to the happy breakdown check later
Note placement BEFORE the unshift
*/
ierr = VecCopy(ZVEC(loc_it),VEC_VV(loc_it+1));CHKERRQ(ierr);
ierr = VecMAXPY(VEC_VV(loc_it+1),loc_it+1,lhh,&VEC_VV(0));CHKERRQ(ierr);
/* (VEC_VV(loc_it+1) is not normalized yet) */
/* The recurred computation for the preconditioned vector (u) */
ierr = VecCopy(Q,PREVEC(loc_it+1));CHKERRQ(ierr);
ierr = VecMAXPY(PREVEC(loc_it+1),loc_it+1,lhh,&PREVEC(0));CHKERRQ(ierr);
ierr = VecScale(PREVEC(loc_it+1),1.0/tt);CHKERRQ(ierr);
/* Unshift an entry in the GS coefficients ("removing the bar") */
lhh[loc_it] -= shift;
/* The recurred computation for z (Au)
Note placement AFTER the "unshift" */
ierr = VecCopy(W,ZVEC(loc_it+1));CHKERRQ(ierr);
ierr = VecMAXPY(ZVEC(loc_it+1),loc_it+1,lhh,&ZVEC(0));CHKERRQ(ierr);
ierr = VecScale(ZVEC(loc_it+1),1.0/tt);CHKERRQ(ierr);
/* Happy Breakdown Check */
hapbnd = PetscAbsScalar((tt) / *RS(loc_it));
/* RS(loc_it) contains the res_norm from the last iteration */
hapbnd = PetscMin(pipefgmres->haptol,hapbnd);
if (tt > hapbnd) {
/* scale new direction by its norm */
ierr = VecScale(VEC_VV(loc_it+1),1.0/tt);CHKERRQ(ierr);
} else {
/* This happens when the solution is exactly reached. */
/* So there is no new direction... */
ierr = VecSet(VEC_TEMP,0.0);CHKERRQ(ierr); /* set VEC_TEMP to 0 */
hapend = PETSC_TRUE;
}
/* note that for pipefgmres we could get HES(loc_it+1, loc_it) = 0 and the
current solution would not be exact if HES was singular. Note that
HH non-singular implies that HES is not singular, and HES is guaranteed
to be nonsingular when PREVECS are linearly independent and A is
nonsingular (in GMRES, the nonsingularity of A implies the nonsingularity
of HES). So we should really add a check to verify that HES is nonsingular.*/
/* Note that to be thorough, in debug mode, one could call a LAPACK routine
here to check that the hessenberg matrix is indeed non-singular (since
FGMRES does not guarantee this) */
/* Now apply rotations to new col of hessenberg (and right side of system),
calculate new rotation, and get new residual norm at the same time*/
ierr = KSPPIPEFGMRESUpdateHessenberg(ksp,loc_it,&hapend,&res_norm);CHKERRQ(ierr);
if (ksp->reason) break;
loc_it++;
pipefgmres->it = (loc_it-1); /* Add this here in case it has converged */
ierr = PetscObjectSAWsTakeAccess((PetscObject)ksp);CHKERRQ(ierr);
ksp->its++;
ksp->rnorm = res_norm;
ierr = PetscObjectSAWsGrantAccess((PetscObject)ksp);CHKERRQ(ierr);
ierr = (*ksp->converged)(ksp,ksp->its,res_norm,&ksp->reason,ksp->cnvP);CHKERRQ(ierr);
/* Catch error in happy breakdown and signal convergence and break from loop */
if (hapend) {
if (!ksp->reason) {
if (ksp->errorifnotconverged) SETERRQ1(PetscObjectComm((PetscObject)ksp),PETSC_ERR_NOT_CONVERGED,"You reached the happy break down, but convergence was not indicated. Residual norm = %g",(double)res_norm);
else {
ksp->reason = KSP_DIVERGED_BREAKDOWN;
break;
}
}
}
}
/* END OF ITERATION LOOP */
ierr = KSPLogResidualHistory(ksp,res_norm);CHKERRQ(ierr);
/*
Monitor if we know that we will not return for a restart */
if (loc_it && (ksp->reason || ksp->its >= ksp->max_it)) {
ierr = KSPMonitor(ksp,ksp->its,res_norm);CHKERRQ(ierr);
}
if (itcount) *itcount = loc_it;
/*
Down here we have to solve for the "best" coefficients of the Krylov
columns, add the solution values together, and possibly unwind the
preconditioning from the solution
*/
/* Form the solution (or the solution so far) */
/* Note: must pass in (loc_it-1) for iteration count so that KSPPIPEGMRESIIBuildSoln
properly navigates */
ierr = KSPPIPEFGMRESBuildSoln(RS(0),ksp->vec_sol,ksp->vec_sol,ksp,loc_it-1);CHKERRQ(ierr);
PetscFunctionReturn(0);
}
static PetscErrorCode KSPSolve_BCGSL(KSP ksp)
{
KSP_BCGSL *bcgsl = (KSP_BCGSL*) ksp->data;
PetscScalar alpha, beta, omega, sigma;
PetscScalar rho0, rho1;
PetscReal kappa0, kappaA, kappa1;
PetscReal ghat;
PetscReal zeta, zeta0, rnmax_computed, rnmax_true, nrm0;
PetscBool bUpdateX;
PetscInt maxit;
PetscInt h, i, j, k, vi, ell;
PetscBLASInt ldMZ,bierr;
PetscScalar utb;
PetscReal max_s, pinv_tol;
PetscErrorCode ierr;
PetscFunctionBegin;
/* set up temporary vectors */
vi = 0;
ell = bcgsl->ell;
bcgsl->vB = ksp->work[vi]; vi++;
bcgsl->vRt = ksp->work[vi]; vi++;
bcgsl->vTm = ksp->work[vi]; vi++;
bcgsl->vvR = ksp->work+vi; vi += ell+1;
bcgsl->vvU = ksp->work+vi; vi += ell+1;
bcgsl->vXr = ksp->work[vi]; vi++;
ierr = PetscBLASIntCast(ell+1,&ldMZ);CHKERRQ(ierr);
/* Prime the iterative solver */
ierr = KSPInitialResidual(ksp, VX, VTM, VB, VVR[0], ksp->vec_rhs);CHKERRQ(ierr);
ierr = VecNorm(VVR[0], NORM_2, &zeta0);CHKERRQ(ierr);
rnmax_computed = zeta0;
rnmax_true = zeta0;
ierr = (*ksp->converged)(ksp, 0, zeta0, &ksp->reason, ksp->cnvP);CHKERRQ(ierr);
if (ksp->reason) {
ierr = PetscObjectAMSTakeAccess((PetscObject)ksp);CHKERRQ(ierr);
ksp->its = 0;
ksp->rnorm = zeta0;
ierr = PetscObjectAMSGrantAccess((PetscObject)ksp);CHKERRQ(ierr);
PetscFunctionReturn(0);
}
ierr = VecSet(VVU[0],0.0);CHKERRQ(ierr);
alpha = 0.;
rho0 = omega = 1;
if (bcgsl->delta>0.0) {
ierr = VecCopy(VX, VXR);CHKERRQ(ierr);
ierr = VecSet(VX,0.0);CHKERRQ(ierr);
ierr = VecCopy(VVR[0], VB);CHKERRQ(ierr);
} else {
ierr = VecCopy(ksp->vec_rhs, VB);CHKERRQ(ierr);
}
/* Life goes on */
ierr = VecCopy(VVR[0], VRT);CHKERRQ(ierr);
zeta = zeta0;
ierr = KSPGetTolerances(ksp, NULL, NULL, NULL, &maxit);CHKERRQ(ierr);
for (k=0; k<maxit; k += bcgsl->ell) {
ksp->its = k;
ksp->rnorm = zeta;
ierr = KSPLogResidualHistory(ksp, zeta);CHKERRQ(ierr);
ierr = KSPMonitor(ksp, ksp->its, zeta);CHKERRQ(ierr);
ierr = (*ksp->converged)(ksp, k, zeta, &ksp->reason, ksp->cnvP);CHKERRQ(ierr);
if (ksp->reason < 0) PetscFunctionReturn(0);
else if (ksp->reason) break;
/* BiCG part */
rho0 = -omega*rho0;
nrm0 = zeta;
for (j=0; j<bcgsl->ell; j++) {
/* rho1 <- r_j' * r_tilde */
ierr = VecDot(VVR[j], VRT, &rho1);CHKERRQ(ierr);
if (rho1 == 0.0) {
ksp->reason = KSP_DIVERGED_BREAKDOWN_BICG;
PetscFunctionReturn(0);
}
beta = alpha*(rho1/rho0);
rho0 = rho1;
for (i=0; i<=j; i++) {
/* u_i <- r_i - beta*u_i */
ierr = VecAYPX(VVU[i], -beta, VVR[i]);CHKERRQ(ierr);
}
/* u_{j+1} <- inv(K)*A*u_j */
ierr = KSP_PCApplyBAorAB(ksp, VVU[j], VVU[j+1], VTM);CHKERRQ(ierr);
ierr = VecDot(VVU[j+1], VRT, &sigma);CHKERRQ(ierr);
if (sigma == 0.0) {
ksp->reason = KSP_DIVERGED_BREAKDOWN_BICG;
PetscFunctionReturn(0);
}
alpha = rho1/sigma;
/* x <- x + alpha*u_0 */
ierr = VecAXPY(VX, alpha, VVU[0]);CHKERRQ(ierr);
for (i=0; i<=j; i++) {
/* r_i <- r_i - alpha*u_{i+1} */
ierr = VecAXPY(VVR[i], -alpha, VVU[i+1]);CHKERRQ(ierr);
}
/* r_{j+1} <- inv(K)*A*r_j */
ierr = KSP_PCApplyBAorAB(ksp, VVR[j], VVR[j+1], VTM);CHKERRQ(ierr);
ierr = VecNorm(VVR[0], NORM_2, &nrm0);CHKERRQ(ierr);
if (bcgsl->delta>0.0) {
if (rnmax_computed<nrm0) rnmax_computed = nrm0;
if (rnmax_true<nrm0) rnmax_true = nrm0;
}
/* NEW: check for early exit */
ierr = (*ksp->converged)(ksp, k+j, nrm0, &ksp->reason, ksp->cnvP);CHKERRQ(ierr);
if (ksp->reason) {
ierr = PetscObjectAMSTakeAccess((PetscObject)ksp);CHKERRQ(ierr);
ksp->its = k+j;
ksp->rnorm = nrm0;
ierr = PetscObjectAMSGrantAccess((PetscObject)ksp);CHKERRQ(ierr);
if (ksp->reason < 0) PetscFunctionReturn(0);
}
}
/* Polynomial part */
for (i = 0; i <= bcgsl->ell; ++i) {
ierr = VecMDot(VVR[i], i+1, VVR, &MZa[i*ldMZ]);CHKERRQ(ierr);
}
/* Symmetrize MZa */
for (i = 0; i <= bcgsl->ell; ++i) {
for (j = i+1; j <= bcgsl->ell; ++j) {
MZa[i*ldMZ+j] = MZa[j*ldMZ+i] = PetscConj(MZa[j*ldMZ+i]);
}
}
/* Copy MZa to MZb */
ierr = PetscMemcpy(MZb,MZa,ldMZ*ldMZ*sizeof(PetscScalar));CHKERRQ(ierr);
if (!bcgsl->bConvex || bcgsl->ell==1) {
PetscBLASInt ione = 1,bell;
ierr = PetscBLASIntCast(bcgsl->ell,&bell);CHKERRQ(ierr);
AY0c[0] = -1;
if (bcgsl->pinv) {
#if defined(PETSC_MISSING_LAPACK_GESVD)
SETERRQ(PETSC_COMM_SELF,PETSC_ERR_SUP,"GESVD - Lapack routine is unavailable.");
#else
# if defined(PETSC_USE_COMPLEX)
PetscStackCall("LAPACKgesvd",LAPACKgesvd_("A","A",&bell,&bell,&MZa[1+ldMZ],&ldMZ,bcgsl->s,bcgsl->u,&bell,bcgsl->v,&bell,bcgsl->work,&bcgsl->lwork,bcgsl->realwork,&bierr));
# else
PetscStackCall("LAPACKgesvd",LAPACKgesvd_("A","A",&bell,&bell,&MZa[1+ldMZ],&ldMZ,bcgsl->s,bcgsl->u,&bell,bcgsl->v,&bell,bcgsl->work,&bcgsl->lwork,&bierr));
# endif
#endif
if (bierr!=0) {
ksp->reason = KSP_DIVERGED_BREAKDOWN;
PetscFunctionReturn(0);
}
/* Apply pseudo-inverse */
max_s = bcgsl->s[0];
for (i=1; i<bell; i++) {
if (bcgsl->s[i] > max_s) {
max_s = bcgsl->s[i];
}
}
/* tolerance is hardwired to bell*max(s)*PETSC_MACHINE_EPSILON */
pinv_tol = bell*max_s*PETSC_MACHINE_EPSILON;
ierr = PetscMemzero(&AY0c[1],bell*sizeof(PetscScalar));CHKERRQ(ierr);
for (i=0; i<bell; i++) {
if (bcgsl->s[i] >= pinv_tol) {
utb=0.;
for (j=0; j<bell; j++) {
utb += MZb[1+j]*bcgsl->u[i*bell+j];
}
for (j=0; j<bell; j++) {
AY0c[1+j] += utb/bcgsl->s[i]*bcgsl->v[j*bell+i];
}
}
}
} else {
#if defined(PETSC_MISSING_LAPACK_POTRF)
SETERRQ(PETSC_COMM_SELF,PETSC_ERR_SUP,"POTRF - Lapack routine is unavailable.");
#else
PetscStackCall("LAPACKpotrf",LAPACKpotrf_("Lower", &bell, &MZa[1+ldMZ], &ldMZ, &bierr));
#endif
if (bierr!=0) {
ksp->reason = KSP_DIVERGED_BREAKDOWN;
PetscFunctionReturn(0);
}
ierr = PetscMemcpy(&AY0c[1],&MZb[1],bcgsl->ell*sizeof(PetscScalar));CHKERRQ(ierr);
PetscStackCall("LAPACKpotrs",LAPACKpotrs_("Lower", &bell, &ione, &MZa[1+ldMZ], &ldMZ, &AY0c[1], &ldMZ, &bierr));
}
} else {
PetscBLASInt ione = 1;
PetscScalar aone = 1.0, azero = 0.0;
PetscBLASInt neqs;
ierr = PetscBLASIntCast(bcgsl->ell-1,&neqs);CHKERRQ(ierr);
#if defined(PETSC_MISSING_LAPACK_POTRF)
SETERRQ(PETSC_COMM_SELF,PETSC_ERR_SUP,"POTRF - Lapack routine is unavailable.");
#else
PetscStackCall("LAPACKpotrf",LAPACKpotrf_("Lower", &neqs, &MZa[1+ldMZ], &ldMZ, &bierr));
#endif
if (bierr!=0) {
ksp->reason = KSP_DIVERGED_BREAKDOWN;
PetscFunctionReturn(0);
}
ierr = PetscMemcpy(&AY0c[1],&MZb[1],(bcgsl->ell-1)*sizeof(PetscScalar));CHKERRQ(ierr);
PetscStackCall("LAPACKpotrs",LAPACKpotrs_("Lower", &neqs, &ione, &MZa[1+ldMZ], &ldMZ, &AY0c[1], &ldMZ, &bierr));
AY0c[0] = -1;
AY0c[bcgsl->ell] = 0.;
ierr = PetscMemcpy(&AYlc[1],&MZb[1+ldMZ*(bcgsl->ell)],(bcgsl->ell-1)*sizeof(PetscScalar));CHKERRQ(ierr);
PetscStackCall("LAPACKpotrs",LAPACKpotrs_("Lower", &neqs, &ione, &MZa[1+ldMZ], &ldMZ, &AYlc[1], &ldMZ, &bierr));
AYlc[0] = 0.;
AYlc[bcgsl->ell] = -1;
PetscStackCall("BLASgemv",BLASgemv_("NoTr", &ldMZ, &ldMZ, &aone, MZb, &ldMZ, AY0c, &ione, &azero, AYtc, &ione));
kappa0 = PetscRealPart(BLASdot_(&ldMZ, AY0c, &ione, AYtc, &ione));
/* round-off can cause negative kappa's */
if (kappa0<0) kappa0 = -kappa0;
kappa0 = PetscSqrtReal(kappa0);
kappaA = PetscRealPart(BLASdot_(&ldMZ, AYlc, &ione, AYtc, &ione));
PetscStackCall("BLASgemv",BLASgemv_("noTr", &ldMZ, &ldMZ, &aone, MZb, &ldMZ, AYlc, &ione, &azero, AYtc, &ione));
kappa1 = PetscRealPart(BLASdot_(&ldMZ, AYlc, &ione, AYtc, &ione));
if (kappa1<0) kappa1 = -kappa1;
kappa1 = PetscSqrtReal(kappa1);
if (kappa0!=0.0 && kappa1!=0.0) {
if (kappaA<0.7*kappa0*kappa1) {
ghat = (kappaA<0.0) ? -0.7*kappa0/kappa1 : 0.7*kappa0/kappa1;
} else {
ghat = kappaA/(kappa1*kappa1);
}
for (i=0; i<=bcgsl->ell; i++) {
AY0c[i] = AY0c[i] - ghat* AYlc[i];
}
}
}
omega = AY0c[bcgsl->ell];
for (h=bcgsl->ell; h>0 && omega==0.0; h--) omega = AY0c[h];
if (omega==0.0) {
ksp->reason = KSP_DIVERGED_BREAKDOWN;
PetscFunctionReturn(0);
}
ierr = VecMAXPY(VX, bcgsl->ell,AY0c+1, VVR);CHKERRQ(ierr);
for (i=1; i<=bcgsl->ell; i++) AY0c[i] *= -1.0;
ierr = VecMAXPY(VVU[0], bcgsl->ell,AY0c+1, VVU+1);CHKERRQ(ierr);
ierr = VecMAXPY(VVR[0], bcgsl->ell,AY0c+1, VVR+1);CHKERRQ(ierr);
for (i=1; i<=bcgsl->ell; i++) AY0c[i] *= -1.0;
ierr = VecNorm(VVR[0], NORM_2, &zeta);CHKERRQ(ierr);
/* Accurate Update */
if (bcgsl->delta>0.0) {
if (rnmax_computed<zeta) rnmax_computed = zeta;
if (rnmax_true<zeta) rnmax_true = zeta;
bUpdateX = (PetscBool) (zeta<bcgsl->delta*zeta0 && zeta0<=rnmax_computed);
if ((zeta<bcgsl->delta*rnmax_true && zeta0<=rnmax_true) || bUpdateX) {
/* r0 <- b-inv(K)*A*X */
ierr = KSP_PCApplyBAorAB(ksp, VX, VVR[0], VTM);CHKERRQ(ierr);
ierr = VecAYPX(VVR[0], -1.0, VB);CHKERRQ(ierr);
rnmax_true = zeta;
if (bUpdateX) {
ierr = VecAXPY(VXR,1.0,VX);CHKERRQ(ierr);
ierr = VecSet(VX,0.0);CHKERRQ(ierr);
ierr = VecCopy(VVR[0], VB);CHKERRQ(ierr);
rnmax_computed = zeta;
}
}
}
}
if (bcgsl->delta>0.0) {
ierr = VecAXPY(VX,1.0,VXR);CHKERRQ(ierr);
}
ierr = (*ksp->converged)(ksp, k, zeta, &ksp->reason, ksp->cnvP);CHKERRQ(ierr);
if (!ksp->reason) ksp->reason = KSP_DIVERGED_ITS;
PetscFunctionReturn(0);
}
static PetscErrorCode TSStep_RK(TS ts)
{
TS_RK *rk = (TS_RK*)ts->data;
RKTableau tab = rk->tableau;
const PetscInt s = tab->s;
const PetscReal *A = tab->A,*c = tab->c;
PetscScalar *w = rk->work;
Vec *Y = rk->Y,*YdotRHS = rk->YdotRHS;
TSAdapt adapt;
PetscInt i,j;
PetscInt rejections = 0;
PetscBool stageok,accept = PETSC_TRUE;
PetscReal next_time_step = ts->time_step;
PetscErrorCode ierr;
PetscFunctionBegin;
rk->status = TS_STEP_INCOMPLETE;
while (!ts->reason && rk->status != TS_STEP_COMPLETE) {
PetscReal t = ts->ptime;
PetscReal h = ts->time_step;
for (i=0; i<s; i++) {
rk->stage_time = t + h*c[i];
ierr = TSPreStage(ts,rk->stage_time); CHKERRQ(ierr);
ierr = VecCopy(ts->vec_sol,Y[i]);CHKERRQ(ierr);
for (j=0; j<i; j++) w[j] = h*A[i*s+j];
ierr = VecMAXPY(Y[i],i,w,YdotRHS);CHKERRQ(ierr);
ierr = TSPostStage(ts,rk->stage_time,i,Y); CHKERRQ(ierr);
ierr = TSGetAdapt(ts,&adapt);CHKERRQ(ierr);
ierr = TSAdaptCheckStage(adapt,ts,rk->stage_time,Y[i],&stageok);CHKERRQ(ierr);
if (!stageok) goto reject_step;
ierr = TSComputeRHSFunction(ts,t+h*c[i],Y[i],YdotRHS[i]);CHKERRQ(ierr);
}
rk->status = TS_STEP_INCOMPLETE;
ierr = TSEvaluateStep(ts,tab->order,ts->vec_sol,NULL);CHKERRQ(ierr);
rk->status = TS_STEP_PENDING;
ierr = TSGetAdapt(ts,&adapt);CHKERRQ(ierr);
ierr = TSAdaptCandidatesClear(adapt);CHKERRQ(ierr);
ierr = TSAdaptCandidateAdd(adapt,tab->name,tab->order,1,tab->ccfl,1.*tab->s,PETSC_TRUE);CHKERRQ(ierr);
ierr = TSAdaptChoose(adapt,ts,ts->time_step,NULL,&next_time_step,&accept);CHKERRQ(ierr);
rk->status = accept ? TS_STEP_COMPLETE : TS_STEP_INCOMPLETE;
if (!accept) { /* Roll back the current step */
ierr = TSRollBack_RK(ts);CHKERRQ(ierr);
ts->time_step = next_time_step;
goto reject_step;
}
if (ts->costintegralfwd) { /* Save the info for the later use in cost integral evaluation*/
rk->ptime = ts->ptime;
rk->time_step = ts->time_step;
}
ts->ptime += ts->time_step;
ts->time_step = next_time_step;
break;
reject_step:
ts->reject++; accept = PETSC_FALSE;
if (!ts->reason && ++rejections > ts->max_reject && ts->max_reject >= 0) {
ts->reason = TS_DIVERGED_STEP_REJECTED;
ierr = PetscInfo2(ts,"Step=%D, step rejections %D greater than current TS allowed, stopping solve\n",ts->steps,rejections);CHKERRQ(ierr);
}
}
PetscFunctionReturn(0);
}
/*@
MatNullSpaceCreateRigidBody - create rigid body modes from coordinates
Collective on Vec
Input Argument:
. coords - block of coordinates of each node, must have block size set
Output Argument:
. sp - the null space
Level: advanced
Notes:
If you are solving an elasticity problems you should likely use this, in conjunction with ee MatSetNearNullspace(), to provide information that
the PCGAMG preconditioner can use to construct a much more efficient preconditioner.
If you are solving an elasticity problem with pure Neumann boundary conditions you can use this in conjunction with MatSetNullspace() to
provide this information to the linear solver so it can handle the null space appropriately in the linear solution.
.seealso: MatNullSpaceCreate(), MatSetNearNullspace(), MatSetNullspace()
@*/
PetscErrorCode MatNullSpaceCreateRigidBody(Vec coords,MatNullSpace *sp)
{
PetscErrorCode ierr;
const PetscScalar *x;
PetscScalar *v[6],dots[5];
Vec vec[6];
PetscInt n,N,dim,nmodes,i,j;
PetscReal sN;
PetscFunctionBegin;
ierr = VecGetBlockSize(coords,&dim);CHKERRQ(ierr);
ierr = VecGetLocalSize(coords,&n);CHKERRQ(ierr);
ierr = VecGetSize(coords,&N);CHKERRQ(ierr);
n /= dim;
N /= dim;
sN = 1./PetscSqrtReal((PetscReal)N);
switch (dim) {
case 1:
ierr = MatNullSpaceCreate(PetscObjectComm((PetscObject)coords),PETSC_TRUE,0,NULL,sp);CHKERRQ(ierr);
break;
case 2:
case 3:
nmodes = (dim == 2) ? 3 : 6;
ierr = VecCreate(PetscObjectComm((PetscObject)coords),&vec[0]);CHKERRQ(ierr);
ierr = VecSetSizes(vec[0],dim*n,dim*N);CHKERRQ(ierr);
ierr = VecSetBlockSize(vec[0],dim);CHKERRQ(ierr);
ierr = VecSetUp(vec[0]);CHKERRQ(ierr);
for (i=1; i<nmodes; i++) {ierr = VecDuplicate(vec[0],&vec[i]);CHKERRQ(ierr);}
for (i=0; i<nmodes; i++) {ierr = VecGetArray(vec[i],&v[i]);CHKERRQ(ierr);}
ierr = VecGetArrayRead(coords,&x);CHKERRQ(ierr);
for (i=0; i<n; i++) {
if (dim == 2) {
v[0][i*2+0] = sN;
v[0][i*2+1] = 0.;
v[1][i*2+0] = 0.;
v[1][i*2+1] = sN;
/* Rotations */
v[2][i*2+0] = -x[i*2+1];
v[2][i*2+1] = x[i*2+0];
} else {
v[0][i*3+0] = sN;
v[0][i*3+1] = 0.;
v[0][i*3+2] = 0.;
v[1][i*3+0] = 0.;
v[1][i*3+1] = sN;
v[1][i*3+2] = 0.;
v[2][i*3+0] = 0.;
v[2][i*3+1] = 0.;
v[2][i*3+2] = sN;
v[3][i*3+0] = x[i*3+1];
v[3][i*3+1] = -x[i*3+0];
v[3][i*3+2] = 0.;
v[4][i*3+0] = 0.;
v[4][i*3+1] = -x[i*3+2];
v[4][i*3+2] = x[i*3+1];
v[5][i*3+0] = x[i*3+2];
v[5][i*3+1] = 0.;
v[5][i*3+2] = -x[i*3+0];
}
}
for (i=0; i<nmodes; i++) {ierr = VecRestoreArray(vec[i],&v[i]);CHKERRQ(ierr);}
ierr = VecRestoreArrayRead(coords,&x);CHKERRQ(ierr);
for (i=dim; i<nmodes; i++) {
/* Orthonormalize vec[i] against vec[0:i-1] */
ierr = VecMDot(vec[i],i,vec,dots);CHKERRQ(ierr);
for (j=0; j<i; j++) dots[j] *= -1.;
ierr = VecMAXPY(vec[i],i,dots,vec);CHKERRQ(ierr);
ierr = VecNormalize(vec[i],NULL);CHKERRQ(ierr);
}
ierr = MatNullSpaceCreate(PetscObjectComm((PetscObject)coords),PETSC_FALSE,nmodes,vec,sp);CHKERRQ(ierr);
for (i=0; i<nmodes; i++) {ierr = VecDestroy(&vec[i]);CHKERRQ(ierr);}
}
PetscFunctionReturn(0);
}
static PetscErrorCode KSPAGMRESBuildSoln(KSP ksp,PetscInt it)
{
KSP_AGMRES *agmres = (KSP_AGMRES*)ksp->data;
PetscErrorCode ierr;
PetscInt max_k = agmres->max_k; /* Size of the non-augmented Krylov basis */
PetscInt i, j;
PetscInt r = agmres->r; /* current number of augmented eigenvectors */
PetscBLASInt KspSize;
PetscBLASInt lC;
PetscBLASInt N;
PetscBLASInt ldH = N + 1;
PetscBLASInt lwork;
PetscBLASInt info, nrhs = 1;
PetscFunctionBegin;
ierr = PetscBLASIntCast(KSPSIZE,&KspSize);CHKERRQ(ierr);
ierr = PetscBLASIntCast(4 * (KspSize+1),&lwork);CHKERRQ(ierr);
ierr = PetscBLASIntCast(KspSize+1,&lC);CHKERRQ(ierr);
ierr = PetscBLASIntCast(MAXKSPSIZE + 1,&N);CHKERRQ(ierr);
ierr = PetscBLASIntCast(N + 1,&ldH);CHKERRQ(ierr);
/* Save a copy of the Hessenberg matrix */
for (j = 0; j < N-1; j++) {
for (i = 0; i < N; i++) {
*HS(i,j) = *H(i,j);
}
}
/* QR factorize the Hessenberg matrix */
#if defined(PETSC_MISSING_LAPACK_GEQRF)
SETERRQ(PetscObjectComm((PetscObject)ksp),PETSC_ERR_SUP,"GEQRF - Lapack routine is unavailable.");
#else
PetscStackCallBLAS("LAPACKgeqrf",LAPACKgeqrf_(&lC, &KspSize, agmres->hh_origin, &ldH, agmres->tau, agmres->work, &lwork, &info));
if (info) SETERRQ1(PetscObjectComm((PetscObject)ksp), PETSC_ERR_LIB,"Error in LAPACK routine XGEQRF INFO=%d", info);
#endif
/* Update the right hand side of the least square problem */
ierr = PetscMemzero(agmres->nrs, N*sizeof(PetscScalar));CHKERRQ(ierr);
agmres->nrs[0] = ksp->rnorm;
#if defined(PETSC_MISSING_LAPACK_ORMQR)
SETERRQ(PetscObjectComm((PetscObject)ksp),PETSC_ERR_SUP,"GEQRF - Lapack routine is unavailable.");
#else
PetscStackCallBLAS("LAPACKormqr",LAPACKormqr_("L", "T", &lC, &nrhs, &KspSize, agmres->hh_origin, &ldH, agmres->tau, agmres->nrs, &N, agmres->work, &lwork, &info));
if (info) SETERRQ1(PetscObjectComm((PetscObject)ksp), PETSC_ERR_LIB,"Error in LAPACK routine XORMQR INFO=%d",info);
#endif
ksp->rnorm = PetscAbsScalar(agmres->nrs[KspSize]);
/* solve the least-square problem */
#if defined(PETSC_MISSING_LAPACK_TRTRS)
SETERRQ(PetscObjectComm((PetscObject)ksp),PETSC_ERR_SUP,"TRTRS - Lapack routine is unavailable.");
#else
PetscStackCallBLAS("LAPACKtrtrs",LAPACKtrtrs_("U", "N", "N", &KspSize, &nrhs, agmres->hh_origin, &ldH, agmres->nrs, &N, &info));
if (info) SETERRQ1(PetscObjectComm((PetscObject)ksp), PETSC_ERR_LIB,"Error in LAPACK routine XTRTRS INFO=%d",info);
#endif
/* Accumulate the correction to the solution of the preconditioned problem in VEC_TMP */
ierr = VecZeroEntries(VEC_TMP);CHKERRQ(ierr);
ierr = VecMAXPY(VEC_TMP, max_k, agmres->nrs, &VEC_V(0));CHKERRQ(ierr);
if (!agmres->DeflPrecond) { ierr = VecMAXPY(VEC_TMP, r, &agmres->nrs[max_k], agmres->U);CHKERRQ(ierr); }
if ((ksp->pc_side == PC_RIGHT) && agmres->r && agmres->DeflPrecond) {
ierr = KSPDGMRESApplyDeflation_DGMRES(ksp, VEC_TMP, VEC_TMP_MATOP);CHKERRQ(ierr);
ierr = VecCopy(VEC_TMP_MATOP, VEC_TMP);CHKERRQ(ierr);
}
ierr = KSPUnwindPreconditioner(ksp, VEC_TMP, VEC_TMP_MATOP);CHKERRQ(ierr);
/* add the solution to the previous one */
ierr = VecAXPY(ksp->vec_sol, 1.0, VEC_TMP);CHKERRQ(ierr);
PetscFunctionReturn(0);
}
