static PetscErrorCode TSStep_Euler(TS ts)
{
TS_Euler *euler = (TS_Euler*)ts->data;
Vec sol = ts->vec_sol,update = euler->update;
PetscErrorCode ierr;
PetscFunctionBegin;
ierr = TSPreStep(ts);CHKERRQ(ierr);
ierr = TSPreStage(ts,ts->ptime);CHKERRQ(ierr);
ierr = TSComputeRHSFunction(ts,ts->ptime,sol,update);CHKERRQ(ierr);
ierr = VecAXPY(sol,ts->time_step,update);CHKERRQ(ierr);
ierr = TSPostStage(ts,ts->ptime,0,&sol);CHKERRQ(ierr);
ts->ptime += ts->time_step;
ts->steps++;
PetscFunctionReturn(0);
}
int TSFunction_Sundials(realtype t,N_Vector y,N_Vector ydot,void *ctx)
{
TS ts = (TS) ctx;
MPI_Comm comm = ((PetscObject)ts)->comm;
TS_Sundials *cvode = (TS_Sundials*)ts->data;
Vec yy = cvode->w1,yyd = cvode->w2;
PetscScalar *y_data,*ydot_data;
PetscErrorCode ierr;
PetscFunctionBegin;
/* Make the PETSc work vectors yy and yyd point to the arrays in the SUNDIALS vectors y and ydot respectively*/
y_data = (PetscScalar *) N_VGetArrayPointer(y);
ydot_data = (PetscScalar *) N_VGetArrayPointer(ydot);
ierr = VecPlaceArray(yy,y_data);CHKERRABORT(comm,ierr);
ierr = VecPlaceArray(yyd,ydot_data); CHKERRABORT(comm,ierr);
/* now compute the right hand side function */
ierr = TSComputeRHSFunction(ts,t,yy,yyd); CHKERRABORT(comm,ierr);
ierr = VecResetArray(yy); CHKERRABORT(comm,ierr);
ierr = VecResetArray(yyd); CHKERRABORT(comm,ierr);
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);
}
PetscErrorCode TSRKqs(TS ts,PetscReal t,PetscReal h)
{
TS_RK *rk = (TS_RK*)ts->data;
PetscErrorCode ierr;
PetscInt j,l;
PetscReal tmp_t=t;
PetscScalar hh=h;
PetscFunctionBegin;
/* k[0]=0 */
ierr = VecSet(rk->k[0],0.0);CHKERRQ(ierr);
/* k[0] = derivs(t,y1) */
ierr = TSComputeRHSFunction(ts,t,rk->y1,rk->k[0]);CHKERRQ(ierr);
/* looping over runge-kutta variables */
/* building the k - array of vectors */
for (j = 1 ; j < rk->s ; j++){
/* rk->tmp = 0 */
ierr = VecSet(rk->tmp,0.0);CHKERRQ(ierr);
for (l=0;l<j;l++){
/* tmp += a(j,l)*k[l] */
ierr = VecAXPY(rk->tmp,rk->a[j][l],rk->k[l]);CHKERRQ(ierr);
}
/* ierr = VecView(rk->tmp,PETSC_VIEWER_STDOUT_WORLD);CHKERRQ(ierr); */
/* k[j] = derivs(t+c(j)*h,y1+h*tmp,k(j)) */
/* I need the following helpers:
PetscScalar tmp_t=t+c(j)*h
Vec tmp_y=h*tmp+y1
*/
tmp_t = t + rk->c[j] * h;
/* tmp_y = h * tmp + y1 */
ierr = VecWAXPY(rk->tmp_y,hh,rk->tmp,rk->y1);CHKERRQ(ierr);
/* rk->k[j]=0 */
ierr = VecSet(rk->k[j],0.0);CHKERRQ(ierr);
ierr = TSComputeRHSFunction(ts,tmp_t,rk->tmp_y,rk->k[j]);CHKERRQ(ierr);
}
/* tmp=0 and tmp_y=0 */
ierr = VecSet(rk->tmp,0.0);CHKERRQ(ierr);
ierr = VecSet(rk->tmp_y,0.0);CHKERRQ(ierr);
for (j = 0 ; j < rk->s ; j++){
/* tmp=b1[j]*k[j]+tmp */
ierr = VecAXPY(rk->tmp,rk->b1[j],rk->k[j]);CHKERRQ(ierr);
/* tmp_y=b2[j]*k[j]+tmp_y */
ierr = VecAXPY(rk->tmp_y,rk->b2[j],rk->k[j]);CHKERRQ(ierr);
}
/* y2 = hh * tmp_y */
ierr = VecSet(rk->y2,0.0);CHKERRQ(ierr);
ierr = VecAXPY(rk->y2,hh,rk->tmp_y);CHKERRQ(ierr);
/* y1 = hh*tmp + y1 */
ierr = VecAXPY(rk->y1,hh,rk->tmp);CHKERRQ(ierr);
/* Finding difference between y1 and y2 */
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,*b = tab->b,*c = tab->c;
PetscScalar *w = rk->work;
Vec *Y = rk->Y,*YdotRHS = rk->YdotRHS;
TSAdapt adapt;
PetscInt i,j,reject,next_scheme;
PetscReal next_time_step;
PetscReal t;
PetscBool accept;
PetscErrorCode ierr;
PetscFunctionBegin;
next_time_step = ts->time_step;
t = ts->ptime;
accept = PETSC_TRUE;
rk->status = TS_STEP_INCOMPLETE;
for (reject=0; reject<ts->max_reject && !ts->reason; reject++,ts->reject++) {
PetscReal h = ts->time_step;
ierr = TSPreStep(ts);CHKERRQ(ierr);
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,&accept);CHKERRQ(ierr);
if (!accept) goto reject_step;
ierr = TSComputeRHSFunction(ts,t+h*c[i],Y[i],YdotRHS[i]);CHKERRQ(ierr);
}
ierr = TSEvaluateStep(ts,tab->order,ts->vec_sol,NULL);CHKERRQ(ierr);
rk->status = TS_STEP_PENDING;
/* Register only the current method as a candidate because we're not supporting multiple candidates yet. */
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,&next_scheme,&next_time_step,&accept);CHKERRQ(ierr);
if (accept) {
if (ts->costintegralfwd) {
/* Evolve ts->vec_costintegral to compute integrals */
for (i=0; i<s; i++) {
ierr = TSAdjointComputeCostIntegrand(ts,t+h*c[i],Y[i],ts->vec_costintegrand);CHKERRQ(ierr);
ierr = VecAXPY(ts->vec_costintegral,h*b[i],ts->vec_costintegrand);CHKERRQ(ierr);
}
}
/* ignore next_scheme for now */
ts->ptime += ts->time_step;
ts->time_step = next_time_step;
ts->steps++;
rk->status = TS_STEP_COMPLETE;
ierr = PetscObjectComposedDataSetReal((PetscObject)ts->vec_sol,explicit_stage_time_id,ts->ptime);CHKERRQ(ierr);
break;
} else { /* Roll back the current step */
for (j=0; j<s; j++) w[j] = -h*b[j];
ierr = VecMAXPY(ts->vec_sol,s,w,rk->YdotRHS);CHKERRQ(ierr);
ts->time_step = next_time_step;
rk->status = TS_STEP_INCOMPLETE;
}
reject_step: continue;
}
if (rk->status != TS_STEP_COMPLETE && !ts->reason) ts->reason = TS_DIVERGED_STEP_REJECTED;
PetscFunctionReturn(0);
}
void PETSC_STDCALL tscomputerhsfunction_(TS ts,PetscReal *t,Vec x,Vec y, int *__ierr ){
*__ierr = TSComputeRHSFunction(
(TS)PetscToPointer((ts) ),*t,
(Vec)PetscToPointer((x) ),
(Vec)PetscToPointer((y) ));
}
