int idaDlsBandDQJac(long int N, long int mupper, long int mlower,
realtype tt, realtype c_j,
N_Vector yy, N_Vector yp, N_Vector rr,
DlsMat Jac, void *data,
N_Vector tmp1, N_Vector tmp2, N_Vector tmp3)
{
realtype inc, inc_inv, yj, ypj, srur, conj, ewtj;
realtype *y_data, *yp_data, *ewt_data, *cns_data = NULL;
realtype *ytemp_data, *yptemp_data, *rtemp_data, *r_data, *col_j;
N_Vector rtemp, ytemp, yptemp;
long int group, i, j, i1, i2, width, ngroups;
int retval = 0;
IDAMem IDA_mem;
IDADlsMem idadls_mem;
/* data points to IDA_mem */
IDA_mem = (IDAMem) data;
idadls_mem = (IDADlsMem) lmem;
rtemp = tmp1; /* Rename work vector for use as the perturbed residual. */
ytemp = tmp2; /* Rename work vector for use as a temporary for yy. */
yptemp= tmp3; /* Rename work vector for use as a temporary for yp. */
/* Obtain pointers to the data for all eight vectors used. */
ewt_data = N_VGetArrayPointer(ewt);
r_data = N_VGetArrayPointer(rr);
y_data = N_VGetArrayPointer(yy);
yp_data = N_VGetArrayPointer(yp);
rtemp_data = N_VGetArrayPointer(rtemp);
ytemp_data = N_VGetArrayPointer(ytemp);
yptemp_data = N_VGetArrayPointer(yptemp);
if (constraints != NULL) cns_data = N_VGetArrayPointer(constraints);
/* Initialize ytemp and yptemp. */
N_VScale(ONE, yy, ytemp);
N_VScale(ONE, yp, yptemp);
/* Compute miscellaneous values for the Jacobian computation. */
srur = RSqrt(uround);
width = mlower + mupper + 1;
ngroups = MIN(width, N);
/* Loop over column groups. */
for (group=1; group <= ngroups; group++) {
/* Increment all yy[j] and yp[j] for j in this group. */
for (j=group-1; j<N; j+=width) {
yj = y_data[j];
ypj = yp_data[j];
ewtj = ewt_data[j];
/* Set increment inc to yj based on sqrt(uround)*abs(yj), with
adjustments using ypj and ewtj if this is small, and a further
adjustment to give it the same sign as hh*ypj. */
inc = MAX( srur * MAX( ABS(yj), ABS(hh*ypj) ) , ONE/ewtj );
if (hh*ypj < ZERO) inc = -inc;
inc = (yj + inc) - yj;
/* Adjust sign(inc) again if yj has an inequality constraint. */
if (constraints != NULL) {
conj = cns_data[j];
if (ABS(conj) == ONE) {if((yj+inc)*conj < ZERO) inc = -inc;}
else if (ABS(conj) == TWO) {if((yj+inc)*conj <= ZERO) inc = -inc;}
}
/* Increment yj and ypj. */
ytemp_data[j] += inc;
yptemp_data[j] += cj*inc;
}
/* Call res routine with incremented arguments. */
retval = res(tt, ytemp, yptemp, rtemp, user_data);
nreDQ++;
if (retval != 0) break;
/* Loop over the indices j in this group again. */
for (j=group-1; j<N; j+=width) {
/* Reset ytemp and yptemp components that were perturbed. */
yj = ytemp_data[j] = y_data[j];
ypj = yptemp_data[j] = yp_data[j];
col_j = BAND_COL(Jac, j);
ewtj = ewt_data[j];
/* Set increment inc exactly as above. */
inc = MAX( srur * MAX( ABS(yj), ABS(hh*ypj) ) , ONE/ewtj );
if (hh*ypj < ZERO) inc = -inc;
inc = (yj + inc) - yj;
if (constraints != NULL) {
conj = cns_data[j];
if (ABS(conj) == ONE) {if((yj+inc)*conj < ZERO) inc = -inc;}
else if (ABS(conj) == TWO) {if((yj+inc)*conj <= ZERO) inc = -inc;}
}
/* Load the difference quotient Jacobian elements for column 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*(rtemp_data[i]-r_data[i]);
}
}
return(retval);
}
int IDACalcIC(void *ida_mem, int icopt, realtype tout1)
{
int ewtsetOK;
int ier, nwt, nh, mxnh, icret, retval=0;
realtype tdist, troundoff, minid, hic, ypnorm;
IDAMem IDA_mem;
/* Check if IDA memory exists */
if(ida_mem == NULL) {
IDAProcessError(NULL, IDA_MEM_NULL, "IDA", "IDACalcIC", MSG_NO_MEM);
return(IDA_MEM_NULL);
}
IDA_mem = (IDAMem) ida_mem;
/* Check if problem was malloc'ed */
if(IDA_mem->ida_MallocDone == SUNFALSE) {
IDAProcessError(IDA_mem, IDA_NO_MALLOC, "IDA", "IDACalcIC", MSG_NO_MALLOC);
return(IDA_NO_MALLOC);
}
/* Check inputs to IDA for correctness and consistency */
ier = IDAInitialSetup(IDA_mem);
if(ier != IDA_SUCCESS) return(IDA_ILL_INPUT);
IDA_mem->ida_SetupDone = SUNTRUE;
/* Check legality of input arguments, and set IDA memory copies. */
if(icopt != IDA_YA_YDP_INIT && icopt != IDA_Y_INIT) {
IDAProcessError(IDA_mem, IDA_ILL_INPUT, "IDA", "IDACalcIC", MSG_IC_BAD_ICOPT);
return(IDA_ILL_INPUT);
}
IDA_mem->ida_icopt = icopt;
if(icopt == IDA_YA_YDP_INIT && (IDA_mem->ida_id == NULL)) {
IDAProcessError(IDA_mem, IDA_ILL_INPUT, "IDA", "IDACalcIC", MSG_IC_MISSING_ID);
return(IDA_ILL_INPUT);
}
tdist = SUNRabs(tout1 - IDA_mem->ida_tn);
troundoff = TWO * IDA_mem->ida_uround * (SUNRabs(IDA_mem->ida_tn) + SUNRabs(tout1));
if(tdist < troundoff) {
IDAProcessError(IDA_mem, IDA_ILL_INPUT, "IDA", "IDACalcIC", MSG_IC_TOO_CLOSE);
return(IDA_ILL_INPUT);
}
/* Allocate space and initialize temporary vectors */
IDA_mem->ida_yy0 = N_VClone(IDA_mem->ida_ee);
IDA_mem->ida_yp0 = N_VClone(IDA_mem->ida_ee);
IDA_mem->ida_t0 = IDA_mem->ida_tn;
N_VScale(ONE, IDA_mem->ida_phi[0], IDA_mem->ida_yy0);
N_VScale(ONE, IDA_mem->ida_phi[1], IDA_mem->ida_yp0);
/* For use in the IDA_YA_YP_INIT case, set sysindex and tscale. */
IDA_mem->ida_sysindex = 1;
IDA_mem->ida_tscale = tdist;
if(icopt == IDA_YA_YDP_INIT) {
minid = N_VMin(IDA_mem->ida_id);
if(minid < ZERO) {
IDAProcessError(IDA_mem, IDA_ILL_INPUT, "IDA", "IDACalcIC", MSG_IC_BAD_ID);
return(IDA_ILL_INPUT);
}
if(minid > HALF) IDA_mem->ida_sysindex = 0;
}
/* Set the test constant in the Newton convergence test */
IDA_mem->ida_epsNewt = IDA_mem->ida_epiccon;
/* Initializations:
cjratio = 1 (for use in direct linear solvers);
set nbacktr = 0; */
IDA_mem->ida_cjratio = ONE;
IDA_mem->ida_nbacktr = 0;
/* Set hic, hh, cj, and mxnh. */
hic = PT001*tdist;
ypnorm = IDAWrmsNorm(IDA_mem, IDA_mem->ida_yp0,
IDA_mem->ida_ewt, IDA_mem->ida_suppressalg);
if(ypnorm > HALF/hic) hic = HALF/ypnorm;
if(tout1 < IDA_mem->ida_tn) hic = -hic;
IDA_mem->ida_hh = hic;
if(icopt == IDA_YA_YDP_INIT) {
IDA_mem->ida_cj = ONE/hic;
mxnh = IDA_mem->ida_maxnh;
}
else {
IDA_mem->ida_cj = ZERO;
mxnh = 1;
}
/* Loop over nwt = number of evaluations of ewt vector. */
for(nwt = 1; nwt <= 2; nwt++) {
/* Loop over nh = number of h values. */
for(nh = 1; nh <= mxnh; nh++) {
/* Call the IC nonlinear solver function. */
retval = IDAnlsIC(IDA_mem);
/* Cut h and loop on recoverable IDA_YA_YDP_INIT failure; else break. */
if(retval == IDA_SUCCESS) break;
IDA_mem->ida_ncfn++;
if(retval < 0) break;
if(nh == mxnh) break;
/* If looping to try again, reset yy0 and yp0 if not converging. */
if(retval != IC_SLOW_CONVRG) {
N_VScale(ONE, IDA_mem->ida_phi[0], IDA_mem->ida_yy0);
N_VScale(ONE, IDA_mem->ida_phi[1], IDA_mem->ida_yp0);
}
hic *= PT1;
IDA_mem->ida_cj = ONE/hic;
IDA_mem->ida_hh = hic;
} /* End of nh loop */
/* Break on failure; else reset ewt, save yy0, yp0 in phi, and loop. */
if(retval != IDA_SUCCESS) break;
ewtsetOK = IDA_mem->ida_efun(IDA_mem->ida_yy0, IDA_mem->ida_ewt,
IDA_mem->ida_edata);
if(ewtsetOK != 0) {
retval = IDA_BAD_EWT;
break;
}
N_VScale(ONE, IDA_mem->ida_yy0, IDA_mem->ida_phi[0]);
N_VScale(ONE, IDA_mem->ida_yp0, IDA_mem->ida_phi[1]);
} /* End of nwt loop */
/* Free temporary space */
N_VDestroy(IDA_mem->ida_yy0);
N_VDestroy(IDA_mem->ida_yp0);
/* Load the optional outputs. */
if(icopt == IDA_YA_YDP_INIT) IDA_mem->ida_hused = hic;
/* On any failure, print message and return proper flag. */
if(retval != IDA_SUCCESS) {
icret = IDAICFailFlag(IDA_mem, retval);
return(icret);
}
/* Otherwise return success flag. */
return(IDA_SUCCESS);
}
static int 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;
int retval;
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 */
retval = f(tn, ytemp, ftemp, f_data);
nfeB++;
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(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]);
}
}
return(0);
}
int SpgmrSolve(SpgmrMem mem, void *A_data, N_Vector x, N_Vector b,
int pretype, int gstype, realtype delta, int max_restarts,
void *P_data, N_Vector s1, N_Vector s2, ATimesFn atimes,
PSolveFn psolve, realtype *res_norm, int *nli, int *nps)
{
N_Vector *V, xcor, vtemp;
realtype **Hes, *givens, *yg;
realtype beta, rotation_product, r_norm, s_product, rho;
booleantype preOnLeft, preOnRight, scale2, scale1, converged;
int i, j, k, l, l_plus_1, l_max, krydim, ier, ntries;
if (mem == NULL) return(SPGMR_MEM_NULL);
/* Initialize some variables */
l_plus_1 = 0;
krydim = 0;
/* Make local copies of mem variables. */
l_max = mem->l_max;
V = mem->V;
Hes = mem->Hes;
givens = mem->givens;
xcor = mem->xcor;
yg = mem->yg;
vtemp = mem->vtemp;
*nli = *nps = 0; /* Initialize counters */
converged = FALSE; /* Initialize converged flag */
if (max_restarts < 0) max_restarts = 0;
if ((pretype != PREC_LEFT) && (pretype != PREC_RIGHT) && (pretype != PREC_BOTH))
pretype = PREC_NONE;
preOnLeft = ((pretype == PREC_LEFT) || (pretype == PREC_BOTH));
preOnRight = ((pretype == PREC_RIGHT) || (pretype == PREC_BOTH));
scale1 = (s1 != NULL);
scale2 = (s2 != NULL);
/* Set vtemp and V[0] to initial (unscaled) residual r_0 = b - A*x_0. */
if (N_VDotProd(x, x) == ZERO) {
N_VScale(ONE, b, vtemp);
} else {
ier = atimes(A_data, x, vtemp);
if (ier != 0)
return((ier < 0) ? SPGMR_ATIMES_FAIL_UNREC : SPGMR_ATIMES_FAIL_REC);
N_VLinearSum(ONE, b, -ONE, vtemp, vtemp);
}
N_VScale(ONE, vtemp, V[0]);
/* Apply left preconditioner and left scaling to V[0] = r_0. */
if (preOnLeft) {
ier = psolve(P_data, V[0], vtemp, PREC_LEFT);
(*nps)++;
if (ier != 0)
return((ier < 0) ? SPGMR_PSOLVE_FAIL_UNREC : SPGMR_PSOLVE_FAIL_REC);
} else {
N_VScale(ONE, V[0], vtemp);
}
if (scale1) {
N_VProd(s1, vtemp, V[0]);
} else {
N_VScale(ONE, vtemp, V[0]);
}
/* Set r_norm = beta to L2 norm of V[0] = s1 P1_inv r_0, and
return if small. */
*res_norm = r_norm = beta = RSqrt(N_VDotProd(V[0], V[0]));
if (r_norm <= delta)
return(SPGMR_SUCCESS);
/* Initialize rho to avoid compiler warning message */
rho = beta;
/* Set xcor = 0. */
N_VConst(ZERO, xcor);
/* Begin outer iterations: up to (max_restarts + 1) attempts. */
for (ntries = 0; ntries <= max_restarts; ntries++) {
/* Initialize the Hessenberg matrix Hes and Givens rotation
product. Normalize the initial vector V[0]. */
for (i = 0; i <= l_max; i++)
for (j = 0; j < l_max; j++)
Hes[i][j] = ZERO;
rotation_product = ONE;
N_VScale(ONE/r_norm, V[0], V[0]);
/* Inner loop: generate Krylov sequence and Arnoldi basis. */
for (l = 0; l < l_max; l++) {
(*nli)++;
krydim = l_plus_1 = l + 1;
/* Generate A-tilde V[l], where A-tilde = s1 P1_inv A P2_inv s2_inv. */
/* Apply right scaling: vtemp = s2_inv V[l]. */
if (scale2) N_VDiv(V[l], s2, vtemp);
else N_VScale(ONE, V[l], vtemp);
/* Apply right preconditioner: vtemp = P2_inv s2_inv V[l]. */
if (preOnRight) {
N_VScale(ONE, vtemp, V[l_plus_1]);
ier = psolve(P_data, V[l_plus_1], vtemp, PREC_RIGHT);
(*nps)++;
if (ier != 0)
return((ier < 0) ? SPGMR_PSOLVE_FAIL_UNREC : SPGMR_PSOLVE_FAIL_REC);
}
/* Apply A: V[l+1] = A P2_inv s2_inv V[l]. */
ier = atimes(A_data, vtemp, V[l_plus_1] );
if (ier != 0)
return((ier < 0) ? SPGMR_ATIMES_FAIL_UNREC : SPGMR_ATIMES_FAIL_REC);
/* Apply left preconditioning: vtemp = P1_inv A P2_inv s2_inv V[l]. */
if (preOnLeft) {
ier = psolve(P_data, V[l_plus_1], vtemp, PREC_LEFT);
(*nps)++;
if (ier != 0)
return((ier < 0) ? SPGMR_PSOLVE_FAIL_UNREC : SPGMR_PSOLVE_FAIL_REC);
} else {
N_VScale(ONE, V[l_plus_1], vtemp);
}
/* Apply left scaling: V[l+1] = s1 P1_inv A P2_inv s2_inv V[l]. */
if (scale1) {
N_VProd(s1, vtemp, V[l_plus_1]);
} else {
N_VScale(ONE, vtemp, V[l_plus_1]);
}
/* Orthogonalize V[l+1] against previous V[i]: V[l+1] = w_tilde. */
if (gstype == CLASSICAL_GS) {
if (ClassicalGS(V, Hes, l_plus_1, l_max, &(Hes[l_plus_1][l]),
vtemp, yg) != 0)
return(SPGMR_GS_FAIL);
} else {
if (ModifiedGS(V, Hes, l_plus_1, l_max, &(Hes[l_plus_1][l])) != 0)
return(SPGMR_GS_FAIL);
}
/* Update the QR factorization of Hes. */
if(QRfact(krydim, Hes, givens, l) != 0 )
return(SPGMR_QRFACT_FAIL);
/* Update residual norm estimate; break if convergence test passes. */
rotation_product *= givens[2*l+1];
*res_norm = rho = ABS(rotation_product*r_norm);
if (rho <= delta) { converged = TRUE; break; }
/* Normalize V[l+1] with norm value from the Gram-Schmidt routine. */
N_VScale(ONE/Hes[l_plus_1][l], V[l_plus_1], V[l_plus_1]);
}
/* Inner loop is done. Compute the new correction vector xcor. */
/* Construct g, then solve for y. */
yg[0] = r_norm;
for (i = 1; i <= krydim; i++) yg[i]=ZERO;
if (QRsol(krydim, Hes, givens, yg) != 0)
return(SPGMR_QRSOL_FAIL);
/* Add correction vector V_l y to xcor. */
for (k = 0; k < krydim; k++)
N_VLinearSum(yg[k], V[k], ONE, xcor, xcor);
/* If converged, construct the final solution vector x and return. */
if (converged) {
/* Apply right scaling and right precond.: vtemp = P2_inv s2_inv xcor. */
if (scale2) N_VDiv(xcor, s2, xcor);
if (preOnRight) {
ier = psolve(P_data, xcor, vtemp, PREC_RIGHT);
(*nps)++;
if (ier != 0)
return((ier < 0) ? SPGMR_PSOLVE_FAIL_UNREC : SPGMR_PSOLVE_FAIL_REC);
} else {
N_VScale(ONE, xcor, vtemp);
}
/* Add vtemp to initial x to get final solution x, and return */
N_VLinearSum(ONE, x, ONE, vtemp, x);
return(SPGMR_SUCCESS);
}
/* Not yet converged; if allowed, prepare for restart. */
if (ntries == max_restarts) break;
/* Construct last column of Q in yg. */
s_product = ONE;
for (i = krydim; i > 0; i--) {
yg[i] = s_product*givens[2*i-2];
s_product *= givens[2*i-1];
}
yg[0] = s_product;
/* Scale r_norm and yg. */
r_norm *= s_product;
for (i = 0; i <= krydim; i++)
yg[i] *= r_norm;
r_norm = ABS(r_norm);
/* Multiply yg by V_(krydim+1) to get last residual vector; restart. */
N_VScale(yg[0], V[0], V[0]);
for (k = 1; k <= krydim; k++)
N_VLinearSum(yg[k], V[k], ONE, V[0], V[0]);
}
/* Failed to converge, even after allowed restarts.
If the residual norm was reduced below its initial value, compute
and return x anyway. Otherwise return failure flag. */
if (rho < beta) {
/* Apply right scaling and right precond.: vtemp = P2_inv s2_inv xcor. */
if (scale2) N_VDiv(xcor, s2, xcor);
if (preOnRight) {
ier = psolve(P_data, xcor, vtemp, PREC_RIGHT);
(*nps)++;
if (ier != 0)
return((ier < 0) ? SPGMR_PSOLVE_FAIL_UNREC : SPGMR_PSOLVE_FAIL_REC);
} else {
N_VScale(ONE, xcor, vtemp);
}
/* Add vtemp to initial x to get final solution x, and return. */
N_VLinearSum(ONE, x, ONE, vtemp, x);
return(SPGMR_RES_REDUCED);
}
return(SPGMR_CONV_FAIL);
}
int SpbcgSolve(SpbcgMem mem, void *A_data, N_Vector x, N_Vector b,
int pretype, realtype delta, void *P_data, N_Vector sx,
N_Vector sb, ATimesFn atimes, PSolveFn psolve,
realtype *res_norm, int *nli, int *nps)
{
realtype alpha, beta, omega, omega_denom, beta_num, beta_denom, r_norm, rho;
N_Vector r_star, r, p, q, u, Ap, vtemp;
booleantype preOnLeft, preOnRight, scale_x, scale_b, converged;
int l, l_max, ier;
if (mem == NULL) return(SPBCG_MEM_NULL);
/* Make local copies of mem variables */
l_max = mem->l_max;
r_star = mem->r_star;
r = mem->r;
p = mem->p;
q = mem->q;
u = mem->u;
Ap = mem->Ap;
vtemp = mem->vtemp;
*nli = *nps = 0; /* Initialize counters */
converged = FALSE; /* Initialize converged flag */
if ((pretype != PREC_LEFT) && (pretype != PREC_RIGHT) && (pretype != PREC_BOTH)) pretype = PREC_NONE;
preOnLeft = ((pretype == PREC_BOTH) || (pretype == PREC_LEFT));
preOnRight = ((pretype == PREC_BOTH) || (pretype == PREC_RIGHT));
scale_x = (sx != NULL);
scale_b = (sb != NULL);
/* Set r_star to initial (unscaled) residual r_0 = b - A*x_0 */
if (N_VDotProd(x, x) == ZERO) N_VScale(ONE, b, r_star);
else {
ier = atimes(A_data, x, r_star);
if (ier != 0)
return((ier < 0) ? SPBCG_ATIMES_FAIL_UNREC : SPBCG_ATIMES_FAIL_REC);
N_VLinearSum(ONE, b, -ONE, r_star, r_star);
}
/* Apply left preconditioner and b-scaling to r_star = r_0 */
if (preOnLeft) {
ier = psolve(P_data, r_star, r, PREC_LEFT);
(*nps)++;
if (ier != 0) return((ier < 0) ? SPBCG_PSOLVE_FAIL_UNREC : SPBCG_PSOLVE_FAIL_REC);
}
else N_VScale(ONE, r_star, r);
if (scale_b) N_VProd(sb, r, r_star);
else N_VScale(ONE, r, r_star);
/* Initialize beta_denom to the dot product of r0 with r0 */
beta_denom = N_VDotProd(r_star, r_star);
/* Set r_norm to L2 norm of r_star = sb P1_inv r_0, and
return if small */
*res_norm = r_norm = rho = RSqrt(beta_denom);
if (r_norm <= delta) return(SPBCG_SUCCESS);
/* Copy r_star to r and p */
N_VScale(ONE, r_star, r);
N_VScale(ONE, r_star, p);
/* Begin main iteration loop */
for(l = 0; l < l_max; l++) {
(*nli)++;
/* Generate Ap = A-tilde p, where A-tilde = sb P1_inv A P2_inv sx_inv */
/* Apply x-scaling: vtemp = sx_inv p */
if (scale_x) N_VDiv(p, sx, vtemp);
else N_VScale(ONE, p, vtemp);
/* Apply right preconditioner: vtemp = P2_inv sx_inv p */
if (preOnRight) {
N_VScale(ONE, vtemp, Ap);
ier = psolve(P_data, Ap, vtemp, PREC_RIGHT);
(*nps)++;
if (ier != 0) return((ier < 0) ? SPBCG_PSOLVE_FAIL_UNREC : SPBCG_PSOLVE_FAIL_REC);
}
/* Apply A: Ap = A P2_inv sx_inv p */
ier = atimes(A_data, vtemp, Ap );
if (ier != 0)
return((ier < 0) ? SPBCG_ATIMES_FAIL_UNREC : SPBCG_ATIMES_FAIL_REC);
/* Apply left preconditioner: vtemp = P1_inv A P2_inv sx_inv p */
if (preOnLeft) {
ier = psolve(P_data, Ap, vtemp, PREC_LEFT);
(*nps)++;
if (ier != 0) return((ier < 0) ? SPBCG_PSOLVE_FAIL_UNREC : SPBCG_PSOLVE_FAIL_REC);
}
else N_VScale(ONE, Ap, vtemp);
/* Apply b-scaling: Ap = sb P1_inv A P2_inv sx_inv p */
if (scale_b) N_VProd(sb, vtemp, Ap);
else N_VScale(ONE, vtemp, Ap);
/* Calculate alpha = <r,r_star>/<Ap,r_star> */
alpha = ((N_VDotProd(r, r_star) / N_VDotProd(Ap, r_star)));
/* Update q = r - alpha*Ap = r - alpha*(sb P1_inv A P2_inv sx_inv p) */
N_VLinearSum(ONE, r, -alpha, Ap, q);
/* Generate u = A-tilde q */
/* Apply x-scaling: vtemp = sx_inv q */
if (scale_x) N_VDiv(q, sx, vtemp);
else N_VScale(ONE, q, vtemp);
/* Apply right preconditioner: vtemp = P2_inv sx_inv q */
if (preOnRight) {
N_VScale(ONE, vtemp, u);
ier = psolve(P_data, u, vtemp, PREC_RIGHT);
(*nps)++;
if (ier != 0) return((ier < 0) ? SPBCG_PSOLVE_FAIL_UNREC : SPBCG_PSOLVE_FAIL_REC);
}
/* Apply A: u = A P2_inv sx_inv u */
ier = atimes(A_data, vtemp, u );
if (ier != 0)
return((ier < 0) ? SPBCG_ATIMES_FAIL_UNREC : SPBCG_ATIMES_FAIL_REC);
/* Apply left preconditioner: vtemp = P1_inv A P2_inv sx_inv p */
if (preOnLeft) {
ier = psolve(P_data, u, vtemp, PREC_LEFT);
(*nps)++;
if (ier != 0) return((ier < 0) ? SPBCG_PSOLVE_FAIL_UNREC : SPBCG_PSOLVE_FAIL_REC);
}
else N_VScale(ONE, u, vtemp);
/* Apply b-scaling: u = sb P1_inv A P2_inv sx_inv u */
if (scale_b) N_VProd(sb, vtemp, u);
else N_VScale(ONE, vtemp, u);
/* Calculate omega = <u,q>/<u,u> */
omega_denom = N_VDotProd(u, u);
if (omega_denom == ZERO) omega_denom = ONE;
omega = (N_VDotProd(u, q) / omega_denom);
/* Update x = x + alpha*p + omega*q */
N_VLinearSum(alpha, p, omega, q, vtemp);
N_VLinearSum(ONE, x, ONE, vtemp, x);
/* Update the residual r = q - omega*u */
N_VLinearSum(ONE, q, -omega, u, r);
/* Set rho = norm(r) and check convergence */
*res_norm = rho = RSqrt(N_VDotProd(r, r));
if (rho <= delta) {
converged = TRUE;
break;
}
/* Not yet converged, continue iteration */
/* Update beta = <rnew,r_star> / <rold,r_start> * alpha / omega */
beta_num = N_VDotProd(r, r_star);
beta = ((beta_num / beta_denom) * (alpha / omega));
beta_denom = beta_num;
/* Update p = r + beta*(p - omega*Ap) */
N_VLinearSum(ONE, p, -omega, Ap, vtemp);
N_VLinearSum(ONE, r, beta, vtemp, p);
}
/* Main loop finished */
if ((converged == TRUE) || (rho < r_norm)) {
/* Apply the x-scaling and right preconditioner: x = P2_inv sx_inv x */
if (scale_x) N_VDiv(x, sx, x);
if (preOnRight) {
ier = psolve(P_data, x, vtemp, PREC_RIGHT);
(*nps)++;
if (ier != 0) return((ier < 0) ? SPBCG_PSOLVE_FAIL_UNREC : SPBCG_PSOLVE_FAIL_REC);
N_VScale(ONE, vtemp, x);
}
if (converged == TRUE) return(SPBCG_SUCCESS);
else return(SPBCG_RES_REDUCED);
}
else return(SPBCG_CONV_FAIL);
}
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;
long 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);
}
/*---------------------------------------------------------------
IBBDDQJac
This routine generates a banded difference quotient approximation
to the local block of the Jacobian of G(t,y,y'). It assumes that
a band matrix of type SUNMatrix is stored column-wise, and that
elements within each column are contiguous.
All matrix elements are generated as difference quotients, by way
of calls to the user routine glocal. By virtue of the band
structure, the number of these calls is bandwidth + 1, where
bandwidth = mldq + mudq + 1. But the band matrix kept has
bandwidth = mlkeep + mukeep + 1. This routine also assumes that
the local elements of a vector are stored contiguously.
Return values are: 0 (success), > 0 (recoverable error),
or < 0 (nonrecoverable error).
----------------------------------------------------------------*/
static int IBBDDQJac(IBBDPrecData pdata, realtype tt, realtype cj,
N_Vector yy, N_Vector yp, N_Vector gref,
N_Vector ytemp, N_Vector yptemp, N_Vector gtemp)
{
IDAMem IDA_mem;
realtype inc, inc_inv;
int retval;
sunindextype group, i, j, width, ngroups, i1, i2;
realtype *ydata, *ypdata, *ytempdata, *yptempdata, *grefdata, *gtempdata;
realtype *cnsdata = NULL, *ewtdata;
realtype *col_j, conj, yj, ypj, ewtj;
IDA_mem = (IDAMem) pdata->ida_mem;
/* Initialize ytemp and yptemp. */
N_VScale(ONE, yy, ytemp);
N_VScale(ONE, yp, yptemp);
/* Obtain pointers as required to the data array of vectors. */
ydata = N_VGetArrayPointer(yy);
ypdata = N_VGetArrayPointer(yp);
gtempdata = N_VGetArrayPointer(gtemp);
ewtdata = N_VGetArrayPointer(IDA_mem->ida_ewt);
if (IDA_mem->ida_constraints != NULL)
cnsdata = N_VGetArrayPointer(IDA_mem->ida_constraints);
ytempdata = N_VGetArrayPointer(ytemp);
yptempdata= N_VGetArrayPointer(yptemp);
grefdata = N_VGetArrayPointer(gref);
/* Call gcomm and glocal to get base value of G(t,y,y'). */
if (pdata->gcomm != NULL) {
retval = pdata->gcomm(pdata->n_local, tt, yy, yp, IDA_mem->ida_user_data);
if (retval != 0) return(retval);
}
retval = pdata->glocal(pdata->n_local, tt, yy, yp, gref, IDA_mem->ida_user_data);
pdata->nge++;
if (retval != 0) return(retval);
/* Set bandwidth and number of column groups for band differencing. */
width = pdata->mldq + pdata->mudq + 1;
ngroups = SUNMIN(width, pdata->n_local);
/* Loop over groups. */
for(group = 1; group <= ngroups; group++) {
/* Loop over the components in this group. */
for(j = group-1; j < pdata->n_local; j += width) {
yj = ydata[j];
ypj = ypdata[j];
ewtj = ewtdata[j];
/* Set increment inc to yj based on rel_yy*abs(yj), with
adjustments using ypj and ewtj if this is small, and a further
adjustment to give it the same sign as hh*ypj. */
inc = pdata->rel_yy *
SUNMAX(SUNRabs(yj), SUNMAX( SUNRabs(IDA_mem->ida_hh*ypj), ONE/ewtj));
if (IDA_mem->ida_hh*ypj < ZERO) inc = -inc;
inc = (yj + inc) - yj;
/* Adjust sign(inc) again if yj has an inequality constraint. */
if (IDA_mem->ida_constraints != NULL) {
conj = cnsdata[j];
if (SUNRabs(conj) == ONE) {if ((yj+inc)*conj < ZERO) inc = -inc;}
else if (SUNRabs(conj) == TWO) {if ((yj+inc)*conj <= ZERO) inc = -inc;}
}
/* Increment yj and ypj. */
ytempdata[j] += inc;
yptempdata[j] += cj*inc;
}
/* Evaluate G with incremented y and yp arguments. */
retval = pdata->glocal(pdata->n_local, tt, ytemp, yptemp,
gtemp, IDA_mem->ida_user_data);
pdata->nge++;
if (retval != 0) return(retval);
/* Loop over components of the group again; restore ytemp and yptemp. */
for(j = group-1; j < pdata->n_local; j += width) {
yj = ytempdata[j] = ydata[j];
ypj = yptempdata[j] = ypdata[j];
ewtj = ewtdata[j];
/* Set increment inc as before .*/
inc = pdata->rel_yy *
SUNMAX(SUNRabs(yj), SUNMAX( SUNRabs(IDA_mem->ida_hh*ypj), ONE/ewtj));
if (IDA_mem->ida_hh*ypj < ZERO) inc = -inc;
inc = (yj + inc) - yj;
if (IDA_mem->ida_constraints != NULL) {
conj = cnsdata[j];
if (SUNRabs(conj) == ONE) {if ((yj+inc)*conj < ZERO) inc = -inc;}
else if (SUNRabs(conj) == TWO) {if ((yj+inc)*conj <= ZERO) inc = -inc;}
}
/* Form difference quotients and load into PP. */
inc_inv = ONE/inc;
col_j = SUNBandMatrix_Column(pdata->PP,j);
i1 = SUNMAX(0, j-pdata->mukeep);
i2 = SUNMIN(j + pdata->mlkeep, pdata->n_local-1);
for(i = i1; i <= i2; i++)
SM_COLUMN_ELEMENT_B(col_j,i,j) =
inc_inv * (gtempdata[i] - grefdata[i]);
}
}
return(0);
}
