realtype N_VMaxNorm_OpenMP(N_Vector x)
{
long int i, N;
realtype tmax, max, *xd;
max = ZERO;
xd = NULL;
N = NV_LENGTH_OMP(x);
xd = NV_DATA_OMP(x);
#pragma omp parallel default(none) private(i,tmax) shared(N,max,xd) \
num_threads(NV_NUM_THREADS_OMP(x))
{
tmax = ZERO;
#pragma omp for schedule(static)
for (i = 0; i < N; i++) {
if (SUNRabs(xd[i]) > tmax) tmax = SUNRabs(xd[i]);
}
#pragma omp critical
{
if (tmax > max)
max = tmax;
}
}
return(max);
}
/*-----------------------------------------------------------------
cvDlsDenseDQJac
-----------------------------------------------------------------
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 cvDlsDenseDQJac(realtype t, N_Vector y, N_Vector fy,
SUNMatrix Jac, CVodeMem cv_mem, N_Vector tmp1)
{
realtype fnorm, minInc, inc, inc_inv, yjsaved, srur;
realtype *y_data, *ewt_data;
N_Vector ftemp, jthCol;
sunindextype j, N;
int retval = 0;
CVDlsMem cvdls_mem;
/* access DlsMem interface structure */
cvdls_mem = (CVDlsMem) 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);
/* 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]);
y_data[j] += inc;
retval = cv_mem->cv_f(t, y, ftemp, cv_mem->cv_user_data);
cvdls_mem->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); /\*UNNECESSARY?? *\/ */
}
/* Destroy jthCol vector */
N_VSetArrayPointer(NULL, jthCol); /* SHOULDN'T BE NEEDED */
N_VDestroy(jthCol);
return(retval);
}
/* ----------------------------------------------------------------------
* Implementation-specific 'check' routines
* --------------------------------------------------------------------*/
int check_vector(N_Vector X, N_Vector Y, realtype tol)
{
int failure = 0;
sunindextype i, local_length;
realtype *Xdata, *Ydata, maxerr;
Xdata = N_VGetArrayPointer(X);
Ydata = N_VGetArrayPointer(Y);
local_length = N_VGetLength_Serial(X);
/* check vector data */
for(i=0; i < local_length; i++)
failure += FNEQ(Xdata[i], Ydata[i], tol);
if (failure > ZERO) {
maxerr = ZERO;
for(i=0; i < local_length; i++)
maxerr = SUNMAX(SUNRabs(Xdata[i]-Ydata[i]), maxerr);
printf("check err failure: maxerr = %g (tol = %g)\n",
maxerr, tol);
return(1);
}
else
return(0);
}
static int IDASensfnorm(IDAMem IDA_mem, realtype *fnorm)
{
int is, retval;
/* Get sensitivity residual */
retval = resS(Ns, t0,
yy0, yp0, delta,
yyS0new, ypS0new, delnewS,
user_dataS, tmpS1, tmpS2, tmpS3);
nrSe++;
if(retval < 0) return(IDA_RES_FAIL);
if(retval > 0) return(IC_FAIL_RECOV);
for(is=0; is<Ns; is++) N_VScale(ONE, delnewS[is], savresS[is]);
/* Call linear solve function */
for(is=0; is<Ns; is++) {
retval = lsolve(IDA_mem, delnewS[is], ewtS[is], yy0, yp0, delta);
if(retval < 0) return(IDA_LSOLVE_FAIL);
if(retval > 0) return(IC_FAIL_RECOV);
}
/* Compute the WRMS-norm; rescale if index = 0. */
*fnorm = IDASensWrmsNorm(IDA_mem, delnewS, ewtS, FALSE);
if(sysindex == 0) (*fnorm) *= tscale*SUNRabs(cj);
return(IDA_SUCCESS);
}
static int IDAfnorm(IDAMem IDA_mem, realtype *fnorm)
{
int retval;
/* Get residual vector F, return if failed, and save F in savres. */
retval = res(t0, ynew, ypnew, delnew, user_data);
nre++;
if(retval < 0) return(IDA_RES_FAIL);
if(retval > 0) return(IC_FAIL_RECOV);
N_VScale(ONE, delnew, savres);
/* Call the linear solve function to get J-inverse F; return if failed. */
retval = lsolve(IDA_mem, delnew, ewt, ynew, ypnew, savres);
if(retval < 0) return(IDA_LSOLVE_FAIL);
if(retval > 0) return(IC_FAIL_RECOV);
/* Compute the WRMS-norm; rescale if index = 0. */
*fnorm = IDAWrmsNorm(IDA_mem, delnew, ewt, FALSE);
if(sysindex == 0) (*fnorm) *= tscale*SUNRabs(cj);
return(IDA_SUCCESS);
}
int check_matrix_entry(SUNMatrix A, realtype val, realtype tol)
{
int failure = 0;
realtype *Adata;
sunindextype Aldata;
sunindextype i;
/* get data pointer */
Adata = SUNDenseMatrix_Data(A);
/* compare data */
Aldata = SUNDenseMatrix_LData(A);
for(i=0; i < Aldata; i++){
failure += FNEQ(Adata[i], val, tol);
}
if (failure > ZERO) {
printf("Check_matrix_entry failures:\n");
for(i=0; i < Aldata; i++)
if (FNEQ(Adata[i], val, tol) != 0)
printf(" Adata[%ld] = %g != %g (err = %g)\n", (long int) i,
Adata[i], val, SUNRabs(Adata[i]-val));
}
if (failure > ZERO)
return(1);
else
return(0);
}
static int IDAfnorm(IDAMem IDA_mem, realtype *fnorm)
{
int retval, is;
/* Get residual vector F, return if failed, and save F in savres. */
retval = res(t0, ynew, ypnew, delnew, user_data);
nre++;
if(retval < 0) return(IDA_RES_FAIL);
if(retval > 0) return(IC_FAIL_RECOV);
N_VScale(ONE, delnew, savres);
/* Call the linear solve function to get J-inverse F; return if failed. */
retval = lsolve(IDA_mem, delnew, ewt, ynew, ypnew, savres);
if(retval < 0) return(IDA_LSOLVE_FAIL);
if(retval > 0) return(IC_FAIL_RECOV);
/* Compute the WRMS-norm. */
*fnorm = IDAWrmsNorm(IDA_mem, delnew, ewt, FALSE);
/* Are we computing SENSITIVITIES with the IDA_SIMULTANEOUS approach? */
if(sensi && (ism==IDA_SIMULTANEOUS)) {
/* Evaluate the residual for sensitivities. */
retval = resS(Ns, t0,
ynew, ypnew, savres,
yyS0new, ypS0new, delnewS,
user_dataS, tmpS1, tmpS2, tmpS3);
nrSe++;
if(retval < 0) return(IDA_RES_FAIL);
if(retval > 0) return(IC_FAIL_RECOV);
/* Save delnewS in savresS. */
for(is=0; is<Ns; is++)
N_VScale(ONE, delnewS[is], savresS[is]);
/* Call the linear solve function to get J-inverse deltaS. */
for(is=0; is<Ns; is++) {
retval = lsolve(IDA_mem, delnewS[is], ewtS[is], ynew, ypnew, savres);
if(retval < 0) return(IDA_LSOLVE_FAIL);
if(retval > 0) return(IC_FAIL_RECOV);
}
/* Include sensitivities in norm. */
*fnorm = IDASensWrmsNormUpdate(IDA_mem, *fnorm, delnewS, ewtS, FALSE);
}
/* Rescale norm if index = 0. */
if(sysindex == 0) (*fnorm) *= tscale*SUNRabs(cj);
return(IDA_SUCCESS);
}
int KINSpilsDQJtimes(N_Vector v, N_Vector Jv,
N_Vector u, booleantype *new_u,
void *data)
{
realtype sigma, sigma_inv, sutsv, sq1norm, sign, vtv;
KINMem kin_mem;
KINSpilsMem kinspils_mem;
int retval;
/* data is kin_mem */
kin_mem = (KINMem) data;
kinspils_mem = (KINSpilsMem) lmem;
/* scale the vector v and put Du*v into vtemp1 */
N_VProd(v, uscale, vtemp1);
/* scale u and put into Jv (used as a temporary storage) */
N_VProd(u, uscale, Jv);
/* compute dot product (Du*u).(Du*v) */
sutsv = N_VDotProd(Jv, vtemp1);
/* compute dot product (Du*v).(Du*v) */
vtv = N_VDotProd(vtemp1, vtemp1);
sq1norm = N_VL1Norm(vtemp1);
sign = (sutsv >= ZERO) ? ONE : -ONE ;
/* this expression for sigma is from p. 469, Brown and Saad paper */
sigma = sign*sqrt_relfunc*SUNMAX(SUNRabs(sutsv),sq1norm)/vtv;
sigma_inv = ONE/sigma;
/* compute the u-prime at which to evaluate the function func */
N_VLinearSum(ONE, u, sigma, v, vtemp1);
/* call the system function to calculate func(u+sigma*v) */
retval = func(vtemp1, vtemp2, user_data);
nfes++;
if (retval != 0) return(retval);
/* finish the computation of the difference quotient */
N_VLinearSum(sigma_inv, vtemp2, -sigma_inv, fval, Jv);
return(0);
}
static int IDANewtonIC(IDAMem IDA_mem)
{
int retval, mnewt;
realtype delnorm, fnorm, fnorm0, oldfnrm, rate;
/* Set pointer for vector delnew */
IDA_mem->ida_delnew = IDA_mem->ida_phi[2];
/* Call the linear solve function to get the Newton step, delta. */
retval = IDA_mem->ida_lsolve(IDA_mem, IDA_mem->ida_delta,
IDA_mem->ida_ewt, IDA_mem->ida_yy0,
IDA_mem->ida_yp0, IDA_mem->ida_savres);
if(retval < 0) return(IDA_LSOLVE_FAIL);
if(retval > 0) return(IC_FAIL_RECOV);
/* Compute the norm of the step; return now if this is small. */
fnorm = IDAWrmsNorm(IDA_mem, IDA_mem->ida_delta, IDA_mem->ida_ewt, SUNFALSE);
if(IDA_mem->ida_sysindex == 0)
fnorm *= IDA_mem->ida_tscale * SUNRabs(IDA_mem->ida_cj);
if(fnorm <= IDA_mem->ida_epsNewt)
return(IDA_SUCCESS);
fnorm0 = fnorm;
/* Initialize rate to avoid compiler warning message */
rate = ZERO;
/* Newton iteration loop */
for(mnewt = 0; mnewt < IDA_mem->ida_maxnit; mnewt++) {
IDA_mem->ida_nni++;
delnorm = fnorm;
oldfnrm = fnorm;
/* Call the Linesearch function and return if it failed. */
retval = IDALineSrch(IDA_mem, &delnorm, &fnorm);
if(retval != IDA_SUCCESS) return(retval);
/* Set the observed convergence rate and test for convergence. */
rate = fnorm/oldfnrm;
if(fnorm <= IDA_mem->ida_epsNewt) return(IDA_SUCCESS);
/* If not converged, copy new step vector, and loop. */
N_VScale(ONE, IDA_mem->ida_delnew, IDA_mem->ida_delta);
} /* End of Newton iteration loop */
/* Return either IC_SLOW_CONVRG or recoverable fail flag. */
if(rate <= ICRATEMAX || fnorm < PT1*fnorm0) return(IC_SLOW_CONVRG);
return(IC_CONV_FAIL);
}
realtype N_VMaxNorm_Parallel(N_Vector x)
{
long int i, N;
realtype max, *xd, gmax;
MPI_Comm comm;
xd = NULL;
N = NV_LOCLENGTH_P(x);
xd = NV_DATA_P(x);
comm = NV_COMM_P(x);
max = ZERO;
for (i = 0; i < N; i++) {
if (SUNRabs(xd[i]) > max) max = SUNRabs(xd[i]);
}
gmax = VAllReduce_Parallel(max, 2, comm);
return(gmax);
}
/* ----------------------------------------------------------------------
* Implementation-specific 'check' routines
* --------------------------------------------------------------------*/
int check_vector(N_Vector X, N_Vector Y, realtype tol)
{
int failure = 0;
sunindextype i;
realtype *Xdata, *Ydata, maxerr;
Xdata = N_VGetArrayPointer(X);
Ydata = N_VGetArrayPointer(Y);
/* check vector data */
for(i=0; i<problem_size; i++)
failure += FNEQ(Xdata[i], Ydata[i], FIVE*tol*SUNRabs(Xdata[i]));
if (failure > ZERO) {
maxerr = ZERO;
for(i=0; i < problem_size; i++)
maxerr = SUNMAX(SUNRabs(Xdata[i]-Ydata[i])/SUNRabs(Xdata[i]), maxerr);
printf("check err failure: maxerr = %g (tol = %g)\n",
maxerr, FIVE*tol);
return(1);
}
else
return(0);
}
/*---------------------------------------------------------------
ARKSpbcgSetup:
This routine does the setup operations for the Spbcg linear
solver. It makes a decision as to whether or not to signal for
reevaluation of Jacobian data in the pset routine, based on
various state variables, then it calls pset. If we signal for
reevaluation, then we reset jcur = *jcurPtr to TRUE, regardless
of the pset output. In any case, if jcur == TRUE, we increment
npe and save nst in nstlpre.
---------------------------------------------------------------*/
static int ARKSpbcgSetup(ARKodeMem ark_mem, int convfail,
N_Vector ypred, N_Vector fpred,
booleantype *jcurPtr, N_Vector vtemp1,
N_Vector vtemp2, N_Vector vtemp3)
{
booleantype jbad, jok;
realtype dgamma;
int retval;
ARKSpilsMem arkspils_mem;
arkspils_mem = (ARKSpilsMem) ark_mem->ark_lmem;
/* Use nst, gamma/gammap, and convfail to set J eval. flag jok */
dgamma = SUNRabs((ark_mem->ark_gamma/ark_mem->ark_gammap) - ONE);
jbad = (ark_mem->ark_nst == 0) ||
(ark_mem->ark_nst > arkspils_mem->s_nstlpre + ARKSPILS_MSBPRE) ||
((convfail == ARK_FAIL_BAD_J) && (dgamma < ARKSPILS_DGMAX)) ||
(convfail == ARK_FAIL_OTHER);
*jcurPtr = jbad;
jok = !jbad;
/* Call pset routine and possibly reset jcur */
retval = arkspils_mem->s_pset(ark_mem->ark_tn, ypred, fpred, jok,
jcurPtr, ark_mem->ark_gamma,
arkspils_mem->s_P_data, vtemp1,
vtemp2, vtemp3);
if (retval < 0) {
arkProcessError(ark_mem, SPBCG_PSET_FAIL_UNREC, "ARKSPBCG",
"ARKSpbcgSetup", MSGS_PSET_FAILED);
arkspils_mem->s_last_flag = SPBCG_PSET_FAIL_UNREC;
}
if (retval > 0) {
arkspils_mem->s_last_flag = SPBCG_PSET_FAIL_REC;
}
if (jbad) *jcurPtr = TRUE;
/* If jcur = TRUE, increment npe and save nst value */
if (*jcurPtr) {
arkspils_mem->s_npe++;
arkspils_mem->s_nstlpre = ark_mem->ark_nst;
}
arkspils_mem->s_last_flag = SPBCG_SUCCESS;
/* Return the same value that pset returned */
return(retval);
}
void N_VAbs_Parallel(N_Vector x, N_Vector z)
{
long int i, N;
realtype *xd, *zd;
xd = zd = NULL;
N = NV_LOCLENGTH_P(x);
xd = NV_DATA_P(x);
zd = NV_DATA_P(z);
for (i = 0; i < N; i++)
zd[i] = SUNRabs(xd[i]);
return;
}
void N_VCompare_Parallel(realtype c, N_Vector x, N_Vector z)
{
long int i, N;
realtype *xd, *zd;
xd = zd = NULL;
N = NV_LOCLENGTH_P(x);
xd = NV_DATA_P(x);
zd = NV_DATA_P(z);
for (i = 0; i < N; i++) {
zd[i] = (SUNRabs(xd[i]) >= c) ? ONE : ZERO;
}
return;
}
void N_VAbs_OpenMP(N_Vector x, N_Vector z)
{
long int i, N;
realtype *xd, *zd;
xd = zd = NULL;
N = NV_LENGTH_OMP(x);
xd = NV_DATA_OMP(x);
zd = NV_DATA_OMP(z);
#pragma omp parallel for schedule(static) num_threads(NV_NUM_THREADS_OMP(x))
for (i = 0; i < N; i++)
zd[i] = SUNRabs(xd[i]);
return;
}
/*
* -----------------------------------------------------------------
* IDASensNewtonIC
* -----------------------------------------------------------------
* IDANewtonIC performs the Newton iteration to solve for
* sensitivities consistent initial conditions. It calls
* IDASensLineSrch within each iteration.
* On return, savresS contains the current residual vectors.
*
* The return value is IDA_SUCCESS = 0 if no error occurred.
* The error return values (positive) considered recoverable are:
* IC_FAIL_RECOV if res or lsolve failed recoverably
* IC_CONSTR_FAILED if the constraints could not be met
* IC_LINESRCH_FAILED if the linesearch failed (on steptol test)
* IC_CONV_FAIL if the Newton iterations failed to converge
* IC_SLOW_CONVRG if the iterations appear to be converging slowly.
* They failed the convergence test, but showed
* an overall norm reduction (by a factor of < 0.1)
* or a convergence rate <= ICRATEMAX).
* The error return values (negative) considered non-recoverable are:
* IDA_RES_FAIL if res had a non-recoverable error
* IDA_LSOLVE_FAIL if lsolve had a non-recoverable error
* -----------------------------------------------------------------
*/
static int IDASensNewtonIC(IDAMem IDA_mem)
{
int retval, is, mnewt;
realtype delnorm, fnorm, fnorm0, oldfnrm, rate;
for(is=0;is<Ns;is++) {
/* Call the linear solve function to get the Newton step, delta. */
retval = lsolve(IDA_mem, deltaS[is], ewtS[is], yy0, yp0, delta);
if(retval < 0) return(IDA_LSOLVE_FAIL);
if(retval > 0) return(IC_FAIL_RECOV);
}
/* Compute the norm of the step and return if it is small enough */
fnorm = IDASensWrmsNorm(IDA_mem, deltaS, ewtS, FALSE);
if(sysindex == 0) fnorm *= tscale*SUNRabs(cj);
if(fnorm <= epsNewt) return(IDA_SUCCESS);
fnorm0 = fnorm;
rate = ZERO;
/* Newton iteration loop */
for(mnewt = 0; mnewt < maxnit; mnewt++) {
nniS++;
delnorm = fnorm;
oldfnrm = fnorm;
/* Call the Linesearch function and return if it failed. */
retval = IDASensLineSrch(IDA_mem, &delnorm, &fnorm);
if(retval != IDA_SUCCESS) return(retval);
/* Set the observed convergence rate and test for convergence. */
rate = fnorm/oldfnrm;
if(fnorm <= epsNewt) return(IDA_SUCCESS);
/* If not converged, copy new step vectors, and loop. */
for(is=0; is<Ns; is++) N_VScale(ONE, delnewS[is], deltaS[is]);
} /* End of Newton iteration loop */
/* Return either IC_SLOW_CONVRG or recoverable fail flag. */
if(rate <= ICRATEMAX || fnorm < PT1*fnorm0) return(IC_SLOW_CONVRG);
return(IC_CONV_FAIL);
}
realtype N_VL1Norm_OpenMP(N_Vector x)
{
long int i, N;
realtype sum, *xd;
sum = ZERO;
xd = NULL;
N = NV_LENGTH_OMP(x);
xd = NV_DATA_OMP(x);
#pragma omp parallel for default(none) private(i) shared(N,xd) \
reduction(+:sum) schedule(static) num_threads(NV_NUM_THREADS_OMP(x))
for (i = 0; i<N; i++)
sum += SUNRabs(xd[i]);
return(sum);
}
static void PrintOutput(N_Vector cB, int ns, int mxns, WebData wdata)
{
int i, jx, jy;
realtype *cdata, cij, cmax, x, y;
x = y = ZERO;
cdata = N_VGetArrayPointer(cB);
for (i=1; i <= ns; i++) {
cmax = ZERO;
for (jy=MY-1; jy >= 0; jy--) {
for (jx=0; jx < MX; jx++) {
cij = cdata[(i-1) + jx*ns + jy*mxns];
if (SUNRabs(cij) > cmax) {
cmax = cij;
x = jx * wdata->dx;
y = jy * wdata->dy;
}
}
}
printf("\nMaximum sensitivity with respect to I.C. of species %d\n", i);
#if defined(SUNDIALS_EXTENDED_PRECISION)
printf(" lambda max = %Le\n",cmax);
#elif defined(SUNDIALS_DOUBLE_PRECISION)
printf(" lambda max = %e\n",cmax);
#else
printf(" lambda max = %e\n",cmax);
#endif
printf("at\n");
#if defined(SUNDIALS_EXTENDED_PRECISION)
printf(" x = %Le\n y = %Le\n", x, y);
#elif defined(SUNDIALS_DOUBLE_PRECISION)
printf(" x = %e\n y = %e\n", x, y);
#else
printf(" x = %e\n y = %e\n", x, y);
#endif
}
}
static int CVSpbcgSetup(CVodeMem cv_mem, int convfail, N_Vector ypred,
N_Vector fpred, booleantype *jcurPtr, N_Vector vtemp1,
N_Vector vtemp2, N_Vector vtemp3)
{
booleantype jbad, jok;
realtype dgamma;
int retval;
CVSpilsMem cvspils_mem;
cvspils_mem = (CVSpilsMem) lmem;
/* Use nst, gamma/gammap, and convfail to set J eval. flag jok */
dgamma = SUNRabs((gamma/gammap) - ONE);
jbad = (nst == 0) || (nst > nstlpre + CVSPILS_MSBPRE) ||
((convfail == CV_FAIL_BAD_J) && (dgamma < CVSPILS_DGMAX)) ||
(convfail == CV_FAIL_OTHER);
*jcurPtr = jbad;
jok = !jbad;
/* Call pset routine and possibly reset jcur */
retval = pset(tn, ypred, fpred, jok, jcurPtr, gamma, P_data,
vtemp1, vtemp2, vtemp3);
if (retval < 0) {
cvProcessError(cv_mem, SPBCG_PSET_FAIL_UNREC, "CVSPBCG", "CVSpbcgSetup", MSGS_PSET_FAILED);
last_flag = SPBCG_PSET_FAIL_UNREC;
}
if (retval > 0) {
last_flag = SPBCG_PSET_FAIL_REC;
}
if (jbad) *jcurPtr = TRUE;
/* If jcur = TRUE, increment npe and save nst value */
if (*jcurPtr) {
npe++;
nstlpre = nst;
}
last_flag = SPBCG_SUCCESS;
/* Return the same value that pset returned */
return(retval);
}
void N_VCompare_OpenMP(realtype c, N_Vector x, N_Vector z)
{
long int i, N;
realtype *xd, *zd;
xd = zd = NULL;
N = NV_LENGTH_OMP(x);
xd = NV_DATA_OMP(x);
zd = NV_DATA_OMP(z);
#pragma omp parallel for default(none) private(i) shared(N,c,xd,zd) schedule(static) \
num_threads(NV_NUM_THREADS_OMP(x))
for (i = 0; i < N; i++) {
zd[i] = (SUNRabs(xd[i]) >= c) ? ONE : ZERO;
}
return;
}
static int ewt(N_Vector y, N_Vector w, void *user_data)
{
int i;
realtype yy, ww, rtol, atol[3];
rtol = RTOL;
atol[0] = ATOL1;
atol[1] = ATOL2;
atol[2] = ATOL3;
for (i=1; i<=3; i++) {
yy = Ith(y,i);
ww = rtol * SUNRabs(yy) + atol[i-1];
if (ww <= 0.0) return (-1);
Ith(w,i) = 1.0/ww;
}
return(0);
}
static void PrintOutput(N_Vector uB, UserData data)
{
realtype *uBdata, uBij, uBmax, x, y, dx, dy;
int i, j;
x = y = ZERO;
dx = data->dx;
dy = data->dy;
uBdata = N_VGetArrayPointer(uB);
uBmax = ZERO;
for(j=1; j<= MY; j++) {
for(i=1; i<=MX; i++) {
uBij = IJth(uBdata, i, j);
if (SUNRabs(uBij) > uBmax) {
uBmax = uBij;
x = i*dx;
y = j*dy;
}
}
}
printf("\nMaximum sensitivity\n");
#if defined(SUNDIALS_EXTENDED_PRECISION)
printf(" lambda max = %Le\n", uBmax);
#elif defined(SUNDIALS_DOUBLE_PRECISION)
printf(" lambda max = %e\n", uBmax);
#else
printf(" lambda max = %e\n", uBmax);
#endif
printf("at\n");
#if defined(SUNDIALS_EXTENDED_PRECISION)
printf(" x = %Le\n y = %Le\n", x, y);
#elif defined(SUNDIALS_DOUBLE_PRECISION)
printf(" x = %e\n y = %e\n", x, y);
#else
printf(" x = %e\n y = %e\n", x, y);
#endif
}
realtype N_VL1Norm_Parallel(N_Vector x)
{
long int i, N;
realtype sum, gsum, *xd;
MPI_Comm comm;
sum = ZERO;
xd = NULL;
N = NV_LOCLENGTH_P(x);
xd = NV_DATA_P(x);
comm = NV_COMM_P(x);
for (i = 0; i<N; i++)
sum += SUNRabs(xd[i]);
gsum = VAllReduce_Parallel(sum, 1, comm);
return(gsum);
}
int check_vector(N_Vector x, N_Vector y, realtype tol)
{
int failure = 0;
realtype *xdata, *ydata;
sunindextype xldata, yldata;
sunindextype i;
/* get vector data */
xdata = N_VGetArrayPointer(x);
ydata = N_VGetArrayPointer(y);
/* check data lengths */
xldata = N_VGetLength_Serial(x);
yldata = N_VGetLength_Serial(y);
if (xldata != yldata) {
printf(">>> ERROR: check_vector: Different data array lengths \n");
return(1);
}
/* check vector data */
for(i=0; i < xldata; i++)
failure += FNEQ(xdata[i], ydata[i], tol);
if (failure > ZERO) {
printf("Check_vector failures:\n");
for(i=0; i < xldata; i++)
if (FNEQ(xdata[i], ydata[i], tol) != 0)
printf(" xdata[%ld] = %g != %g (err = %g)\n", (long int) i,
xdata[i], ydata[i], SUNRabs(xdata[i]-ydata[i]));
}
if (failure > ZERO)
return(1);
else
return(0);
}
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 == FALSE) {
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 = TRUE;
/* 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 && (id == NULL)) {
IDAProcessError(IDA_mem, IDA_ILL_INPUT, "IDA", "IDACalcIC", MSG_IC_MISSING_ID);
return(IDA_ILL_INPUT);
}
tdist = SUNRabs(tout1 - tn);
troundoff = TWO*uround*(SUNRabs(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 */
yy0 = N_VClone(ee);
yp0 = N_VClone(ee);
t0 = tn;
N_VScale(ONE, phi[0], yy0);
N_VScale(ONE, phi[1], 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(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 = epiccon;
/* Initializations:
cjratio = 1 (for use in direct linear solvers);
set nbacktr = 0; */
cjratio = ONE;
nbacktr = 0;
/* Set hic, hh, cj, and mxnh. */
hic = PT001*tdist;
ypnorm = IDAWrmsNorm(IDA_mem, yp0, ewt, suppressalg);
if(ypnorm > HALF/hic) hic = HALF/ypnorm;
if(tout1 < tn) hic = -hic;
hh = hic;
if(icopt == IDA_YA_YDP_INIT) {
cj = ONE/hic;
mxnh = maxnh;
}
else {
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;
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, phi[0], yy0);
N_VScale(ONE, phi[1], yp0);
}
hic *= PT1;
cj = ONE/hic;
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 = efun(yy0, ewt, edata);
if(ewtsetOK != 0) {
retval = IDA_BAD_EWT;
break;
}
N_VScale(ONE, yy0, phi[0]);
N_VScale(ONE, yp0, phi[1]);
} /* End of nwt loop */
/* Free temporary space */
N_VDestroy(yy0);
N_VDestroy(yp0);
/* Load the optional outputs. */
if(icopt == IDA_YA_YDP_INIT) 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 KBBDDQJac(KBBDPrecData pdata,
N_Vector uu, N_Vector uscale,
N_Vector gu, N_Vector gtemp, N_Vector utemp)
{
realtype inc, inc_inv;
long int group, i, j, width, ngroups, i1, i2;
KINMem kin_mem;
realtype *udata, *uscdata, *gudata, *gtempdata, *utempdata, *col_j;
int retval;
kin_mem = (KINMem) pdata->kin_mem;
/* set pointers to the data for all vectors */
udata = N_VGetArrayPointer(uu);
uscdata = N_VGetArrayPointer(uscale);
gudata = N_VGetArrayPointer(gu);
gtempdata = N_VGetArrayPointer(gtemp);
utempdata = N_VGetArrayPointer(utemp);
/* load utemp with uu = predicted solution vector */
N_VScale(ONE, uu, utemp);
/* call gcomm and gloc to get base value of g(uu) */
if (gcomm != NULL) {
retval = gcomm(Nlocal, uu, user_data);
if (retval != 0) return(retval);
}
retval = gloc(Nlocal, uu, gu, user_data);
if (retval != 0) return(retval);
/* set bandwidth and number of column groups for band differencing */
width = mldq + mudq + 1;
ngroups = SUNMIN(width, Nlocal);
/* loop over groups */
for (group = 1; group <= ngroups; group++) {
/* increment all u_j in group */
for(j = group - 1; j < Nlocal; j += width) {
inc = rel_uu * SUNMAX(SUNRabs(udata[j]), (ONE / uscdata[j]));
utempdata[j] += inc;
}
/* evaluate g with incremented u */
retval = gloc(Nlocal, utemp, gtemp, user_data);
if (retval != 0) return(retval);
/* restore utemp, then form and load difference quotients */
for (j = group - 1; j < Nlocal; j += width) {
utempdata[j] = udata[j];
col_j = BAND_COL(PP,j);
inc = rel_uu * SUNMAX(SUNRabs(udata[j]) , (ONE / uscdata[j]));
inc_inv = ONE / inc;
i1 = SUNMAX(0, (j - mukeep));
i2 = SUNMIN((j + mlkeep), (Nlocal - 1));
for (i = i1; i <= i2; i++)
BAND_COL_ELEM(col_j, i, j) = inc_inv * (gtempdata[i] - gudata[i]);
}
}
return(0);
}
/*---------------------------------------------------------------
ARKBandPDQJac:
This routine generates a banded difference quotient approximation to
the Jacobian of f(t,y). It assumes that a band matrix of type
DlsMat 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 macro BAND_COL and to write a simple for loop to set
each of the elements of a column in succession.
---------------------------------------------------------------*/
static int ARKBandPDQJac(ARKBandPrecData pdata,
realtype t, N_Vector y, N_Vector fy,
N_Vector ftemp, N_Vector ytemp)
{
ARKodeMem ark_mem;
realtype fnorm, minInc, inc, inc_inv, srur;
long int group, i, j, width, ngroups, i1, i2;
realtype *col_j, *ewt_data, *fy_data, *ftemp_data, *y_data, *ytemp_data;
int retval;
ark_mem = (ARKodeMem) pdata->arkode_mem;
/* Obtain pointers to the data for ewt, fy, ftemp, y, ytemp. */
ewt_data = N_VGetArrayPointer(ark_mem->ark_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(ark_mem->ark_uround);
/* fnorm = N_VWrmsNorm(fy, ark_mem->ark_ewt); */
fnorm = N_VWrmsNorm(fy, ark_mem->ark_rwt);
minInc = (fnorm != ZERO) ?
(MIN_INC_MULT * SUNRabs(ark_mem->ark_h) * ark_mem->ark_uround * pdata->N * fnorm) : ONE;
/* Set bandwidth and number of column groups for band differencing. */
width = pdata->ml + pdata->mu + 1;
ngroups = SUNMIN(width, pdata->N);
for (group = 1; group <= ngroups; group++) {
/* Increment all y_j in group. */
for(j = group-1; j < pdata->N; j += width) {
inc = SUNMAX(srur*SUNRabs(y_data[j]), minInc/ewt_data[j]);
ytemp_data[j] += inc;
}
/* Evaluate f with incremented y. */
retval = ark_mem->ark_fi(t, ytemp, ftemp, ark_mem->ark_user_data);
pdata->nfeBP++;
if (retval != 0) return(retval);
/* Restore ytemp, then form and load difference quotients. */
for (j = group-1; j < pdata->N; j += width) {
ytemp_data[j] = y_data[j];
col_j = BAND_COL(pdata->savedJ,j);
inc = SUNMAX(srur*SUNRabs(y_data[j]), minInc/ewt_data[j]);
inc_inv = ONE/inc;
i1 = SUNMAX(0, j-pdata->mu);
i2 = SUNMIN(j+pdata->ml, pdata->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);
}
/*---------------------------------------------------------------
arkKLUSetup:
This routine does the setup operations for the ARKKLU linear
solver module. It calls the Jacobian evaluation routine,
updates counters, and calls the LU factorization routine.
The return value is either
ARKSLS_SUCCESS = 0 if successful,
+1 if the jac routine failed recoverably or the
LU factorization failed, or
-1 if the jac routine failed unrecoverably.
---------------------------------------------------------------*/
static int arkKLUSetup(ARKodeMem ark_mem, int convfail,
N_Vector ypred, N_Vector fpred,
booleantype *jcurPtr, N_Vector vtemp1,
N_Vector vtemp2, N_Vector vtemp3)
{
booleantype jbad, jok;
realtype dgamma;
ARKSlsMem arksls_mem;
ARKSlsMassMem arksls_mass_mem;
KLUData klu_data;
int retval;
realtype uround_twothirds;
uround_twothirds = SUNRpowerR(ark_mem->ark_uround,TWOTHIRDS);
arksls_mem = (ARKSlsMem) ark_mem->ark_lmem;
klu_data = (KLUData) arksls_mem->s_solver_data;
/* Check that Jacobian eval routine is set */
if (arksls_mem->s_Jeval == NULL) {
arkProcessError(ark_mem, ARKSLS_JAC_NOSET, "ARKSLS",
"arkKLUSetup", MSGSP_JAC_NOSET);
free(arksls_mem); arksls_mem = NULL;
return(ARKSLS_JAC_NOSET);
}
/* Use nst, gamma/gammap, and convfail to set J eval. flag jok */
dgamma = SUNRabs((ark_mem->ark_gamma/ark_mem->ark_gammap) - ONE);
jbad = (ark_mem->ark_nst == 0) ||
(ark_mem->ark_nst > arksls_mem->s_nstlj + ARKS_MSBJ) ||
((convfail == ARK_FAIL_BAD_J) && (dgamma < ARKS_DGMAX)) ||
(convfail == ARK_FAIL_OTHER);
jok = !jbad;
/* If jok = TRUE, use saved copy of J */
if (jok) {
*jcurPtr = FALSE;
SparseCopyMat(arksls_mem->s_savedJ, arksls_mem->s_A);
/* If jok = FALSE, call jac routine for new J value */
} else {
arksls_mem->s_nje++;
arksls_mem->s_nstlj = ark_mem->ark_nst;
*jcurPtr = TRUE;
SparseSetMatToZero(arksls_mem->s_A);
retval = arksls_mem->s_Jeval(ark_mem->ark_tn, ypred, fpred,
arksls_mem->s_A, arksls_mem->s_Jdata,
vtemp1, vtemp2, vtemp3);
if (retval < 0) {
arkProcessError(ark_mem, ARKSLS_JACFUNC_UNRECVR, "ARKSLS",
"arkKLUSetup", MSGSP_JACFUNC_FAILED);
arksls_mem->s_last_flag = ARKSLS_JACFUNC_UNRECVR;
return(-1);
}
if (retval > 0) {
arksls_mem->s_last_flag = ARKSLS_JACFUNC_RECVR;
return(1);
}
SparseCopyMat(arksls_mem->s_A, arksls_mem->s_savedJ);
}
/* Scale J by -gamma */
SparseScaleMat(-ark_mem->ark_gamma, arksls_mem->s_A);
/* Add mass matrix to get A = M-gamma*J */
if (ark_mem->ark_mass_matrix) {
/* Compute mass matrix */
arksls_mass_mem = (ARKSlsMassMem) ark_mem->ark_mass_mem;
SparseSetMatToZero(arksls_mass_mem->s_M);
retval = arksls_mass_mem->s_Meval(ark_mem->ark_tn,
arksls_mass_mem->s_M,
arksls_mass_mem->s_Mdata,
vtemp1, vtemp2, vtemp3);
arksls_mass_mem->s_nme++;
if (retval < 0) {
arkProcessError(ark_mem, ARKSLS_MASSFUNC_UNRECVR, "ARKSLS",
"arkKLUSetup", MSGSP_MASSFUNC_FAILED);
arksls_mem->s_last_flag = ARKSLS_MASSFUNC_UNRECVR;
return(-1);
}
if (retval > 0) {
arksls_mem->s_last_flag = ARKSLS_MASSFUNC_RECVR;
return(1);
}
/* add to A */
retval = SparseAddMat(arksls_mem->s_A, arksls_mass_mem->s_M);
if (retval < 0) {
arkProcessError(ark_mem, ARKSLS_PACKAGE_FAIL, "ARKSLS",
"arkKLUSetup", "Error in adding mass matrix to Jacobian");
arksls_mem->s_last_flag = ARKSLS_PACKAGE_FAIL;
return(retval);
}
if (retval > 0) return(retval);
} else {
SparseAddIdentityMat(arksls_mem->s_A);
}
/* On first decomposition, get the symbolic factorization */
if (arksls_mem->s_first_factorize) {
/* Update the ordering option with user-updated values */
klu_data->s_Common.ordering = klu_data->s_ordering;
/* Perform symbolic analysis of sparsity structure */
if (klu_data->s_Symbolic != NULL) {
klu_free_symbolic(&(klu_data->s_Symbolic), &(klu_data->s_Common));
}
klu_data->s_Symbolic = klu_analyze(arksls_mem->s_A->NP,
arksls_mem->s_A->indexptrs,
arksls_mem->s_A->indexvals,
&(klu_data->s_Common));
if (klu_data->s_Symbolic == NULL) {
arkProcessError(ark_mem, ARKSLS_PACKAGE_FAIL, "ARKSLS",
"ARKKLUSetup", MSGSP_PACKAGE_FAIL);
return(ARKSLS_PACKAGE_FAIL);
}
/* ------------------------------------------------------------
Compute the LU factorization of the Jacobian.
------------------------------------------------------------*/
if( klu_data->s_Numeric != NULL) {
klu_free_numeric(&(klu_data->s_Numeric), &(klu_data->s_Common));
}
klu_data->s_Numeric = klu_factor(arksls_mem->s_A->indexptrs,
arksls_mem->s_A->indexvals,
arksls_mem->s_A->data,
klu_data->s_Symbolic,
&(klu_data->s_Common));
if (klu_data->s_Numeric == NULL) {
arkProcessError(ark_mem, ARKSLS_PACKAGE_FAIL, "ARKSLS",
"ARKKLUSetup", MSGSP_PACKAGE_FAIL);
return(ARKSLS_PACKAGE_FAIL);
}
arksls_mem->s_first_factorize = 0;
}
else {
retval = klu_refactor(arksls_mem->s_A->indexptrs,
arksls_mem->s_A->indexvals,
arksls_mem->s_A->data,
klu_data->s_Symbolic, klu_data->s_Numeric,
&(klu_data->s_Common));
if (retval == 0) {
arkProcessError(ark_mem, ARKSLS_PACKAGE_FAIL, "ARKSLS",
"ARKKLUSetup", MSGSP_PACKAGE_FAIL);
return(ARKSLS_PACKAGE_FAIL);
}
/*-----------------------------------------------------------
Check if a cheap estimate of the reciprocal of the condition
number is getting too small. If so, delete
the prior numeric factorization and recompute it.
-----------------------------------------------------------*/
retval = klu_rcond(klu_data->s_Symbolic, klu_data->s_Numeric,
&(klu_data->s_Common));
if (retval == 0) {
arkProcessError(ark_mem, ARKSLS_PACKAGE_FAIL, "ARKSLS",
"ARKKLUSetup", MSGSP_PACKAGE_FAIL);
return(ARKSLS_PACKAGE_FAIL);
}
if ( (klu_data->s_Common.rcond) < uround_twothirds ) {
/* Condition number may be getting large.
Compute more accurate estimate */
retval = klu_condest(arksls_mem->s_A->indexptrs,
arksls_mem->s_A->data,
klu_data->s_Symbolic, klu_data->s_Numeric,
&(klu_data->s_Common));
if (retval == 0) {
arkProcessError(ark_mem, ARKSLS_PACKAGE_FAIL, "ARKSLS",
"ARKKLUSetup", MSGSP_PACKAGE_FAIL);
return(ARKSLS_PACKAGE_FAIL);
}
if ( (klu_data->s_Common.condest) >
(1.0/uround_twothirds) ) {
/* More accurate estimate also says condition number is
large, so recompute the numeric factorization */
klu_free_numeric(&(klu_data->s_Numeric), &(klu_data->s_Common));
klu_data->s_Numeric = klu_factor(arksls_mem->s_A->indexptrs,
arksls_mem->s_A->indexvals,
arksls_mem->s_A->data,
klu_data->s_Symbolic,
&(klu_data->s_Common));
if (klu_data->s_Numeric == NULL) {
arkProcessError(ark_mem, ARKSLS_PACKAGE_FAIL, "ARKSLS",
"ARKKLUSetup", MSGSP_PACKAGE_FAIL);
return(ARKSLS_PACKAGE_FAIL);
}
}
}
}
arksls_mem->s_last_flag = ARKSLS_SUCCESS;
return(0);
}
/*
* -----------------------------------------------------------------
* idaDlsDenseDQJac
* -----------------------------------------------------------------
* This routine generates a dense difference quotient approximation to
* the Jacobian F_y + c_j*F_y'. It assumes that a dense matrix of type
* DlsMat is stored column-wise, and that elements within each column
* are contiguous. The address of the jth column of J is obtained via
* the macro LAPACK_DENSE_COL and this pointer is associated with an N_Vector
* using the N_VGetArrayPointer/N_VSetArrayPointer functions.
* Finally, the actual computation of the jth column of the Jacobian is
* done with a call to N_VLinearSum.
* -----------------------------------------------------------------
*/
int idaDlsDenseDQJac(long int N, 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;
realtype *tmp2_data, *y_data, *yp_data, *ewt_data, *cns_data = NULL;
N_Vector rtemp, jthCol;
long int j;
int retval = 0;
IDAMem IDA_mem;
IDADlsMem idadls_mem;
/* data points to IDA_mem */
IDA_mem = (IDAMem) data;
idadls_mem = (IDADlsMem) lmem;
/* Save pointer to the array in tmp2 */
tmp2_data = N_VGetArrayPointer(tmp2);
/* Rename work vectors for readibility */
rtemp = tmp1;
jthCol = tmp2;
/* Obtain pointers to the data for ewt, yy, yp. */
ewt_data = N_VGetArrayPointer(ewt);
y_data = N_VGetArrayPointer(yy);
yp_data = N_VGetArrayPointer(yp);
if(constraints!=NULL) cns_data = N_VGetArrayPointer(constraints);
srur = SUNRsqrt(uround);
for (j=0; j < N; j++) {
/* Generate the jth col of J(tt,yy,yp) as delta(F)/delta(y_j). */
/* Set data address of jthCol, and save y_j and yp_j values. */
N_VSetArrayPointer(DENSE_COL(Jac,j), jthCol);
yj = y_data[j];
ypj = yp_data[j];
/* Set increment inc to y_j based on sqrt(uround)*abs(y_j), with
adjustments using yp_j and ewt_j if this is small, and a further
adjustment to give it the same sign as hh*yp_j. */
inc = SUNMAX( srur * SUNMAX( SUNRabs(yj), SUNRabs(hh*ypj) ) , ONE/ewt_data[j] );
if (hh*ypj < ZERO) inc = -inc;
inc = (yj + inc) - yj;
/* Adjust sign(inc) again if y_j has an inequality constraint. */
if (constraints != NULL) {
conj = cns_data[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 y_j and yp_j, call res, and break on error return. */
y_data[j] += inc;
yp_data[j] += c_j*inc;
retval = res(tt, yy, yp, rtemp, user_data);
nreDQ++;
if (retval != 0) break;
/* Construct difference quotient in jthCol */
inc_inv = ONE/inc;
N_VLinearSum(inc_inv, rtemp, -inc_inv, rr, jthCol);
DENSE_COL(Jac,j) = N_VGetArrayPointer(jthCol);
/* reset y_j, yp_j */
y_data[j] = yj;
yp_data[j] = ypj;
}
/* Restore original array pointer in tmp2 */
N_VSetArrayPointer(tmp2_data, tmp2);
return(retval);
}
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 i, j, i1, i2, width, ngroups, group;
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 = SUNRsqrt(uround);
width = mlower + mupper + 1;
ngroups = SUNMIN(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 = SUNMAX( srur * SUNMAX( SUNRabs(yj), SUNRabs(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 (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. */
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 = SUNMAX( srur * SUNMAX( SUNRabs(yj), SUNRabs(hh*ypj) ) , ONE/ewtj );
if (hh*ypj < ZERO) inc = -inc;
inc = (yj + inc) - yj;
if (constraints != NULL) {
conj = cns_data[j];
if (SUNRabs(conj) == ONE) {if((yj+inc)*conj < ZERO) inc = -inc;}
else if (SUNRabs(conj) == TWO) {if((yj+inc)*conj <= ZERO) inc = -inc;}
}
/* Load the difference quotient Jacobian elements for column 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*(rtemp_data[i]-r_data[i]);
}
}
return(retval);
}
