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);
}
PetscErrorCode TSPrecond_Sundials(realtype tn,N_Vector y,N_Vector fy,
booleantype jok,booleantype *jcurPtr,
realtype _gamma,void *P_data,
N_Vector vtemp1,N_Vector vtemp2,N_Vector vtemp3)
{
TS ts = (TS) P_data;
TS_Sundials *cvode = (TS_Sundials*)ts->data;
PC pc = cvode->pc;
PetscErrorCode ierr;
Mat Jac = ts->B;
Vec yy = cvode->w1;
PetscScalar one = 1.0,gm;
MatStructure str = DIFFERENT_NONZERO_PATTERN;
PetscScalar *y_data;
PetscFunctionBegin;
/* This allows us to construct preconditioners in-place if we like */
ierr = MatSetUnfactored(Jac);CHKERRQ(ierr);
/* jok - TRUE means reuse current Jacobian else recompute Jacobian */
if (jok) {
ierr = MatCopy(cvode->pmat,Jac,str);CHKERRQ(ierr);
*jcurPtr = FALSE;
} else {
/* make PETSc vector yy point to SUNDIALS vector y */
y_data = (PetscScalar *) N_VGetArrayPointer(y);
ierr = VecPlaceArray(yy,y_data); CHKERRQ(ierr);
/* compute the Jacobian */
ierr = TSComputeRHSJacobian(ts,ts->ptime,yy,&Jac,&Jac,&str);CHKERRQ(ierr);
ierr = VecResetArray(yy); CHKERRQ(ierr);
/* copy the Jacobian matrix */
if (!cvode->pmat) {
ierr = MatDuplicate(Jac,MAT_COPY_VALUES,&cvode->pmat);CHKERRQ(ierr);
ierr = PetscLogObjectParent(ts,cvode->pmat);CHKERRQ(ierr);
} else {
ierr = MatCopy(Jac,cvode->pmat,str);CHKERRQ(ierr);
}
*jcurPtr = TRUE;
}
/* construct I-gamma*Jac */
gm = -_gamma;
ierr = MatScale(Jac,gm);CHKERRQ(ierr);
ierr = MatShift(Jac,one);CHKERRQ(ierr);
ierr = PCSetOperators(pc,Jac,Jac,str);CHKERRQ(ierr);
PetscFunctionReturn(0);
}
void PETSC_STDCALL tscomputerhsjacobian_(TS ts,PetscReal *t,Vec X,Mat *A,Mat *B,MatStructure *flg, int *__ierr ){
*__ierr = TSComputeRHSJacobian(
(TS)PetscToPointer((ts) ),*t,
(Vec)PetscToPointer((X) ),A,B,flg);
}
