static int cpNlsFunctionalImpl(CPodeMem cp_mem)
{
int retval, m;
realtype del, delp, dcon;
#ifdef CPODES_DEBUG
printf(" Functional, implicit ODE\n");
#endif
/* Initialize counter */
crate = ONE;
m = 0;
/* Evaluate f at predicted y and y' */
N_VScale(ONE, zn[0], y);
N_VScale(ONE/h, zn[1], yp);
retval = fi(tn, y, yp, ftemp, f_data);
nfe++;
if (retval < 0) return(CP_ODEFUNC_FAIL);
if (retval > 0) return(ODEFUNC_RECVR);
/* Initialize accumulated correction to 0 */
N_VConst(ZERO, acor);
/* Initialize delp to avoid compiler warning message */
del = delp = ZERO;
/* Loop until convergence; accumulate corrections in acor */
loop {
nni++;
/* Correct y directly from the last f value ( y <- y - gamma*f ) */
N_VScale(-gamma, ftemp, tempv);
N_VLinearSum(ONE, y, ONE, tempv, y);
/* Get WRMS norm of current correction to use in convergence test */
del = N_VWrmsNorm(tempv, ewt);
/* Update accumulated correction */
N_VLinearSum(ONE, acor, ONE, tempv, acor);
/* Test for convergence. If m > 0, an estimate of the convergence
rate constant is stored in crate, and used in the test. */
if (m > 0) crate = MAX(NLS_CRDOWN * crate, del / delp);
dcon = del * MIN(ONE, crate) / tq[4];
if (dcon <= ONE) {
acnrm = (m == 0) ? del : N_VWrmsNorm(acor, ewt);
return(CP_SUCCESS); /* Convergence achieved */
}
/* Stop at maxcor iterations or if iter. seems to be diverging */
m++;
if ((m==maxcor) || ((m >= 2) && (del > NLS_RDIV * delp))) return(CONV_FAIL);
/* Save norm of correction */
delp = del;
/* Update y' and evaluate f again */
N_VLinearSum(ONE, y, -ONE, zn[0], yp);
N_VLinearSum(ONE/gamma, yp, ONE/h, zn[1], yp);
retval = fi(tn, y, yp, ftemp, f_data);
nfe++;
if (retval < 0) return(CP_ODEFUNC_FAIL);
if (retval > 0) return(ODEFUNC_RECVR);
}
}
/*
This routine generates the block-diagonal part of the Jacobian
corresponding to the interaction rates, multiplies by -gamma, adds
the identity matrix, and calls denseGETRF to do the LU decomposition of
each diagonal block. The computation of the diagonal blocks uses
the preset block and grouping information. One block per group is
computed. The Jacobian elements are generated by difference
quotients using calls to the routine fblock.
This routine can be regarded as a prototype for the general case
of a block-diagonal preconditioner. The blocks are of size mp, and
there are ngrp=ngx*ngy blocks computed in the block-grouping scheme.
*/
static int Precond(realtype t, N_Vector c, N_Vector fc,
booleantype jok, booleantype *jcurPtr, realtype gamma,
void *user_data, N_Vector vtemp1, N_Vector vtemp2,
N_Vector vtemp3)
{
realtype ***P;
long int **pivot, ier;
int i, if0, if00, ig, igx, igy, j, jj, jx, jy;
int *jxr, *jyr, ngrp, ngx, ngy, mxmp, flag;
long int mp;
realtype uround, fac, r, r0, save, srur;
realtype *f1, *fsave, *cdata, *rewtdata;
WebData wdata;
void *cvode_mem;
N_Vector rewt;
wdata = (WebData) user_data;
cvode_mem = wdata->cvode_mem;
cdata = N_VGetArrayPointer_Serial(c);
rewt = wdata->rewt;
flag = CVodeGetErrWeights(cvode_mem, rewt);
if(check_flag(&flag, "CVodeGetErrWeights", 1)) return(1);
rewtdata = N_VGetArrayPointer_Serial(rewt);
uround = UNIT_ROUNDOFF;
P = wdata->P;
pivot = wdata->pivot;
jxr = wdata->jxr;
jyr = wdata->jyr;
mp = wdata->mp;
srur = wdata->srur;
ngrp = wdata->ngrp;
ngx = wdata->ngx;
ngy = wdata->ngy;
mxmp = wdata->mxmp;
fsave = wdata->fsave;
/* Make mp calls to fblock to approximate each diagonal block of Jacobian.
Here, fsave contains the base value of the rate vector and
r0 is a minimum increment factor for the difference quotient. */
f1 = N_VGetArrayPointer_Serial(vtemp1);
fac = N_VWrmsNorm (fc, rewt);
r0 = RCONST(1000.0)*SUNRabs(gamma)*uround*NEQ*fac;
if (r0 == ZERO) r0 = ONE;
for (igy = 0; igy < ngy; igy++) {
jy = jyr[igy];
if00 = jy*mxmp;
for (igx = 0; igx < ngx; igx++) {
jx = jxr[igx];
if0 = if00 + jx*mp;
ig = igx + igy*ngx;
/* Generate ig-th diagonal block */
for (j = 0; j < mp; j++) {
/* Generate the jth column as a difference quotient */
jj = if0 + j;
save = cdata[jj];
r = SUNMAX(srur*SUNRabs(save),r0/rewtdata[jj]);
cdata[jj] += r;
fac = -gamma/r;
fblock (t, cdata, jx, jy, f1, wdata);
for (i = 0; i < mp; i++) {
P[ig][j][i] = (f1[i] - fsave[if0+i])*fac;
}
cdata[jj] = save;
}
}
}
/* Add identity matrix and do LU decompositions on blocks. */
for (ig = 0; ig < ngrp; ig++) {
denseAddIdentity(P[ig], mp);
ier = denseGETRF(P[ig], mp, mp, pivot[ig]);
if (ier != 0) return(1);
}
*jcurPtr = TRUE;
return(0);
}
static int CVBandPDQJac(CVBandPrecData pdata,
realtype t, N_Vector y, N_Vector fy,
N_Vector ftemp, N_Vector ytemp)
{
CVodeMem cv_mem;
realtype fnorm, minInc, inc, inc_inv, srur;
int group, i, j, width, ngroups, i1, i2;
realtype *col_j, *ewt_data, *fy_data, *ftemp_data, *y_data, *ytemp_data;
int retval;
cv_mem = (CVodeMem) pdata->cvode_mem;
/* Obtain pointers to the data for ewt, fy, ftemp, y, ytemp. */
ewt_data = N_VGetArrayPointer(ewt);
fy_data = N_VGetArrayPointer(fy);
ftemp_data = N_VGetArrayPointer(ftemp);
y_data = N_VGetArrayPointer(y);
ytemp_data = N_VGetArrayPointer(ytemp);
/* Load ytemp with y = predicted y vector. */
N_VScale(ONE, y, ytemp);
/* Set minimum increment based on uround and norm of f. */
srur = RSqrt(uround);
fnorm = N_VWrmsNorm(fy, ewt);
minInc = (fnorm != ZERO) ?
(MIN_INC_MULT * ABS(h) * uround * N * fnorm) : ONE;
/* Set bandwidth and number of column groups for band differencing. */
width = ml + mu + 1;
ngroups = MIN(width, N);
for (group = 1; group <= ngroups; group++) {
/* Increment all y_j in group. */
for(j = group-1; j < N; j += width) {
inc = MAX(srur*ABS(y_data[j]), minInc/ewt_data[j]);
ytemp_data[j] += inc;
}
/* Evaluate f with incremented y. */
retval = f(t, ytemp, ftemp, user_data);
nfeBP++;
if (retval != 0) return(retval);
/* Restore ytemp, then form and load difference quotients. */
for (j = group-1; j < N; j += width) {
ytemp_data[j] = y_data[j];
col_j = BAND_COL(savedJ,j);
inc = MAX(srur*ABS(y_data[j]), minInc/ewt_data[j]);
inc_inv = ONE/inc;
i1 = MAX(0, j-mu);
i2 = MIN(j+ml, N-1);
for (i=i1; i <= i2; i++)
BAND_COL_ELEM(col_j,i,j) =
inc_inv * (ftemp_data[i] - fy_data[i]);
}
}
return(0);
}
static int cpNewtonIterationExpl(CPodeMem cp_mem)
{
int m, retval;
realtype del, delp, dcon;
N_Vector b;
mnewt = m = 0;
/* Initialize delp to avoid compiler warning message */
del = delp = ZERO;
/* Looping point for Newton iteration */
loop {
#ifdef CPODES_DEBUG
printf(" Iteration # %d\n",m);
#endif
#ifdef CPODES_DEBUG_SERIAL
printf(" zn[0] = "); N_VPrint_Serial(zn[0]);
printf(" zn[1] = "); N_VPrint_Serial(zn[1]);
printf(" ewt = "); N_VPrint_Serial(ewt);
printf(" acor = "); N_VPrint_Serial(acor);
printf(" ftemp = "); N_VPrint_Serial(ftemp);
#endif
/* Evaluate the residual of the nonlinear system*/
N_VLinearSum(rl1, zn[1], ONE, acor, tempv);
N_VLinearSum(gamma, ftemp, -ONE, tempv, tempv);
/* Call the lsolve function */
b = tempv;
#ifdef CPODES_DEBUG
printf(" Linear solver solve\n");
#endif
#ifdef CPODES_DEBUG_SERIAL
printf(" rhs = "); N_VPrint_Serial(b);
#endif
retval = lsolve(cp_mem, b, ewt, y, NULL, ftemp);
#ifdef CPODES_DEBUG_SERIAL
printf(" sol = "); N_VPrint_Serial(b);
#endif
#ifdef CPODES_DEBUG
printf(" Linear solver solve return value = %d\n",retval);
#endif
nni++;
if (retval < 0) return(CP_LSOLVE_FAIL);
if (retval > 0) return(CONV_FAIL);
/* Get WRMS norm of correction; add correction to acor and y */
del = N_VWrmsNorm(b, ewt);
#ifdef CPODES_DEBUG
printf(" Norm of correction: del = %lg\n", del);
#endif
N_VLinearSum(ONE, acor, ONE, b, acor);
N_VLinearSum(ONE, zn[0], ONE, acor, y);
/* Test for convergence. If m > 0, an estimate of the convergence
rate constant is stored in crate, and used in the test. */
if (m > 0) {
crate = MAX(NLS_CRDOWN * crate, del/delp);
}
dcon = del * MIN(ONE, crate) / tq[4];
#ifdef CPODES_DEBUG
printf(" Convergence test dcon = %lg\n", dcon);
#endif
if (dcon <= ONE) {
acnrm = (m==0) ? del : N_VWrmsNorm(acor, ewt);
#ifdef CPODES_DEBUG_SERIAL
printf(" acor = "); N_VPrint_Serial(acor);
#endif
#ifdef CPODES_DEBUG
printf(" Accumulated correction norm = %lg\n", acnrm);
#endif
jcur = FALSE;
return(CP_SUCCESS); /* Nonlinear system was solved successfully */
}
mnewt = ++m;
/* Stop at maxcor iterations or if iter. seems to be diverging. */
if ((m == maxcor) || ((m >= 2) && (del > NLS_RDIV*delp))) return(CONV_FAIL);
/* Save norm of correction, evaluate f, and loop again */
delp = del;
retval = fe(tn, y, ftemp, f_data);
nfe++;
if (retval < 0) return(CP_ODEFUNC_FAIL);
if (retval > 0) return(ODEFUNC_RECVR);
} /* end loop */
}
/*---------------------------------------------------------------
Function : PcgSolve
--------------------------------------------------------------*/
int PcgSolve(PcgMem mem, void *A_data, N_Vector x, N_Vector b,
int pretype, realtype delta, void *P_data,
N_Vector w, ATimesFn atimes, PSolveFn psolve,
realtype *res_norm, int *nli, int *nps)
{
realtype alpha, beta, r0_norm, rho, rz, rz_old;
N_Vector r, p, z, Ap;
booleantype UsePrec, converged;
int l, l_max, ier;
if (mem == NULL) return(PCG_MEM_NULL);
/* Make local copies of mem variables */
l_max = mem->l_max;
r = mem->r;
p = mem->p;
z = mem->z;
Ap = mem->Ap;
/* Initialize counters and converged flag */
*nli = *nps = 0;
converged = FALSE;
/* Set preconditioning flag */
UsePrec = ((pretype == PREC_BOTH) || (pretype == PREC_LEFT) || (pretype == PREC_RIGHT));
/* Set r to initial residual r_0 = b - A*x_0 */
if (N_VDotProd(x, x) == ZERO) N_VScale(ONE, b, r);
else {
ier = atimes(A_data, x, r);
if (ier != 0)
return((ier < 0) ? PCG_ATIMES_FAIL_UNREC : PCG_ATIMES_FAIL_REC);
N_VLinearSum(ONE, b, -ONE, r, r);
}
/* Set rho to L2 norm of r, and return if small */
*res_norm = r0_norm = rho = N_VWrmsNorm(r,w);
if (rho <= delta) return(PCG_SUCCESS);
/* Apply preconditioner and b-scaling to r = r_0 */
if (UsePrec) {
ier = psolve(P_data, r, z, PREC_LEFT); /* z = P^{-1}r */
(*nps)++;
if (ier != 0) return((ier < 0) ? PCG_PSOLVE_FAIL_UNREC : PCG_PSOLVE_FAIL_REC);
}
else N_VScale(ONE, r, z);
/* Initialize rz to <r,z> */
rz = N_VDotProd(r, z);
/* Copy z to p */
N_VScale(ONE, z, p);
/* Begin main iteration loop */
for(l=0; l<l_max; l++) {
/* increment counter */
(*nli)++;
/* Generate Ap = A*p */
ier = atimes(A_data, p, Ap );
if (ier != 0)
return((ier < 0) ? PCG_ATIMES_FAIL_UNREC : PCG_ATIMES_FAIL_REC);
/* Calculate alpha = <r,z> / <Ap,p> */
alpha = rz / N_VDotProd(Ap, p);
/* Update x = x + alpha*p */
N_VLinearSum(ONE, x, alpha, p, x);
/* Update r = r - alpha*Ap */
N_VLinearSum(ONE, r, -alpha, Ap, r);
/* Set rho and check convergence */
*res_norm = rho = N_VWrmsNorm(r, w);
if (rho <= delta) {
converged = TRUE;
break;
}
/* Apply preconditioner: z = P^{-1}*r */
if (UsePrec) {
ier = psolve(P_data, r, z, PREC_LEFT);
(*nps)++;
if (ier != 0) return((ier < 0) ? PCG_PSOLVE_FAIL_UNREC : PCG_PSOLVE_FAIL_REC);
}
else N_VScale(ONE, r, z);
/* update rz */
rz_old = rz;
rz = N_VDotProd(r, z);
/* Calculate beta = <r,z> / <r_old,z_old> */
beta = rz / rz_old;
/* Update p = z + beta*p */
N_VLinearSum(ONE, z, beta, p, p);
}
/* Main loop finished, return with result */
if (converged == TRUE) return(PCG_SUCCESS);
if (rho < r0_norm) return(PCG_RES_REDUCED);
return(PCG_CONV_FAIL);
}
static int CVSptfqmrSolve(CVodeMem cv_mem, N_Vector b, N_Vector weight,
N_Vector ynow, N_Vector fnow)
{
realtype bnorm, res_norm;
CVSpilsMem cvspils_mem;
SptfqmrMem sptfqmr_mem;
int nli_inc, nps_inc, retval;
cvspils_mem = (CVSpilsMem) lmem;
sptfqmr_mem = (SptfqmrMem) spils_mem;
/* Test norm(b); if small, return x = 0 or x = b */
deltar = eplifac * tq[4];
bnorm = N_VWrmsNorm(b, weight);
if (bnorm <= deltar) {
if (mnewt > 0) N_VConst(ZERO, b);
return(0);
}
/* Set vectors ycur and fcur for use by the Atimes and Psolve routines */
ycur = ynow;
fcur = fnow;
/* Set inputs delta and initial guess x = 0 to SptfqmrSolve */
delta = deltar * sqrtN;
N_VConst(ZERO, x);
/* Call SptfqmrSolve and copy x to b */
retval = SptfqmrSolve(sptfqmr_mem, cv_mem, x, b, pretype, delta,
cv_mem, weight, weight, CVSpilsAtimes, CVSpilsPSolve,
&res_norm, &nli_inc, &nps_inc);
N_VScale(ONE, x, b);
/* Increment counters nli, nps, and ncfl */
nli += nli_inc;
nps += nps_inc;
if (retval != SPTFQMR_SUCCESS) ncfl++;
/* Interpret return value from SpgmrSolve */
last_flag = retval;
switch(retval) {
case SPTFQMR_SUCCESS:
return(0);
break;
case SPTFQMR_RES_REDUCED:
if (mnewt == 0) return(0);
else return(1);
break;
case SPTFQMR_CONV_FAIL:
return(1);
break;
case SPTFQMR_PSOLVE_FAIL_REC:
return(1);
break;
case SPTFQMR_ATIMES_FAIL_REC:
return(1);
break;
case SPTFQMR_MEM_NULL:
return(-1);
break;
case SPTFQMR_ATIMES_FAIL_UNREC:
CVProcessError(cv_mem, SPTFQMR_ATIMES_FAIL_UNREC, "CVSPTFQMR", "CVSptfqmrSolve", MSGS_JTIMES_FAILED);
return(-1);
break;
case SPTFQMR_PSOLVE_FAIL_UNREC:
CVProcessError(cv_mem, SPTFQMR_PSOLVE_FAIL_UNREC, "CVSPTFQMR", "CVSptfqmrSolve", MSGS_PSOLVE_FAILED);
return(-1);
break;
}
return(0);
}
/*-----------------------------------------------------------------
cvLsDenseDQJac
This routine generates a dense difference quotient approximation
to the Jacobian of f(t,y). It assumes that a dense SUNMatrix is
stored column-wise, and that elements within each column are
contiguous. The address of the jth column of J is obtained via
the accessor function SUNDenseMatrix_Column, and this pointer
is associated with an N_Vector using the N_VSetArrayPointer
function. Finally, the actual computation of the jth column of
the Jacobian is done with a call to N_VLinearSum.
-----------------------------------------------------------------*/
int cvLsDenseDQJac(realtype t, N_Vector y, N_Vector fy,
SUNMatrix Jac, CVodeMem cv_mem, N_Vector tmp1)
{
realtype fnorm, minInc, inc, inc_inv, yjsaved, srur, conj;
realtype *y_data, *ewt_data, *cns_data;
N_Vector ftemp, jthCol;
sunindextype j, N;
CVLsMem cvls_mem;
int retval = 0;
/* access LsMem interface structure */
cvls_mem = (CVLsMem) cv_mem->cv_lmem;
/* access matrix dimension */
N = SUNDenseMatrix_Rows(Jac);
/* Rename work vector for readibility */
ftemp = tmp1;
/* Create an empty vector for matrix column calculations */
jthCol = N_VCloneEmpty(tmp1);
/* Obtain pointers to the data for ewt, y */
ewt_data = N_VGetArrayPointer(cv_mem->cv_ewt);
y_data = N_VGetArrayPointer(y);
if (cv_mem->cv_constraints != NULL)
cns_data = N_VGetArrayPointer(cv_mem->cv_constraints);
/* Set minimum increment based on uround and norm of f */
srur = SUNRsqrt(cv_mem->cv_uround);
fnorm = N_VWrmsNorm(fy, cv_mem->cv_ewt);
minInc = (fnorm != ZERO) ?
(MIN_INC_MULT * SUNRabs(cv_mem->cv_h) * cv_mem->cv_uround * N * fnorm) : ONE;
for (j = 0; j < N; j++) {
/* Generate the jth col of J(tn,y) */
N_VSetArrayPointer(SUNDenseMatrix_Column(Jac,j), jthCol);
yjsaved = y_data[j];
inc = SUNMAX(srur*SUNRabs(yjsaved), minInc/ewt_data[j]);
/* Adjust sign(inc) if y_j has an inequality constraint. */
if (cv_mem->cv_constraints != NULL) {
conj = cns_data[j];
if (SUNRabs(conj) == ONE) {if ((yjsaved+inc)*conj < ZERO) inc = -inc;}
else if (SUNRabs(conj) == TWO) {if ((yjsaved+inc)*conj <= ZERO) inc = -inc;}
}
y_data[j] += inc;
retval = cv_mem->cv_f(t, y, ftemp, cv_mem->cv_user_data);
cvls_mem->nfeDQ++;
if (retval != 0) break;
y_data[j] = yjsaved;
inc_inv = ONE/inc;
N_VLinearSum(inc_inv, ftemp, -inc_inv, fy, jthCol);
}
/* Destroy jthCol vector */
N_VSetArrayPointer(NULL, jthCol); /* SHOULDN'T BE NEEDED */
N_VDestroy(jthCol);
return(retval);
}
static int cpProjNonlinearIteration(CPodeMem cp_mem)
{
int m, retval;
realtype del, delp, dcon;
N_Vector corP;
/* Initialize counter */
m = 0;
/* Initialize delp to avoid compiler warning message */
del = delp = ZERO;
/* Rename ftemp as corP */
corP = ftemp;
/* Set acorP to zero */
N_VConst(ZERO, acorP);
/* Set errP to acor */
if (project_err) N_VScale(ONE, acor, errP);
/* Looping point for iterations */
loop {
#ifdef CPODES_DEBUG
printf(" Iteration # %d\n",m);
#endif
/* Call lsolveP (rhs is ctemp; solution in corP) */
retval = lsolveP(cp_mem, ctemp, corP, y, ctemp, tempvP1, tempv);
#ifdef CPODES_DEBUG
printf(" Linear solver solve return value = %d\n",retval);
#endif
if (retval < 0) return(CP_PLSOLVE_FAIL);
if (retval > 0) return(CONV_FAIL);
/* Add correction to acorP and y and get its WRMS norm */
N_VLinearSum(ONE, acorP, -ONE, corP, acorP);
N_VLinearSum(ONE, y, -ONE, corP, y);
del = N_VWrmsNorm(corP, ewt);
#ifdef CPODES_DEBUG
printf(" Norm of correction: del = %lg\n", del);
#endif
/* If activated, find correction to the error estimate */
if (project_err) {
/* Compute rhs as G*errP and load it in tempvP2 */
lmultP(cp_mem, errP, tempvP2);
/* Call lsolveP (rhs is tempvP2; solution in corP) */
retval = lsolveP(cp_mem, tempvP2, corP, y, ctemp, tempvP1, tempv);
if (retval < 0) return(CP_PLSOLVE_FAIL);
if (retval > 0) return(CONV_FAIL);
/* Add correction to errP */
N_VLinearSum(ONE, errP, -ONE, corP, errP);
}
/* Test for convergence. If m > 0, an estimate of the convergence
rate constant is stored in crateP, and used in the test. */
if (m > 0) crateP = MAX(PRJ_CRDOWN * crateP, del/delp);
dcon = del * MIN(ONE, crateP) / prjcoef;
#ifdef CPODES_DEBUG
printf(" Convergence test dcon = %lg\n", dcon);
#endif
if (dcon <= ONE) {
if (project_err) acnrm = N_VWrmsNorm(errP, ewt);
return(CP_SUCCESS);
}
m++;
/* Stop at maxcorP iterations or if iter. seems to be diverging. */
if ((m == maxcorP) || ((m >= 2) && (del > PRJ_RDIV*delp))) return(CONV_FAIL);
/* Save norm of correction, evaluate cfun, and loop again */
delp = del;
retval = cfun(tn, y, ctemp, c_data);
nce++;
if (retval < 0) return(CP_CNSTRFUNC_FAIL);
if (retval > 0) return(CNSTRFUNC_RECVR);
}
}
int cvDlsBandDQJac(long int N, long int mupper, long int mlower,
realtype t, N_Vector y, N_Vector fy,
DlsMat Jac, void *data,
N_Vector tmp1, N_Vector tmp2, N_Vector tmp3)
{
N_Vector ftemp, ytemp;
realtype fnorm, minInc, inc, inc_inv, srur;
realtype *col_j, *ewt_data, *fy_data, *ftemp_data, *y_data, *ytemp_data;
long int group, i, j, width, ngroups, i1, i2;
int retval = 0;
CVodeMem cv_mem;
CVDlsMem cvdls_mem;
/* data points to cvode_mem */
cv_mem = (CVodeMem) data;
cvdls_mem = (CVDlsMem) lmem;
/* Rename work vectors for use as temporary values of y and f */
ftemp = tmp1;
ytemp = tmp2;
/* Obtain pointers to the data for ewt, fy, ftemp, y, ytemp */
ewt_data = N_VGetArrayPointer(ewt);
fy_data = N_VGetArrayPointer(fy);
ftemp_data = N_VGetArrayPointer(ftemp);
y_data = N_VGetArrayPointer(y);
ytemp_data = N_VGetArrayPointer(ytemp);
/* Load ytemp with y = predicted y vector */
N_VScale(ONE, y, ytemp);
/* Set minimum increment based on uround and norm of f */
srur = SUNRsqrt(uround);
fnorm = N_VWrmsNorm(fy, ewt);
minInc = (fnorm != ZERO) ?
(MIN_INC_MULT * SUNRabs(h) * uround * N * fnorm) : ONE;
/* Set bandwidth and number of column groups for band differencing */
width = mlower + mupper + 1;
ngroups = SUNMIN(width, N);
/* Loop over column groups. */
for (group=1; group <= ngroups; group++) {
/* Increment all y_j in group */
for(j=group-1; j < N; j+=width) {
inc = SUNMAX(srur*SUNRabs(y_data[j]), minInc/ewt_data[j]);
ytemp_data[j] += inc;
}
/* Evaluate f with incremented y */
retval = f(tn, ytemp, ftemp, user_data);
nfeDQ++;
if (retval != 0) break;
/* Restore ytemp, then form and load difference quotients */
for (j=group-1; j < N; j+=width) {
ytemp_data[j] = y_data[j];
col_j = BAND_COL(Jac,j);
inc = SUNMAX(srur*SUNRabs(y_data[j]), minInc/ewt_data[j]);
inc_inv = ONE/inc;
i1 = SUNMAX(0, j-mupper);
i2 = SUNMIN(j+mlower, N-1);
for (i=i1; i <= i2; i++)
BAND_COL_ELEM(col_j,i,j) = inc_inv * (ftemp_data[i] - fy_data[i]);
}
}
return(retval);
}
/*-----------------------------------------------------------------
cvLsSolve
This routine interfaces between CVode and the generic
SUNLinearSolver object LS, by setting the appropriate tolerance
and scaling vectors, calling the solver, and accumulating
statistics from the solve for use/reporting by CVode.
-----------------------------------------------------------------*/
int cvLsSolve(CVodeMem cv_mem, N_Vector b, N_Vector weight,
N_Vector ynow, N_Vector fnow)
{
CVLsMem cvls_mem;
realtype bnorm, deltar, delta, w_mean;
int curiter, nli_inc, retval, LSType;
/* access CVLsMem structure */
if (cv_mem->cv_lmem==NULL) {
cvProcessError(cv_mem, CVLS_LMEM_NULL, "CVLS",
"cvLsSolve", MSG_LS_LMEM_NULL);
return(CVLS_LMEM_NULL);
}
cvls_mem = (CVLsMem) cv_mem->cv_lmem;
/* Retrieve the LS type */
LSType = SUNLinSolGetType(cvls_mem->LS);
/* get current nonlinear solver iteration */
retval = SUNNonlinSolGetCurIter(cv_mem->NLS, &curiter);
/* If the linear solver is iterative:
test norm(b), if small, return x = 0 or x = b;
set linear solver tolerance (in left/right scaled 2-norm) */
if ( (LSType == SUNLINEARSOLVER_ITERATIVE) ||
(LSType == SUNLINEARSOLVER_MATRIX_ITERATIVE) ) {
deltar = cvls_mem->eplifac * cv_mem->cv_tq[4];
bnorm = N_VWrmsNorm(b, weight);
if (bnorm <= deltar) {
if (curiter > 0) N_VConst(ZERO, b);
cvls_mem->last_flag = CVLS_SUCCESS;
return(cvls_mem->last_flag);
}
delta = deltar * cvls_mem->sqrtN;
} else {
delta = ZERO;
}
/* Set vectors ycur and fcur for use by the Atimes and Psolve
interface routines */
cvls_mem->ycur = ynow;
cvls_mem->fcur = fnow;
/* Set initial guess x = 0 to LS */
N_VConst(ZERO, cvls_mem->x);
/* Set scaling vectors for LS to use (if applicable) */
if (cvls_mem->LS->ops->setscalingvectors) {
retval = SUNLinSolSetScalingVectors(cvls_mem->LS,
weight,
weight);
if (retval != SUNLS_SUCCESS) {
cvProcessError(cv_mem, CVLS_SUNLS_FAIL, "CVLS", "cvLsSolve",
"Error in calling SUNLinSolSetScalingVectors");
cvls_mem->last_flag = CVLS_SUNLS_FAIL;
return(cvls_mem->last_flag);
}
/* If solver is iterative and does not support scaling vectors, update the
tolerance in an attempt to account for weight vector. We make the
following assumptions:
1. w_i = w_mean, for i=0,...,n-1 (i.e. the weights are homogeneous)
2. the linear solver uses a basic 2-norm to measure convergence
Hence (using the notation from sunlinsol_spgmr.h, with S = diag(w)),
|| bbar - Abar xbar ||_2 < tol
<=> || S b - S A x ||_2 < tol
<=> || S (b - A x) ||_2 < tol
<=> \sum_{i=0}^{n-1} (w_i (b - A x)_i)^2 < tol^2
<=> w_mean^2 \sum_{i=0}^{n-1} (b - A x_i)^2 < tol^2
<=> \sum_{i=0}^{n-1} (b - A x_i)^2 < tol^2 / w_mean^2
<=> || b - A x ||_2 < tol / w_mean
So we compute w_mean = ||w||_RMS = ||w||_2 / sqrt(n), and scale
the desired tolerance accordingly. */
} else if ( (LSType == SUNLINEARSOLVER_ITERATIVE) ||
(LSType == SUNLINEARSOLVER_MATRIX_ITERATIVE) ) {
w_mean = SUNRsqrt( N_VDotProd(weight, weight) ) / cvls_mem->sqrtN;
delta /= w_mean;
}
/* If a user-provided jtsetup routine is supplied, call that here */
if (cvls_mem->jtsetup) {
cvls_mem->last_flag = cvls_mem->jtsetup(cv_mem->cv_tn, ynow, fnow,
cvls_mem->jt_data);
cvls_mem->njtsetup++;
if (cvls_mem->last_flag != 0) {
cvProcessError(cv_mem, retval, "CVLS",
"cvLsSolve", MSG_LS_JTSETUP_FAILED);
return(cvls_mem->last_flag);
}
}
/* Call solver, and copy x to b */
retval = SUNLinSolSolve(cvls_mem->LS, cvls_mem->A, cvls_mem->x, b, delta);
N_VScale(ONE, cvls_mem->x, b);
/* If using a direct or matrix-iterative solver, BDF method, and gamma has changed,
scale the correction to account for change in gamma */
if ( ((LSType == SUNLINEARSOLVER_DIRECT) ||
(LSType == SUNLINEARSOLVER_MATRIX_ITERATIVE)) &&
(cv_mem->cv_lmm == CV_BDF) &&
(cv_mem->cv_gamrat != ONE) )
N_VScale(TWO/(ONE + cv_mem->cv_gamrat), b, b);
/* Retrieve statistics from iterative linear solvers */
nli_inc = 0;
if ( ((LSType == SUNLINEARSOLVER_ITERATIVE) ||
(LSType == SUNLINEARSOLVER_MATRIX_ITERATIVE)) &&
(cvls_mem->LS->ops->numiters) )
nli_inc = SUNLinSolNumIters(cvls_mem->LS);
/* Increment counters nli and ncfl */
cvls_mem->nli += nli_inc;
if (retval != SUNLS_SUCCESS) cvls_mem->ncfl++;
/* Interpret solver return value */
cvls_mem->last_flag = retval;
switch(retval) {
case SUNLS_SUCCESS:
return(0);
break;
case SUNLS_RES_REDUCED:
/* allow reduction but not solution on first Newton iteration,
otherwise return with a recoverable failure */
if (curiter == 0) return(0);
else return(1);
break;
case SUNLS_CONV_FAIL:
case SUNLS_ATIMES_FAIL_REC:
case SUNLS_PSOLVE_FAIL_REC:
case SUNLS_PACKAGE_FAIL_REC:
case SUNLS_QRFACT_FAIL:
case SUNLS_LUFACT_FAIL:
return(1);
break;
case SUNLS_MEM_NULL:
case SUNLS_ILL_INPUT:
case SUNLS_MEM_FAIL:
case SUNLS_GS_FAIL:
case SUNLS_QRSOL_FAIL:
return(-1);
break;
case SUNLS_PACKAGE_FAIL_UNREC:
cvProcessError(cv_mem, SUNLS_PACKAGE_FAIL_UNREC, "CVLS",
"cvLsSolve",
"Failure in SUNLinSol external package");
return(-1);
break;
case SUNLS_ATIMES_FAIL_UNREC:
cvProcessError(cv_mem, SUNLS_ATIMES_FAIL_UNREC, "CVLS",
"cvLsSolve", MSG_LS_JTIMES_FAILED);
return(-1);
break;
case SUNLS_PSOLVE_FAIL_UNREC:
cvProcessError(cv_mem, SUNLS_PSOLVE_FAIL_UNREC, "CVLS",
"cvLsSolve", MSG_LS_PSOLVE_FAILED);
return(-1);
break;
}
return(0);
}
static int cvBBDDQJac(CVBBDPrecData pdata, realtype t,
N_Vector y, N_Vector gy,
N_Vector ytemp, N_Vector gtemp)
{
CVodeMem cv_mem;
realtype gnorm, minInc, inc, inc_inv;
int group, i, j, width, ngroups, i1, i2;
realtype *y_data, *ewt_data, *gy_data, *gtemp_data, *ytemp_data, *col_j;
int retval;
cv_mem = (CVodeMem) pdata->cvode_mem;
/* Load ytemp with y = predicted solution vector */
N_VScale(ONE, y, ytemp);
/* Call cfn and gloc to get base value of g(t,y) */
if (cfn != NULL) {
retval = cfn(Nlocal, t, y, user_data);
if (retval != 0) return(retval);
}
retval = gloc(Nlocal, t, ytemp, gy, user_data);
nge++;
if (retval != 0) return(retval);
/* Obtain pointers to the data for various vectors */
y_data = N_VGetArrayPointer(y);
gy_data = N_VGetArrayPointer(gy);
ewt_data = N_VGetArrayPointer(ewt);
ytemp_data = N_VGetArrayPointer(ytemp);
gtemp_data = N_VGetArrayPointer(gtemp);
/* Set minimum increment based on uround and norm of g */
gnorm = N_VWrmsNorm(gy, ewt);
minInc = (gnorm != ZERO) ?
(MIN_INC_MULT * ABS(h) * uround * Nlocal * gnorm) : ONE;
/* Set bandwidth and number of column groups for band differencing */
width = mldq + mudq + 1;
ngroups = MIN(width, Nlocal);
/* Loop over groups */
for (group=1; group <= ngroups; group++) {
/* Increment all y_j in group */
for(j=group-1; j < Nlocal; j+=width) {
inc = MAX(dqrely*ABS(y_data[j]), minInc/ewt_data[j]);
ytemp_data[j] += inc;
}
/* Evaluate g with incremented y */
retval = gloc(Nlocal, t, ytemp, gtemp, user_data);
nge++;
if (retval != 0) return(retval);
/* Restore ytemp, then form and load difference quotients */
for (j=group-1; j < Nlocal; j+=width) {
ytemp_data[j] = y_data[j];
col_j = BAND_COL(savedJ,j);
inc = MAX(dqrely*ABS(y_data[j]), minInc/ewt_data[j]);
inc_inv = ONE/inc;
i1 = MAX(0, j-mukeep);
i2 = MIN(j+mlkeep, Nlocal-1);
for (i=i1; i <= i2; i++)
BAND_COL_ELEM(col_j,i,j) =
inc_inv * (gtemp_data[i] - gy_data[i]);
}
}
return(0);
}
int Cvode::calcJacobian(double t, long int N, N_Vector fHelp, N_Vector errorWeight, N_Vector jthCol, double* y, N_Vector fy, DlsMat Jac)
{
try
{
int l,g;
double fnorm, minInc, *f_data, *fHelp_data, *errorWeight_data, h, srur, delta_inv;
f_data = NV_DATA_S(fy);
errorWeight_data = NV_DATA_S(errorWeight);
fHelp_data = NV_DATA_S(fHelp);
//Get relevant info
_idid = CVodeGetErrWeights(_cvodeMem, errorWeight);
if (_idid < 0)
{
_idid = -5;
throw ModelicaSimulationError(SOLVER,"Cvode::calcJacobian()");
}
_idid = CVodeGetCurrentStep(_cvodeMem, &h);
if (_idid < 0)
{
_idid = -5;
throw ModelicaSimulationError(SOLVER,"Cvode::calcJacobian()");
}
srur = sqrt(UROUND);
fnorm = N_VWrmsNorm(fy, errorWeight);
minInc = (fnorm != 0.0) ?
(1000.0 * abs(h) * UROUND * N * fnorm) : 1.0;
for(int j=0;j<N;j++)
{
_delta[j] = max(srur*abs(y[j]), minInc/errorWeight_data[j]);
}
for(int j=0;j<N;j++)
{
_deltaInv[j] = 1/_delta[j];
}
if (_jacobianANonzeros != 0)
{
for(int color=1; color <= _maxColors; color++)
{
for(int k=0; k < _dimSys; k++)
{
if((_colorOfColumn[k] ) == color)
{
_ysave[k] = y[k];
y[k]+= _delta[k];
}
}
calcFunction(t, y, fHelp_data);
for (int k = 0; k < _dimSys; k++)
{
if((_colorOfColumn[k]) == color)
{
y[k] = _ysave[k];
int startOfColumn = k * _dimSys;
for (int j = _jacobianALeadindex[k]; j < _jacobianALeadindex[k+1];j++)
{
l = _jacobianAIndex[j];
g = l + startOfColumn;
Jac->data[g] = (fHelp_data[l] - f_data[l]) * _deltaInv[k];
}
}
}
}
}
}
/*
//Calculation of J without colouring
for (j = 0; j < N; j++)
{
//N_VSetArrayPointer(DENSE_COL(Jac,j), jthCol);
_ysave[j] = y[j];
y[j] += _delta[j];
calcFunction(t, y, fHelp_data);
y[j] = _ysave[j];
delta_inv = 1.0/_delta[j];
N_VLinearSum(delta_inv, fHelp, -delta_inv, fy, jthCol);
for(int i=0; i<_dimSys; ++i)
{
Jac->data[i+j*_dimSys] = NV_Ith_S(jthCol,i);
}
//DENSE_COL(Jac,j) = N_VGetArrayPointer(jthCol);
}
*/
//workaround until exception can be catch from c- libraries
catch (std::exception & ex )
{
cerr << "CVode integration error: " << ex.what();
return 1;
}
return 0;
}
/*---------------------------------------------------------------
ARKSpbcgSolve:
This routine handles the call to the generic solver SpbcgSolve
for the solution of the linear system Ax = b with the SPBCG
method. The solution x is returned in the vector b.
If the WRMS norm of b is small, we return x = b (if this is the
first Newton iteration) or x = 0 (if a later Newton iteration).
Otherwise, we set the tolerance parameter and initial guess
(x = 0), call SpbcgSolve, and copy the solution x into b. The
x-scaling and b-scaling arrays are both equal to weight.
The counters nli, nps, and ncfl are incremented, and the return
value is set according to the success of SpbcgSolve. The
success flag is returned if SpbcgSolve converged, or if this is
the first Newton iteration and the residual norm was reduced
below its initial value.
---------------------------------------------------------------*/
static int ARKSpbcgSolve(ARKodeMem ark_mem, N_Vector b,
N_Vector weight, N_Vector ynow,
N_Vector fnow)
{
realtype bnorm, res_norm;
ARKSpilsMem arkspils_mem;
SpbcgMem spbcg_mem;
int nli_inc, nps_inc, retval;
arkspils_mem = (ARKSpilsMem) ark_mem->ark_lmem;
spbcg_mem = (SpbcgMem) arkspils_mem->s_spils_mem;
/* Test norm(b); if small, return x = 0 or x = b */
arkspils_mem->s_deltar = arkspils_mem->s_eplifac * ark_mem->ark_eLTE;
bnorm = N_VWrmsNorm(b, weight);
if (bnorm <= arkspils_mem->s_deltar) {
if (ark_mem->ark_mnewt > 0) N_VConst(ZERO, b);
return(0);
}
/* Set vectors ycur and fcur for use by the Atimes and Psolve routines */
arkspils_mem->s_ycur = ynow;
arkspils_mem->s_fcur = fnow;
/* Set inputs delta and initial guess x = 0 to SpbcgSolve */
arkspils_mem->s_delta = arkspils_mem->s_deltar * arkspils_mem->s_sqrtN;
N_VConst(ZERO, arkspils_mem->s_x);
/* N_VConst(ark_mem->ark_uround, arkspils_mem->s_x); */
/* Call SpbcgSolve and copy x to b */
retval = SpbcgSolve(spbcg_mem, ark_mem, arkspils_mem->s_x, b,
arkspils_mem->s_pretype, arkspils_mem->s_delta,
ark_mem, weight, weight, ARKSpilsAtimes,
ARKSpilsPSolve, &res_norm, &nli_inc, &nps_inc);
N_VScale(ONE, arkspils_mem->s_x, b);
/* Increment counters nli, nps, and ncfl */
arkspils_mem->s_nli += nli_inc;
arkspils_mem->s_nps += nps_inc;
if (retval != SPBCG_SUCCESS) arkspils_mem->s_ncfl++;
/* Log solver statistics to diagnostics file (if requested) */
if (ark_mem->ark_report)
fprintf(ark_mem->ark_diagfp, " kry %19.16g %19.16g %i %i\n",
bnorm, res_norm, nli_inc, nps_inc);
/* Interpret return value from SpbcgSolve */
arkspils_mem->s_last_flag = retval;
switch(retval) {
case SPBCG_SUCCESS:
return(0);
break;
case SPBCG_RES_REDUCED:
/* allow reduction but not solution on first Newton iteration,
otherwise return with a recoverable failure */
if (ark_mem->ark_mnewt == 0) return(0);
else return(1);
break;
case SPBCG_CONV_FAIL:
return(1);
break;
case SPBCG_PSOLVE_FAIL_REC:
return(1);
break;
case SPBCG_ATIMES_FAIL_REC:
return(1);
break;
case SPBCG_MEM_NULL:
return(-1);
break;
case SPBCG_ATIMES_FAIL_UNREC:
arkProcessError(ark_mem, SPBCG_ATIMES_FAIL_UNREC, "ARKSPBCG",
"ARKSpbcgSolve", MSGS_JTIMES_FAILED);
return(-1);
break;
case SPBCG_PSOLVE_FAIL_UNREC:
arkProcessError(ark_mem, SPBCG_PSOLVE_FAIL_UNREC, "ARKSPBCG",
"ARKSpbcgSolve", MSGS_PSOLVE_FAILED);
return(-1);
break;
}
return(0);
}
int cvDlsDenseDQJac(long int N, realtype t,
N_Vector y, N_Vector fy,
DlsMat Jac, void *data,
N_Vector tmp1, N_Vector tmp2, N_Vector tmp3)
{
realtype fnorm, minInc, inc, inc_inv, yjsaved, srur;
realtype *tmp2_data, *y_data, *ewt_data;
N_Vector ftemp, jthCol;
long int j;
int retval = 0;
CVodeMem cv_mem;
CVDlsMem cvdls_mem;
/* data points to cvode_mem */
cv_mem = (CVodeMem) data;
cvdls_mem = (CVDlsMem) lmem;
/* Save pointer to the array in tmp2 */
tmp2_data = N_VGetArrayPointer(tmp2);
/* Rename work vectors for readibility */
ftemp = tmp1;
jthCol = tmp2;
/* Obtain pointers to the data for ewt, y */
ewt_data = N_VGetArrayPointer(ewt);
y_data = N_VGetArrayPointer(y);
/* Set minimum increment based on uround and norm of f */
srur = RSqrt(uround);
fnorm = N_VWrmsNorm(fy, ewt);
minInc = (fnorm != ZERO) ?
(MIN_INC_MULT * ABS(h) * uround * N * fnorm) : ONE;
for (j = 0; j < N; j++)
{
/* Generate the jth col of J(tn,y) */
N_VSetArrayPointer(DENSE_COL(Jac, j), jthCol);
yjsaved = y_data[j];
inc = MAX(srur * ABS(yjsaved), minInc / ewt_data[j]);
y_data[j] += inc;
retval = f(t, y, ftemp, user_data);
nfeDQ++;
if (retval != 0)
{
break;
}
y_data[j] = yjsaved;
inc_inv = ONE / inc;
N_VLinearSum(inc_inv, ftemp, -inc_inv, fy, jthCol);
DENSE_COL(Jac, j) = N_VGetArrayPointer(jthCol);
}
/* Restore original array pointer in tmp2 */
N_VSetArrayPointer(tmp2_data, tmp2);
return(retval);
}
/*-----------------------------------------------------------------
cvLsBandDQJac
This routine generates a banded difference quotient approximation
to the Jacobian of f(t,y). It assumes that a band SUNMatrix is
stored column-wise, and that elements within each column are
contiguous. This makes it possible to get the address of a column
of J via the accessor function SUNBandMatrix_Column, and to write
a simple for loop to set each of the elements of a column in
succession.
-----------------------------------------------------------------*/
int cvLsBandDQJac(realtype t, N_Vector y, N_Vector fy, SUNMatrix Jac,
CVodeMem cv_mem, N_Vector tmp1, N_Vector tmp2)
{
N_Vector ftemp, ytemp;
realtype fnorm, minInc, inc, inc_inv, srur, conj;
realtype *col_j, *ewt_data, *fy_data, *ftemp_data;
realtype *y_data, *ytemp_data, *cns_data;
sunindextype group, i, j, width, ngroups, i1, i2;
sunindextype N, mupper, mlower;
CVLsMem cvls_mem;
int retval = 0;
/* access LsMem interface structure */
cvls_mem = (CVLsMem) cv_mem->cv_lmem;
/* access matrix dimensions */
N = SUNBandMatrix_Columns(Jac);
mupper = SUNBandMatrix_UpperBandwidth(Jac);
mlower = SUNBandMatrix_LowerBandwidth(Jac);
/* Rename work vectors for use as temporary values of y and f */
ftemp = tmp1;
ytemp = tmp2;
/* Obtain pointers to the data for ewt, fy, ftemp, y, ytemp */
ewt_data = N_VGetArrayPointer(cv_mem->cv_ewt);
fy_data = N_VGetArrayPointer(fy);
ftemp_data = N_VGetArrayPointer(ftemp);
y_data = N_VGetArrayPointer(y);
ytemp_data = N_VGetArrayPointer(ytemp);
if (cv_mem->cv_constraints != NULL)
cns_data = N_VGetArrayPointer(cv_mem->cv_constraints);
/* Load ytemp with y = predicted y vector */
N_VScale(ONE, y, ytemp);
/* Set minimum increment based on uround and norm of f */
srur = SUNRsqrt(cv_mem->cv_uround);
fnorm = N_VWrmsNorm(fy, cv_mem->cv_ewt);
minInc = (fnorm != ZERO) ?
(MIN_INC_MULT * SUNRabs(cv_mem->cv_h) * cv_mem->cv_uround * N * fnorm) : ONE;
/* Set bandwidth and number of column groups for band differencing */
width = mlower + mupper + 1;
ngroups = SUNMIN(width, N);
/* Loop over column groups. */
for (group=1; group <= ngroups; group++) {
/* Increment all y_j in group */
for(j=group-1; j < N; j+=width) {
inc = SUNMAX(srur*SUNRabs(y_data[j]), minInc/ewt_data[j]);
/* Adjust sign(inc) if yj has an inequality constraint. */
if (cv_mem->cv_constraints != NULL) {
conj = cns_data[j];
if (SUNRabs(conj) == ONE) {if ((ytemp_data[j]+inc)*conj < ZERO) inc = -inc;}
else if (SUNRabs(conj) == TWO) {if ((ytemp_data[j]+inc)*conj <= ZERO) inc = -inc;}
}
ytemp_data[j] += inc;
}
/* Evaluate f with incremented y */
retval = cv_mem->cv_f(cv_mem->cv_tn, ytemp, ftemp, cv_mem->cv_user_data);
cvls_mem->nfeDQ++;
if (retval != 0) break;
/* Restore ytemp, then form and load difference quotients */
for (j=group-1; j < N; j+=width) {
ytemp_data[j] = y_data[j];
col_j = SUNBandMatrix_Column(Jac, j);
inc = SUNMAX(srur*SUNRabs(y_data[j]), minInc/ewt_data[j]);
/* Adjust sign(inc) as before. */
if (cv_mem->cv_constraints != NULL) {
conj = cns_data[j];
if (SUNRabs(conj) == ONE) {if ((ytemp_data[j]+inc)*conj < ZERO) inc = -inc;}
else if (SUNRabs(conj) == TWO) {if ((ytemp_data[j]+inc)*conj <= ZERO) inc = -inc;}
}
inc_inv = ONE/inc;
i1 = SUNMAX(0, j-mupper);
i2 = SUNMIN(j+mlower, N-1);
for (i=i1; i <= i2; i++)
SM_COLUMN_ELEMENT_B(col_j,i,j) = inc_inv * (ftemp_data[i] - fy_data[i]);
}
}
return(retval);
}
static void CVBandDQJac(long int N, long int mupper, long int mlower,
BandMat J, realtype t,
N_Vector y, N_Vector fy, void *jac_data,
N_Vector tmp1, N_Vector tmp2, N_Vector tmp3)
{
realtype fnorm, minInc, inc, inc_inv, srur;
N_Vector ftemp, ytemp;
long int group, i, j, width, ngroups, i1, i2;
realtype *col_j, *ewt_data, *fy_data, *ftemp_data, *y_data, *ytemp_data;
CVodeMem cv_mem;
CVBandMem cvband_mem;
/* jac_dat points to cvode_mem */
cv_mem = (CVodeMem) jac_data;
cvband_mem = (CVBandMem) lmem;
/* Rename work vectors for use as temporary values of y and f */
ftemp = tmp1;
ytemp = tmp2;
/* Obtain pointers to the data for ewt, fy, ftemp, y, ytemp */
ewt_data = N_VGetArrayPointer(ewt);
fy_data = N_VGetArrayPointer(fy);
ftemp_data = N_VGetArrayPointer(ftemp);
y_data = N_VGetArrayPointer(y);
ytemp_data = N_VGetArrayPointer(ytemp);
/* Load ytemp with y = predicted y vector */
N_VScale(ONE, y, ytemp);
/* Set minimum increment based on uround and norm of f */
srur = RSqrt(uround);
fnorm = N_VWrmsNorm(fy, ewt);
minInc = (fnorm != ZERO) ?
(MIN_INC_MULT * ABS(h) * uround * N * fnorm) : ONE;
/* Set bandwidth and number of column groups for band differencing */
width = mlower + mupper + 1;
ngroups = MIN(width, N);
for (group=1; group <= ngroups; group++) {
/* Increment all y_j in group */
for(j=group-1; j < N; j+=width) {
inc = MAX(srur*ABS(y_data[j]), minInc/ewt_data[j]);
ytemp_data[j] += inc;
}
/* Evaluate f with incremented y */
f(tn, ytemp, ftemp, f_data);
/* Restore ytemp, then form and load difference quotients */
for (j=group-1; j < N; j+=width) {
ytemp_data[j] = y_data[j];
col_j = BAND_COL(J,j);
inc = MAX(srur*ABS(y_data[j]), minInc/ewt_data[j]);
inc_inv = ONE/inc;
i1 = MAX(0, j-mupper);
i2 = MIN(j+mlower, N-1);
for (i=i1; i <= i2; i++)
BAND_COL_ELEM(col_j,i,j) =
inc_inv * (ftemp_data[i] - fy_data[i]);
}
}
/* Increment counter nfeB */
nfeB += ngroups;
}
int cpDoProjection(CPodeMem cp_mem, realtype saved_t, int *npfPtr)
{
int flag, retval;
realtype cnorm;
switch (proj_type) {
case CP_PROJ_INTERNAL:
/* Evaluate constraints at current time and with the corrected y */
retval = cfun(tn, y, ctemp, c_data);
nce++;
if (retval < 0) {flag = CP_CNSTRFUNC_FAIL; break;}
if (retval > 0) {flag = CNSTRFUNC_RECVR; break;}
/*
* If activated, evaluate WL2 norm of constraint violation.
* If the constraint violation is small enough, return.
*/
if (test_cnstr) {
cnorm = N_VWL2Norm(ctemp, ctol);
cnorm /= prjcoef;
#ifdef CPODES_DEBUG
printf(" Constraint violation norm = %lg\n",cnorm);
#endif
if (cnorm <= ONE) {
applyProj = FALSE;
return(CP_SUCCESS);
}
}
#ifdef CPODES_DEBUG
else {
printf(" No constraint testing\n");
}
#endif
/* Perform projection step
* On a successful return, the projection correction is available in acorP.
* Also, if projection of the error estimate was enabled, the new error
* estimate is available in errP and acnrm contains ||errP||_WRMS.
*/
nproj++;
if (cnstr_type == CP_CNSTR_NONLIN) flag = cpProjNonlinear(cp_mem);
else flag = cpProjLinear(cp_mem);
break;
case CP_PROJ_USER:
#ifdef CPODES_DEBUG
printf(" User-defined projection\n");
#endif
/* Use ftemp to store errP and tempv to store acorP
* (recall that in this case we did not allocate memory
* errP and acorP).
*/
errP = ftemp;
acorP = tempv;
/* Copy acor into errP */
N_VScale(ONE, acor, errP);
/* Call the user projection function */
retval = pfun(tn, y, acorP, prjcoef, errP, p_data);
nproj++;
if (retval < 0) {flag = CP_PROJFUNC_FAIL; break;}
if (retval > 0) {flag = PROJFUNC_RECVR; break;}
/* Recompute acnrm to be used in error test */
acnrm = N_VWrmsNorm(errP, ewt);
flag = CP_SUCCESS;
break;
}
#ifdef CPODES_DEBUG
printf(" acnrm = %lg\n",acnrm);
#endif
/* This is not the first projection anymore */
first_proj = FALSE;
/* If the projection was successful, return now. */
if (flag == CP_SUCCESS) {
applyProj = TRUE;
return(CP_SUCCESS);
}
/* The projection failed. Increment nprf and restore zn */
nprf++;
cpRestore(cp_mem, saved_t);
/* Return if lsetupP, lsolveP, cfun, or pfun failed unrecoverably */
if (flag == CP_PLSETUP_FAIL) return(CP_PLSETUP_FAIL);
if (flag == CP_PLSOLVE_FAIL) return(CP_PLSOLVE_FAIL);
if (flag == CP_CNSTRFUNC_FAIL) return(CP_CNSTRFUNC_FAIL);
if (flag == CP_PROJFUNC_FAIL) return(CP_PROJFUNC_FAIL);
/* At this point, flag = CONV_FAIL or CNSTRFUNC_RECVR or PRJFUNC_RECVR; increment npf */
(*npfPtr)++;
etamax = ONE;
/* If we had maxnpf failures or |h| = hmin,
return CP_PROJ_FAILURE or CP_REPTD_CNSTRFUNC_ERR or CP_REPTD_PROJFUNC_ERR. */
if ((ABS(h) <= hmin*ONEPSM) || (*npfPtr == maxnpf)) {
if (flag == CONV_FAIL) return(CP_PROJ_FAILURE);
if (flag == CNSTRFUNC_RECVR) return(CP_REPTD_CNSTRFUNC_ERR);
if (flag == PROJFUNC_RECVR) return(CP_REPTD_PROJFUNC_ERR);
}
/* Reduce step size; return to reattempt the step */
eta = MAX(ETAPR, hmin / ABS(h));
cpRescale(cp_mem);
return(PREDICT_AGAIN);
}
