int FKINLapackBandJac(long int N, long int mupper, long int mlower,
N_Vector uu, N_Vector fval,
DlsMat J, void *user_data,
N_Vector vtemp1, N_Vector vtemp2)
{
realtype *uu_data, *fval_data, *jacdata, *v1_data, *v2_data;
long int eband;
int ier;
/* Initialize all pointers to NULL */
uu_data = fval_data = jacdata = v1_data = v2_data = NULL;
/* NOTE: The user-supplied routine should set ier to an
appropriate value, but we preset the value to zero
(meaning SUCCESS) so the user need only reset the
value if an error occurred */
ier = 0;
/* Get pointers to vector data */
uu_data = N_VGetArrayPointer(uu);
fval_data = N_VGetArrayPointer(fval);
v1_data = N_VGetArrayPointer(vtemp1);
v2_data = N_VGetArrayPointer(vtemp2);
eband = (J->s_mu) + mlower + 1;
jacdata = BAND_COL(J,0) - mupper;
/* Call user-supplied routine */
FK_BJAC(&N, &mupper, &mlower, &eband,
uu_data, fval_data,
jacdata,
v1_data, v2_data, &ier);
return(ier);
}
int FCVBandJac(long int N, long int mupper, long int mlower,
BandMat J, realtype t,
N_Vector y, N_Vector fy, void *jac_data,
N_Vector vtemp1, N_Vector vtemp2, N_Vector vtemp3)
{
int ier;
realtype *ydata, *fydata, *jacdata, *v1data, *v2data, *v3data;
realtype h;
long int eband;
FCVUserData CV_userdata;
CVodeGetLastStep(CV_cvodemem, &h);
ydata = N_VGetArrayPointer(y);
fydata = N_VGetArrayPointer(fy);
v1data = N_VGetArrayPointer(vtemp1);
v2data = N_VGetArrayPointer(vtemp2);
v3data = N_VGetArrayPointer(vtemp3);
eband = (J->smu) + mlower + 1;
jacdata = BAND_COL(J,0) - mupper;
CV_userdata = (FCVUserData) jac_data;
FCV_BJAC(&N, &mupper, &mlower, &eband, &t, ydata, fydata, jacdata, &h,
CV_userdata->ipar, CV_userdata->rpar, v1data, v2data, v3data, &ier);
return(ier);
}
void FCVBandJac(long int N, long int mupper, long int mlower,
BandMat J, realtype t,
N_Vector y, N_Vector fy, void *jac_data,
N_Vector vtemp1, N_Vector vtemp2, N_Vector vtemp3)
{
N_Vector ewt;
realtype *ydata, *fydata, *jacdata, *ewtdata, *v1data, *v2data, *v3data;
realtype h;
long int eband;
ewt = N_VClone(y);
CVodeGetErrWeights(CV_cvodemem, ewt);
CVodeGetLastStep(CV_cvodemem, &h);
ydata = N_VGetArrayPointer(y);
fydata = N_VGetArrayPointer(fy);
v1data = N_VGetArrayPointer(vtemp1);
v2data = N_VGetArrayPointer(vtemp2);
v3data = N_VGetArrayPointer(vtemp3);
ewtdata = N_VGetArrayPointer(ewt);
eband = (J->smu) + mlower + 1;
jacdata = BAND_COL(J,0) - mupper;
FCV_BJAC(&N, &mupper, &mlower, &eband,
&t, ydata, fydata, jacdata,
ewtdata, &h, v1data, v2data, v3data);
N_VDestroy(ewt);
}
static void PVBBDDQJac(integer Nlocal, integer mudq, integer mldq,
integer mukeep, integer mlkeep, real rely,
PVLocalFn gloc, PVCommFn cfn, BandMat J,
void *f_data, real t, N_Vector y,
N_Vector ewt, real h, real uround,
N_Vector gy, N_Vector gtemp, N_Vector ytemp)
{
real gnorm, minInc, inc, inc_inv;
integer group, i, j, width, ngroups, i1, i2;
real *y_data, *ewt_data, *gy_data, *gtemp_data, *ytemp_data, *col_j;
/* Obtain pointers to the data for all vectors */
y_data = N_VDATA(y);
ewt_data = N_VDATA(ewt);
gy_data = N_VDATA(gy);
gtemp_data = N_VDATA(gtemp);
ytemp_data = N_VDATA(ytemp);
/* Load ytemp with y = predicted solution vector */
N_VScale(ONE, y, ytemp);
/* Call cfn and gloc to get base value of g(t,y) */
cfn (Nlocal, t, y, f_data);
gloc(Nlocal, t, ytemp_data, gy_data, f_data);
/* 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(rely*ABS(y_data[j]), minInc/ewt_data[j]);
ytemp_data[j] += inc;
}
/* Evaluate g with incremented y */
gloc(Nlocal, t, ytemp_data, gtemp_data, f_data);
/* 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(J,j);
inc = MAX(rely*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]);
}
}
}
static void Jac2(long int N, long int mu, long int ml, BandMat J,
realtype tn, N_Vector y, N_Vector fy, void *jac_data,
N_Vector tmp1, N_Vector tmp2, N_Vector tmp3)
{
long int i, j, k;
realtype *kthCol;
/*
The components of f(t,y) which depend on y are
i,j
f , f , and f :
i,j i+1,j i,j+1
f = -2 y + alpha1 * y + alpha2 * y
i,j i,j i-1,j i,j-1
f = -2 y + alpha1 * y + alpha2 * y
i+1,j i+1,j i,j i+1,j-1
f = -2 y + alpha1 * y + alpha2 * y
i,j+1 i,j+1 i-1,j+1 i,j
*/
for (j=0; j < P2_MESHY; j++) {
for (i=0; i < P2_MESHX; i++) {
k = i + j * P2_MESHX;
kthCol = BAND_COL(J,k);
BAND_COL_ELEM(kthCol,k,k) = -TWO;
if (i != P2_MESHX-1) BAND_COL_ELEM(kthCol,k+1,k) = P2_ALPH1;
if (j != P2_MESHY-1) BAND_COL_ELEM(kthCol,k+P2_MESHX,k) = P2_ALPH2;
}
}
}
static void 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;
long int group, i, j, width, ngroups, i1, i2;
realtype *col_j, *ewt_data, *fy_data, *ftemp_data, *y_data, *ytemp_data;
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. */
f(t, ytemp, ftemp, f_data);
nfeBP++;
/* 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]);
}
}
}
int mtlb_IdaBandJac(long int Neq, long int mupper,
long int mlower, realtype tt,
N_Vector yy, N_Vector yp, N_Vector rr,
realtype c_j, void *jac_data, BandMat Jac,
N_Vector tmp1, N_Vector tmp2,
N_Vector tmp3)
{
double *J_data;
long int eband, i;
int ret;
mxArray *mx_in[8], *mx_out[3];
/* Inputs to the Matlab function */
mx_in[0] = mxCreateScalarDouble(1.0); /* type=1: forward ODE */
mx_in[1] = mxCreateScalarDouble(tt); /* current t */
mx_in[2] = mxCreateDoubleMatrix(N,1,mxREAL); /* current yy */
mx_in[3] = mxCreateDoubleMatrix(N,1,mxREAL); /* current yp */
mx_in[4] = mxCreateDoubleMatrix(N,1,mxREAL); /* current rr */
mx_in[5] = mxCreateScalarDouble(c_j); /* current c_j */
mx_in[6] = mx_JACfct; /* matlab function handle */
mx_in[7] = mx_data; /* matlab user data */
/* Call matlab wrapper */
GetData(yy, mxGetPr(mx_in[2]), N);
GetData(yp, mxGetPr(mx_in[3]), N);
GetData(rr, mxGetPr(mx_in[4]), N);
mexCallMATLAB(3,mx_out,8,mx_in,"idm_bjac");
/* Extract data */
eband = mupper + mlower + 1;
J_data = mxGetPr(mx_out[0]);
for (i=0; i<N; i++)
memcpy(BAND_COL(Jac,i) - mupper, J_data + i*eband, eband*sizeof(double));
ret = (int)*mxGetPr(mx_out[1]);
if (!mxIsEmpty(mx_out[2])) {
UpdateUserData(mx_out[2]);
}
/* Free temporary space */
mxDestroyArray(mx_in[0]);
mxDestroyArray(mx_in[1]);
mxDestroyArray(mx_in[2]);
mxDestroyArray(mx_in[3]);
mxDestroyArray(mx_in[4]);
mxDestroyArray(mx_in[5]);
mxDestroyArray(mx_out[0]);
mxDestroyArray(mx_out[1]);
mxDestroyArray(mx_out[2]);
return(ret);
}
int mxW_CVodeBandJacB(long int NeqB, long int mupperB, long int mlowerB, realtype t,
N_Vector y, N_Vector yB, N_Vector fyB,
DlsMat JB, void *user_dataB,
N_Vector tmp1B, N_Vector tmp2B, N_Vector tmp3B)
{
cvmPbData fwdPb, bckPb;
double *JB_data;
mxArray *mx_in[6], *mx_out[3];
long int ebandB, i;
int ret;
/* Extract global interface data from user-data */
bckPb = (cvmPbData) user_dataB;
fwdPb = bckPb->fwd;
/* Inputs to the Matlab function */
mx_in[0] = mxCreateDoubleScalar(t); /* current t */
mx_in[1] = mxCreateDoubleMatrix(N,1,mxREAL); /* current y */
mx_in[2] = mxCreateDoubleMatrix(NB,1,mxREAL); /* current yB */
mx_in[3] = mxCreateDoubleMatrix(NB,1,mxREAL); /* current fyB */
mx_in[4] = bckPb->JACfct; /* matlab function handle */
mx_in[5] = bckPb->mtlb_data; /* matlab user data */
/* Call matlab wrapper */
GetData(y, mxGetPr(mx_in[1]), N);
GetData(yB, mxGetPr(mx_in[2]), NB);
GetData(fyB, mxGetPr(mx_in[3]), NB);
mexCallMATLAB(3,mx_out,6,mx_in,"cvm_bjacB");
ebandB = mupperB + mlowerB + 1;
JB_data = mxGetPr(mx_out[0]);
for (i=0;i<NB;i++)
memcpy(BAND_COL(JB,i) - mupperB, JB_data + i*ebandB, ebandB*sizeof(double));
ret = (int)*mxGetPr(mx_out[1]);
if (!mxIsEmpty(mx_out[2])) {
UpdateUserData(mx_out[2], bckPb);
}
/* Free temporary space */
mxDestroyArray(mx_in[0]);
mxDestroyArray(mx_in[1]);
mxDestroyArray(mx_in[2]);
mxDestroyArray(mx_in[3]);
mxDestroyArray(mx_out[0]);
mxDestroyArray(mx_out[1]);
mxDestroyArray(mx_out[2]);
return(ret);
}
int mxW_CVodeBandJac(long int Neq, long int mupper, long int mlower, realtype t,
N_Vector y, N_Vector fy,
DlsMat J, void *user_data,
N_Vector tmp1, N_Vector tmp2, N_Vector tmp3)
{
cvmPbData fwdPb;
double *J_data;
long int eband, i;
int ret;
mxArray *mx_in[5], *mx_out[3];
/* Extract global interface data from user-data */
fwdPb = (cvmPbData) user_data;
/* Inputs to the Matlab function */
mx_in[0] = mxCreateDoubleScalar(t); /* current t */
mx_in[1] = mxCreateDoubleMatrix(N,1,mxREAL); /* current y */
mx_in[2] = mxCreateDoubleMatrix(N,1,mxREAL); /* current fy */
mx_in[3] = fwdPb->JACfct; /* matlab function handle */
mx_in[4] = fwdPb->mtlb_data; /* matlab user data */
/* Call matlab wrapper */
GetData(y, mxGetPr(mx_in[1]), N);
GetData(fy, mxGetPr(mx_in[2]), N);
mexCallMATLAB(3,mx_out,5,mx_in,"cvm_bjac");
/* Extract data */
eband = mupper + mlower + 1;
J_data = mxGetPr(mx_out[0]);
for (i=0;i<N;i++)
memcpy(BAND_COL(J,i) - mupper, J_data + i*eband, eband*sizeof(double));
ret = (int)*mxGetPr(mx_out[1]);
if (!mxIsEmpty(mx_out[2])) {
UpdateUserData(mx_out[2], fwdPb);
}
/* Free temporary space */
mxDestroyArray(mx_in[0]);
mxDestroyArray(mx_in[1]);
mxDestroyArray(mx_in[2]);
mxDestroyArray(mx_out[0]);
mxDestroyArray(mx_out[1]);
mxDestroyArray(mx_out[2]);
return(ret);
}
static int jac(long int N, long int mu, long int ml,
N_Vector u, N_Vector f,
DlsMat J, void *user_data,
N_Vector tmp1, N_Vector tmp2)
{
realtype dx, dy;
realtype hdc, vdc;
realtype *kthCol;
int i, j, k;
dx = ONE/(NX+1);
dy = ONE/(NY+1);
hdc = ONE/(dx*dx);
vdc = ONE/(dy*dy);
/*
The components of f(t,u) which depend on u_{i,j} are
f_{i,j}, f_{i-1,j}, f_{i+1,j}, f_{i,j+1}, and f_{i,j-1}.
Thus, a column of the Jacobian will contain an entry from
each of these equations exception the ones on the boundary.
f_{i,j} = hdc*(u_{i-1,j} -2u_{i,j} +u_{i+1,j}) + vdc*(u_{i,j-1} -2u_{i,j} +u_{i,j+1})
f_{i-1,j} = hdc*(u_{i-2,j} -2u_{i-1,j}+u_{i,j}) + vdc*(u_{i-1,j-1}-2u_{i-1,j}+u_{i-1,j+1})
f_{i+1,j} = hdc*(u_{i,j} -2u_{i+1,j}+u_{i+2,j}) + vdc*(u_{i+1,j-1}-2u_{i+1,j}+u_{i+1,j+1})
f_{i,j-1} = hdc*(u_{i-1,j-1}-2u_{i,j-1}+u_{i+1,j-1}) + vdc*(u_{i,j-2} -2u_{i,j-1}+u_{i,j})
f_{i,j+1} = hdc*(u_{i-1,j+1}-2u_{i,j+1}+u_{i+1,j+1}) + vdc*(u_{i,j} -2u_{i,j+1}+u_{i,j+2})
*/
for (j=0; j <= NY-1; j++) {
for (i=0; i <= NX-1; i++) {
/* Evaluate diffusion coefficients */
k = i + j*NX;
kthCol = BAND_COL(J, k);
BAND_COL_ELEM(kthCol,k,k) = -2.0*hdc - 2.0*vdc;
if ( i != (NX-1) ) BAND_COL_ELEM(kthCol,k+1,k) = hdc;
if ( i != 0 ) BAND_COL_ELEM(kthCol,k-1,k) = hdc;
if ( j != (NY-1) ) BAND_COL_ELEM(kthCol,k+NX,k) = vdc;
if ( j != 0 ) BAND_COL_ELEM(kthCol,k-NX,k) = vdc;
}
}
return(0);
}
int FIDALapackBandJac(long int N, long int mupper, long int mlower,
realtype t, realtype c_j,
N_Vector yy, N_Vector yp, N_Vector rr,
DlsMat J, void *user_data,
N_Vector vtemp1, N_Vector vtemp2, N_Vector vtemp3)
{
realtype *yy_data, *yp_data, *rr_data, *jacdata, *ewtdata, *v1data, *v2data, *v3data;
realtype h;
long int eband;
int ier;
FIDAUserData IDA_userdata;
/* Initialize all pointers to NULL */
yy_data = yp_data = rr_data = jacdata = ewtdata = NULL;
v1data = v2data = v3data = NULL;
/* NOTE: The user-supplied routine should set ier to an
appropriate value, but we preset the value to zero
(meaning SUCCESS) so the user need only reset the
value if an error occurred */
ier = 0;
IDAGetErrWeights(IDA_idamem, F2C_IDA_ewtvec);
IDAGetLastStep(IDA_idamem, &h);
/* Get pointers to vector data */
yy_data = N_VGetArrayPointer(yy);
yp_data = N_VGetArrayPointer(yp);
rr_data = N_VGetArrayPointer(rr);
ewtdata = N_VGetArrayPointer(F2C_IDA_ewtvec);
v1data = N_VGetArrayPointer(vtemp1);
v2data = N_VGetArrayPointer(vtemp2);
v3data = N_VGetArrayPointer(vtemp3);
eband = (J->s_mu) + mlower + 1;
jacdata = BAND_COL(J,0) - mupper;
IDA_userdata = (FIDAUserData) user_data;
/* Call user-supplied routine */
FIDA_BJAC(&N, &mupper, &mlower, &eband, &t, yy_data, yp_data, rr_data,
&c_j, jacdata, ewtdata, &h,
IDA_userdata->ipar, IDA_userdata->rpar,
v1data, v2data, v3data, &ier);
return(ier);
}
int mxW_KINBandJac(int Neq, int mupper, int mlower,
N_Vector y, N_Vector fy,
DlsMat J, void *user_data,
N_Vector tmp1, N_Vector tmp2)
{
kimInterfaceData kimData;
double *J_data;
mxArray *mx_in[4], *mx_out[3];
int eband, i, ret;
/* Extract global interface data from user-data */
kimData = (kimInterfaceData) user_data;
/* Inputs to the Matlab function */
mx_in[0] = mxCreateDoubleMatrix(N,1,mxREAL); /* current y */
mx_in[1] = mxCreateDoubleMatrix(N,1,mxREAL); /* current fy */
mx_in[2] = kimData->JACfct; /* matlab function handle */
mx_in[3] = kimData->mtlb_data; /* matlab user data */
/* Call matlab wrapper */
GetData(y, mxGetPr(mx_in[0]), N);
GetData(fy, mxGetPr(mx_in[1]), N);
mexCallMATLAB(3,mx_out,4,mx_in,"kim_bjac");
eband = mupper + mlower + 1;
J_data = mxGetPr(mx_out[0]);
for (i=0;i<N;i++) memcpy(BAND_COL(J,i) - mupper, J_data + i*eband, eband*sizeof(double));
ret = (int)*mxGetPr(mx_out[1]);
if (!mxIsEmpty(mx_out[2])) {
UpdateUserData(mx_out[2], kimData);
}
/* Free temporary space */
mxDestroyArray(mx_in[0]);
mxDestroyArray(mx_in[1]);
mxDestroyArray(mx_out[0]);
mxDestroyArray(mx_out[1]);
mxDestroyArray(mx_out[2]);
return(ret);
}
static int Jac(long int N, long int mu, long int ml,
realtype t, N_Vector u, N_Vector fu,
DlsMat J, void *user_data,
N_Vector tmp1, N_Vector tmp2, N_Vector tmp3)
{
int i, j, k;
realtype *kthCol, hordc, horac, verdc;
UserData data;
/*
* The components of f = udot that depend on u(i,j) are
* f(i,j), f(i-1,j), f(i+1,j), f(i,j-1), f(i,j+1), with
* df(i,j)/du(i,j) = -2 (1/dx^2 + 1/dy^2)
* df(i-1,j)/du(i,j) = 1/dx^2 + .25/dx (if i > 1)
* df(i+1,j)/du(i,j) = 1/dx^2 - .25/dx (if i < MX)
* df(i,j-1)/du(i,j) = 1/dy^2 (if j > 1)
* df(i,j+1)/du(i,j) = 1/dy^2 (if j < MY)
*/
data = (UserData) user_data;
hordc = data->hdcoef;
horac = data->hacoef;
verdc = data->vdcoef;
/* set non-zero Jacobian entries */
for (j=1; j <= MY; j++) {
for (i=1; i <= MX; i++) {
k = j-1 + (i-1)*MY;
kthCol = BAND_COL(J,k);
/* set the kth column of J */
BAND_COL_ELEM(kthCol,k,k) = -TWO*(verdc+hordc);
if (i != 1) BAND_COL_ELEM(kthCol,k-MY,k) = hordc + horac;
if (i != MX) BAND_COL_ELEM(kthCol,k+MY,k) = hordc - horac;
if (j != 1) BAND_COL_ELEM(kthCol,k-1,k) = verdc;
if (j != MY) BAND_COL_ELEM(kthCol,k+1,k) = verdc;
}
}
return(0);
}
void KernelBand<NLSSystemObject>::CalculatesNormOfJacobianRows(Eigen::VectorXd& row_norms)
{
row_norms.setZero();
for (int group = 1; group <= ngroups_; group++)
{
for (int j = group - 1; j < static_cast<int>(this->ne_); j += width_)
{
double* col_j = BAND_COL(J_, j);
int i1 = std::max(0, j - J_->nUpper());
int i2 = std::min(j + J_->nLower(), static_cast<int>(this->ne_ - 1));
for (int i = i1; i <= i2; i++)
{
const double J = BAND_COL_ELEM(col_j, i, j);
row_norms(i) += J*J;
}
}
}
for (unsigned int i = 0; i < this->ne_; i++)
row_norms(i) = std::sqrt(row_norms(i));
}
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);
}
int kinDlsBandDQJac(long int N, long int mupper, long int mlower,
N_Vector u, N_Vector fu,
DlsMat Jac, void *data,
N_Vector tmp1, N_Vector tmp2)
{
realtype inc, inc_inv;
N_Vector futemp, utemp;
int retval;
long int group, i, j, width, ngroups, i1, i2;
realtype *col_j, *fu_data, *futemp_data, *u_data, *utemp_data, *uscale_data;
KINMem kin_mem;
KINDlsMem kindls_mem;
/* data points to kinmem */
kin_mem = (KINMem) data;
kindls_mem = (KINDlsMem) lmem;
/* Rename work vectors for use as temporary values of u and fu */
futemp = tmp1;
utemp = tmp2;
/* Obtain pointers to the data for ewt, fy, futemp, y, ytemp */
fu_data = N_VGetArrayPointer(fu);
futemp_data = N_VGetArrayPointer(futemp);
u_data = N_VGetArrayPointer(u);
uscale_data = N_VGetArrayPointer(uscale);
utemp_data = N_VGetArrayPointer(utemp);
/* Load utemp with u */
N_VScale(ONE, u, utemp);
/* 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 utemp components in group */
for (j = group - 1; j < N; j += width)
{
inc = sqrt_relfunc * MAX(ABS(u_data[j]), ABS(uscale_data[j]));
utemp_data[j] += inc;
}
/* Evaluate f with incremented u */
retval = func(utemp, futemp, user_data);
if (retval != 0)
{
return(-1);
}
/* Restore utemp components, then form and load difference quotients */
for (j = group - 1; j < N; j += width)
{
utemp_data[j] = u_data[j];
col_j = BAND_COL(Jac, j);
inc = sqrt_relfunc * MAX(ABS(u_data[j]), ABS(uscale_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 * (futemp_data[i] - fu_data[i]);
}
}
}
/* Increment counter nfeDQ */
nfeDQ += ngroups;
return(0);
}
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 = 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);
}
static int cpBBDDQJacImpl(CPBBDPrecData pdata, realtype t, realtype gamma,
N_Vector y, N_Vector yp, N_Vector gref,
N_Vector ytemp, N_Vector yptemp, N_Vector gtemp)
{
CPodeMem cp_mem;
realtype inc, inc_inv;
int retval;
int group, i, j, width, ngroups, i1, i2;
realtype *ydata, *ypdata, *ytempdata, *yptempdata, *grefdata, *gtempdata;
realtype *ewtdata;
realtype *col_j, yj, ypj, ewtj;
cp_mem = (CPodeMem) pdata->cpode_mem;
/* Initialize ytemp and yptemp. */
N_VScale(ONE, y, ytemp);
N_VScale(ONE, yp, yptemp);
/* Obtain pointers as required to the data array of vectors. */
ydata = N_VGetArrayPointer(y);
ypdata = N_VGetArrayPointer(yp);
gtempdata = N_VGetArrayPointer(gtemp);
ewtdata = N_VGetArrayPointer(ewt);
ytempdata = N_VGetArrayPointer(ytemp);
yptempdata= N_VGetArrayPointer(yptemp);
grefdata = N_VGetArrayPointer(gref);
/* Call cfn and glocI to get base value of G(t,y,y'). */
if (cfn != NULL) {
retval = cfn(Nlocal, t, y, yp, f_data);
if (retval != 0) return(retval);
}
retval = glocI(Nlocal, t, y, yp, gref, f_data);
nge++;
if (retval != 0) return(retval);
/* 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++) {
/* Loop over the components in this group. */
for(j = group-1; j < Nlocal; 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 = dqrely*MAX(ABS(yj), MAX( ABS(h*ypj), ONE/ewtj));
if (h*ypj < ZERO) inc = -inc;
inc = (yj + inc) - yj;
/* Increment yj and ypj. */
ytempdata[j] += gamma*inc;
yptempdata[j] += inc;
}
/* Evaluate G with incremented y and yp arguments. */
retval = glocI(Nlocal, t, ytemp, yptemp, gtemp, f_data);
nge++;
if (retval != 0) return(retval);
/* Loop over components of the group again; restore ytemp and yptemp. */
for(j = group-1; j < Nlocal; j += width) {
yj = ytempdata[j] = ydata[j];
ypj = yptempdata[j] = ypdata[j];
ewtj = ewtdata[j];
/* Set increment inc as before .*/
inc = dqrely*MAX(ABS(yj), MAX( ABS(h*ypj), ONE/ewtj));
if (h*ypj < ZERO) inc = -inc;
inc = (yj + inc) - yj;
/* Form difference quotients and load into savedP. */
inc_inv = ONE/inc;
col_j = BAND_COL(savedP,j);
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 * (gtempdata[i] - grefdata[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);
}
int mtlb_IdaBandJacB(long int NeqB,
long int mupperB, long int mlowerB,
realtype tt,
N_Vector yy, N_Vector yp,
N_Vector yyB, N_Vector ypB, N_Vector rrB,
realtype c_jB, void *jac_dataB,
BandMat JacB,
N_Vector tmp1B, N_Vector tmp2B,
N_Vector tmp3B)
{
double *JB_data;
long int ebandB, i;
mxArray *mx_in[10], *mx_out[3];
int ret;
/* Inputs to the Matlab function */
mx_in[0] = mxCreateScalarDouble(-1.0); /* type=-1: backward ODE */
mx_in[1] = mxCreateScalarDouble(tt); /* current t */
mx_in[2] = mxCreateDoubleMatrix(N,1,mxREAL); /* current yy */
mx_in[3] = mxCreateDoubleMatrix(N,1,mxREAL); /* current yp */
mx_in[4] = mxCreateDoubleMatrix(NB,1,mxREAL); /* current yyB */
mx_in[5] = mxCreateDoubleMatrix(NB,1,mxREAL); /* current ypB */
mx_in[6] = mxCreateDoubleMatrix(NB,1,mxREAL); /* current rrB */
mx_in[7] = mxCreateScalarDouble(c_jB); /* current c_jB */
mx_in[8] = mx_JACfctB; /* matlab function handle */
mx_in[9] = mx_data; /* matlab user data */
/* Call matlab wrapper */
GetData(yy, mxGetPr(mx_in[2]), N);
GetData(yp, mxGetPr(mx_in[3]), N);
GetData(yyB, mxGetPr(mx_in[4]), NB);
GetData(ypB, mxGetPr(mx_in[5]), NB);
GetData(rrB, mxGetPr(mx_in[6]), NB);
mexCallMATLAB(3,mx_out,10,mx_in,"idm_bjac");
ebandB = mupperB + mlowerB + 1;
JB_data = mxGetPr(mx_out[0]);
for (i=0; i<NB; i++)
memcpy(BAND_COL(JacB,i) - mupperB, JB_data + i*ebandB, ebandB*sizeof(double));
ret = (int)*mxGetPr(mx_out[1]);
if (!mxIsEmpty(mx_out[2])) {
UpdateUserData(mx_out[2]);
}
/* Free temporary space */
mxDestroyArray(mx_in[0]);
mxDestroyArray(mx_in[1]);
mxDestroyArray(mx_in[2]);
mxDestroyArray(mx_in[3]);
mxDestroyArray(mx_in[4]);
mxDestroyArray(mx_in[5]);
mxDestroyArray(mx_in[6]);
mxDestroyArray(mx_in[7]);
mxDestroyArray(mx_out[0]);
mxDestroyArray(mx_out[1]);
mxDestroyArray(mx_out[2]);
return(ret);
}
void KernelBand<NLSSystemObject>::NumericalJacobian(const Eigen::VectorXd& x, const Eigen::VectorXd& f, Eigen::VectorXd& x_dimensions, const bool max_constraints, const Eigen::VectorXd& xMax)
{
if (pre_processing_ == false)
PreProcessing();
const double tstart = OpenSMOKE::OpenSMOKEGetCpuTime();
const double ZERO_DER = 1.e-8;
const double ETA2 = std::sqrt(OpenSMOKE::OPENSMOKE_MACH_EPS_DOUBLE);
// Save the original vector
x_plus_ = x;
// Loop
for (int group = 1; group <= ngroups_; group++)
{
if (max_constraints == false)
{
for (int j = group - 1; j < static_cast<int>(this->ne_); j += width_)
{
const double xh = std::fabs(x(j));
const double xdh = std::fabs(x_dimensions(j));
hJ_(j) = ETA2*std::max(xh, xdh);
hJ_(j) = std::max(hJ_(j), ZERO_DER);
hJ_(j) = std::min(hJ_(j), 0.001 + 0.001*std::fabs(xh));
x_plus_(j) += hJ_(j);
}
}
else
{
for (int j = group - 1; j < static_cast<int>(this->ne_); j += width_)
{
const double xh = std::fabs(x(j));
const double xdh = std::fabs(x_dimensions(j));
hJ_(j) = ETA2*std::max(xh, xdh);
hJ_(j) = std::max(hJ_(j), ZERO_DER);
hJ_(j) = std::min(hJ_(j), 0.001 + 0.001*std::fabs(xh));
if (xh + hJ_(j) > xMax(j))
hJ_(j) = -hJ_(j);
x_plus_(j) += hJ_(j);
}
}
this->Equations(x_plus_, f_plus_);
for (int j = group - 1; j < static_cast<int>(this->ne_); j += width_)
{
x_plus_(j) = x(j);
double* col_j = BAND_COL(J_, j);
int i1 = std::max(0, j - J_->nUpper());
int i2 = std::min(j + J_->nLower(), static_cast<int>(this->ne_ - 1));
for (int i = i1; i <= i2; i++)
BAND_COL_ELEM(col_j, i, j) = (f_plus_(i) - f(i)) / hJ_(j);
}
}
const double tend = OpenSMOKE::OpenSMOKEGetCpuTime();
numberOfSystemCallsForJacobian_ += this->ngroups_;
numberOfJacobianFullAssembling_++;
cpuTimeSingleJacobianFullAssembling_ = tend - tstart;
cpuTimeJacobianFullAssembling_ += cpuTimeSingleJacobianFullAssembling_;
}
void KernelBand<NLSSystemObject>::QuasiNewton(const Eigen::VectorXd& dxi, const Eigen::VectorXd& dfi)
{
const double tstart = OpenSMOKE::OpenSMOKEGetCpuTime();
{
// The auxiliary vector named x_plus is used here
Eigen::VectorXd* normSquared = &x_plus_;
normSquared->setZero();
for (int group = 1; group <= ngroups_; group++)
{
for (int j = group - 1; j < static_cast<int>(this->ne_); j += width_)
{
int i1 = std::max(0, j - J_->nUpper());
int i2 = std::min(j + J_->nLower(), static_cast<int>(this->ne_ - 1));
for (int i = i1; i <= i2; i++)
(*normSquared)(i) += dxi(j)*dxi(j);
}
}
// The auxiliary vector named x_plus is used here
Eigen::VectorXd* sum_vector = &f_plus_;
(*sum_vector) = dfi;
for (int group = 1; group <= ngroups_; group++)
{
for (int j = group - 1; j < static_cast<int>(this->ne_); j += width_)
{
double* col_j = BAND_COL(J_, j);
int i1 = std::max(0, j - J_->nUpper());
int i2 = std::min(j + J_->nLower(), static_cast<int>(this->ne_ - 1));
for (int i = i1; i <= i2; i++)
(*sum_vector)(i) -= BAND_COL_ELEM(col_j, i, j)*dxi(j);
}
}
for (int group = 1; group <= ngroups_; group++)
{
for (int j = group - 1; j < static_cast<int>(this->ne_); j += width_)
{
double* col_j = BAND_COL(J_, j);
int i1 = std::max(0, j - J_->nUpper());
int i2 = std::min(j + J_->nLower(), static_cast<int>(this->ne_ - 1));
}
}
const double eps = 1.e-10;
for (int j = 0; j < static_cast<int>(this->ne_); j++)
(*sum_vector)(j) /= ((*normSquared)(j) + eps);
for (int group = 1; group <= ngroups_; group++)
{
for (int j = group - 1; j < static_cast<int>(this->ne_); j += width_)
{
double* col_j = BAND_COL(J_, j);
int i1 = std::max(0, j - J_->nUpper());
int i2 = std::min(j + J_->nLower(), static_cast<int>(this->ne_ - 1));
for (int i = i1; i <= i2; i++)
BAND_COL_ELEM(col_j, i, j) += (*sum_vector)(i)*dxi(j);
}
}
}
const double tend = OpenSMOKE::OpenSMOKEGetCpuTime();
numberOfJacobianQuasiAssembling_++;
cpuTimeSingleJacobianQuasiAssembling_ = tend - tstart;
cpuTimeJacobianQuasiAssembling_ += cpuTimeSingleJacobianQuasiAssembling_;
}
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;
long int 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(ewt);
if (constraints != NULL)
cnsdata = N_VGetArrayPointer(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 (gcomm != NULL) {
retval = gcomm(Nlocal, tt, yy, yp, res_data);
if (retval != 0) return(retval);
}
retval = glocal(Nlocal, tt, yy, yp, gref, res_data);
nge++;
if (retval != 0) return(retval);
/* 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++) {
/* Loop over the components in this group. */
for(j = group-1; j < Nlocal; 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 = rel_yy*MAX(ABS(yj), MAX( 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 = cnsdata[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. */
ytempdata[j] += inc;
yptempdata[j] += cj*inc;
}
/* Evaluate G with incremented y and yp arguments. */
retval = glocal(Nlocal, tt, ytemp, yptemp, gtemp, res_data);
nge++;
if (retval != 0) return(retval);
/* Loop over components of the group again; restore ytemp and yptemp. */
for(j = group-1; j < Nlocal; j += width) {
yj = ytempdata[j] = ydata[j];
ypj = yptempdata[j] = ypdata[j];
ewtj = ewtdata[j];
/* Set increment inc as before .*/
inc = rel_yy*MAX(ABS(yj), MAX( ABS(hh*ypj), ONE/ewtj));
if (hh*ypj < ZERO) inc = -inc;
inc = (yj + inc) - yj;
if (constraints != NULL) {
conj = cnsdata[j];
if (ABS(conj) == ONE) {if ((yj+inc)*conj < ZERO) inc = -inc;}
else if (ABS(conj) == TWO) {if ((yj+inc)*conj <= ZERO) inc = -inc;}
}
/* Form difference quotients and load into PP. */
inc_inv = ONE/inc;
col_j = BAND_COL(PP,j);
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 * (gtempdata[i] - grefdata[i]);
}
}
return(0);
}
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 = 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);
/* 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 = MAX(srur*ABS(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 = 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(retval);
}
static void 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;
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)
cfn (Nlocal, t, y, f_data);
gloc(Nlocal, t, ytemp, gy, f_data);
/* 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 */
gloc(Nlocal, t, ytemp, gtemp, f_data);
/* 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]);
}
}
}
int cpDlsBandDQJacImpl(int N, int mupper, int mlower,
realtype t, realtype gm,
N_Vector y, N_Vector yp, N_Vector r,
DlsMat Jac, void *jac_data,
N_Vector tmp1, N_Vector tmp2, N_Vector tmp3)
{
N_Vector ftemp, ytemp, yptemp;
realtype inc, inc_inv, yj, ypj, srur, ewtj;
realtype *y_data, *yp_data, *ewt_data;
realtype *ytemp_data, *yptemp_data, *ftemp_data, *r_data, *col_j;
int i, j, i1, i2, width, group, ngroups;
int retval = 0;
CPodeMem cp_mem;
CPDlsMem cpdls_mem;
/* jac_data points to cpode_mem */
cp_mem = (CPodeMem) jac_data;
cpdls_mem = (CPDlsMem) lmem;
ftemp = 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 vectors used. */
ewt_data = N_VGetArrayPointer(ewt);
r_data = N_VGetArrayPointer(r);
y_data = N_VGetArrayPointer(y);
yp_data = N_VGetArrayPointer(yp);
ftemp_data = N_VGetArrayPointer(ftemp);
ytemp_data = N_VGetArrayPointer(ytemp);
yptemp_data = N_VGetArrayPointer(yptemp);
/* Initialize ytemp and yptemp. */
N_VScale(ONE, y, 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 y[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 h*ypj. */
inc = MAX( srur * MAX( ABS(yj), ABS(h*ypj) ) , ONE/ewtj );
if (h*ypj < ZERO) inc = -inc;
inc = (yj + inc) - yj;
/* Increment yj and ypj. */
ytemp_data[j] += gamma*inc;
yptemp_data[j] += inc;
}
/* Call ODE fct. with incremented arguments. */
retval = fi(tn, ytemp, yptemp, ftemp, f_data);
nfeDQ++;
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(h*ypj) ) , ONE/ewtj );
if (h*ypj < ZERO) inc = -inc;
inc = (yj + inc) - yj;
/* 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*(ftemp_data[i]-r_data[i]);
}
}
return(retval);
}
