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 TSAdaptChoose_Basic(TSAdapt adapt,TS ts,PetscReal h,PetscInt *next_sc,PetscReal *next_h,PetscBool *accept,PetscReal *wlte)
{
TSAdapt_Basic *basic = (TSAdapt_Basic*)adapt->data;
PetscInt order = PETSC_DECIDE;
PetscReal enorm = -1;
PetscReal safety = basic->safety;
PetscReal hfac_lte,h_lte;
PetscErrorCode ierr;
PetscFunctionBegin;
*next_sc = 0; /* Reuse the same order scheme */
if (ts->ops->evaluatewlte) {
ierr = TSEvaluateWLTE(ts,adapt->wnormtype,&order,&enorm);CHKERRQ(ierr);
if (enorm >= 0 && order < 1) SETERRQ1(PetscObjectComm((PetscObject)adapt),PETSC_ERR_ARG_OUTOFRANGE,"Computed error order %D must be positive",order);
} else if (ts->ops->evaluatestep) {
if (adapt->candidates.n < 1) SETERRQ(PetscObjectComm((PetscObject)adapt),PETSC_ERR_ARG_WRONGSTATE,"No candidate has been registered");
if (!adapt->candidates.inuse_set) SETERRQ1(PetscObjectComm((PetscObject)adapt),PETSC_ERR_ARG_WRONGSTATE,"The current in-use scheme is not among the %D candidates",adapt->candidates.n);
if (!basic->Y) {ierr = VecDuplicate(ts->vec_sol,&basic->Y);CHKERRQ(ierr);}
order = adapt->candidates.order[0];
ierr = TSEvaluateStep(ts,order-1,basic->Y,NULL);CHKERRQ(ierr);
ierr = TSErrorWeightedNorm(ts,ts->vec_sol,basic->Y,adapt->wnormtype,&enorm);CHKERRQ(ierr);
}
if (enorm < 0) {
*accept = PETSC_TRUE;
*next_h = h; /* Reuse the old step */
*wlte = -1; /* Weighted local truncation error was not evaluated */
PetscFunctionReturn(0);
}
/* Determine whether the step is accepted of rejected */
if (enorm > 1) {
if (!*accept) safety *= basic->reject_safety; /* The last attempt also failed, shorten more aggressively */
if (h < (1 + PETSC_SQRT_MACHINE_EPSILON)*adapt->dt_min) {
ierr = PetscInfo2(adapt,"Estimated scaled local truncation error %g, accepting because step size %g is at minimum\n",(double)enorm,(double)h);CHKERRQ(ierr);
*accept = PETSC_TRUE;
} else if (basic->always_accept) {
ierr = PetscInfo2(adapt,"Estimated scaled local truncation error %g, accepting step of size %g because always_accept is set\n",(double)enorm,(double)h);CHKERRQ(ierr);
*accept = PETSC_TRUE;
} else {
ierr = PetscInfo2(adapt,"Estimated scaled local truncation error %g, rejecting step of size %g\n",(double)enorm,(double)h);CHKERRQ(ierr);
*accept = PETSC_FALSE;
}
} else {
ierr = PetscInfo2(adapt,"Estimated scaled local truncation error %g, accepting step of size %g\n",(double)enorm,(double)h);CHKERRQ(ierr);
*accept = PETSC_TRUE;
}
/* The optimal new step based purely on local truncation error for this step. */
if (enorm > 0)
hfac_lte = safety * PetscPowReal(enorm,((PetscReal)-1)/order);
else
hfac_lte = safety * PETSC_INFINITY;
h_lte = h * PetscClipInterval(hfac_lte,basic->clip[0],basic->clip[1]);
*next_h = PetscClipInterval(h_lte,adapt->dt_min,adapt->dt_max);
*wlte = enorm;
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);
}
static PetscErrorCode TSStep_EIMEX(TS ts)
{
TS_EIMEX *ext = (TS_EIMEX*)ts->data;
const PetscInt ns = ext->nstages;
Vec *T=ext->T, Y=ext->Y;
SNES snes;
PetscInt i,j;
PetscBool accept = PETSC_FALSE;
PetscErrorCode ierr;
PetscReal alpha,local_error;
PetscFunctionBegin;
ierr = TSGetSNES(ts,&snes);CHKERRQ(ierr);
ierr = SNESSetType(snes,"ksponly"); CHKERRQ(ierr);
ext->status = TS_STEP_INCOMPLETE;
ierr = VecCopy(ts->vec_sol,ext->VecSolPrev);CHKERRQ(ierr);
/* Apply n_j steps of the base method to obtain solutions of T(j,1),1<=j<=s */
for(j=0; j<ns; j++){
ierr = TSStage_EIMEX(ts,j);CHKERRQ(ierr);
ierr = VecCopy(Y,T[j]); CHKERRQ(ierr);
}
for(i=1;i<ns;i++){
for(j=i;j<ns;j++){
alpha = -(PetscReal)ext->N[j]/ext->N[j-i];
ierr = VecAXPBYPCZ(T[Map(j,i,ns)],alpha,1.0,0,T[Map(j,i-1,ns)],T[Map(j-1,i-1,ns)]);/* T[j][i]=alpha*T[j][i-1]+T[j-1][i-1] */CHKERRQ(ierr);
alpha = 1.0/(1.0 + alpha);
ierr = VecScale(T[Map(j,i,ns)],alpha);CHKERRQ(ierr);
}
}
ierr = TSEvaluateStep(ts,ns,ts->vec_sol,NULL);CHKERRQ(ierr);/*update ts solution */
if(ext->ord_adapt && ext->nstages < ext->max_rows){
accept = PETSC_FALSE;
while(!accept && ext->nstages < ext->max_rows){
ierr = TSErrorWeightedNorm(ts,ts->vec_sol,T[Map(ext->nstages-1,ext->nstages-2,ext->nstages)],ts->adapt->wnormtype,&local_error);CHKERRQ(ierr);
accept = (local_error < 1.0)? PETSC_TRUE : PETSC_FALSE;
if(!accept){/* add one more stage*/
ierr = TSStage_EIMEX(ts,ext->nstages);CHKERRQ(ierr);
ext->nstages++; ext->row_ind++; ext->col_ind++;
/*T table need to be recycled*/
ierr = VecDuplicateVecs(ts->vec_sol,(1+ext->nstages)*ext->nstages/2,&ext->T);CHKERRQ(ierr);
for(i=0; i<ext->nstages-1; i++){
for(j=0; j<=i; j++){
ierr = VecCopy(T[Map(i,j,ext->nstages-1)],ext->T[Map(i,j,ext->nstages)]);CHKERRQ(ierr);
}
}
ierr = VecDestroyVecs(ext->nstages*(ext->nstages-1)/2,&T);CHKERRQ(ierr);
T = ext->T; /*reset the pointer*/
/*recycling finished, store the new solution*/
ierr = VecCopy(Y,T[ext->nstages-1]); CHKERRQ(ierr);
/*extrapolation for the newly added stage*/
for(i=1;i<ext->nstages;i++){
alpha = -(PetscReal)ext->N[ext->nstages-1]/ext->N[ext->nstages-1-i];
ierr = VecAXPBYPCZ(T[Map(ext->nstages-1,i,ext->nstages)],alpha,1.0,0,T[Map(ext->nstages-1,i-1,ext->nstages)],T[Map(ext->nstages-1-1,i-1,ext->nstages)]);/*T[ext->nstages-1][i]=alpha*T[ext->nstages-1][i-1]+T[ext->nstages-1-1][i-1]*/CHKERRQ(ierr);
alpha = 1.0/(1.0 + alpha);
ierr = VecScale(T[Map(ext->nstages-1,i,ext->nstages)],alpha);CHKERRQ(ierr);
}
/*update ts solution */
ierr = TSEvaluateStep(ts,ext->nstages,ts->vec_sol,NULL);CHKERRQ(ierr);
}/*end if !accept*/
}/*end while*/
if(ext->nstages == ext->max_rows){
ierr = PetscInfo(ts,"Max number of rows has been used\n");CHKERRQ(ierr);
}
}/*end if ext->ord_adapt*/
ts->ptime += ts->time_step;
ext->status = TS_STEP_COMPLETE;
if (ext->status != TS_STEP_COMPLETE && !ts->reason) ts->reason = TS_DIVERGED_STEP_REJECTED;
PetscFunctionReturn(0);
}
