static void CVDenseDQJac(long int N, DenseMat 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, yjsaved, srur;
realtype *tmp2_data, *y_data, *ewt_data;
N_Vector ftemp, jthCol;
long int j;
CVodeMem cv_mem;
CVDenseMem cvdense_mem;
/* jac_data points to cvode_mem */
cv_mem = (CVodeMem) jac_data;
cvdense_mem = (CVDenseMem) lmem;
/* Save pointer to the array in tmp2 */
tmp2_data = N_VGetArrayPointer(tmp2);
/* Rename work vectors for readibility */
ftemp = tmp1;
jthCol = tmp2;
/* Obtain pointers to the data for ewt, y */
ewt_data = N_VGetArrayPointer(ewt);
y_data = N_VGetArrayPointer(y);
/* Set minimum increment based on uround and norm of f */
srur = RSqrt(uround);
fnorm = N_VWrmsNorm(fy, ewt);
minInc = (fnorm != ZERO) ?
(MIN_INC_MULT * ABS(h) * uround * N * fnorm) : ONE;
/* This is the only for loop for 0..N-1 in CVODE */
for (j = 0; j < N; j++) {
/* Generate the jth col of J(tn,y) */
N_VSetArrayPointer(DENSE_COL(J,j), jthCol);
yjsaved = y_data[j];
inc = MAX(srur*ABS(yjsaved), minInc/ewt_data[j]);
y_data[j] += inc;
f(tn, y, ftemp, f_data);
y_data[j] = yjsaved;
inc_inv = ONE/inc;
N_VLinearSum(inc_inv, ftemp, -inc_inv, fy, jthCol);
DENSE_COL(J,j) = N_VGetArrayPointer(jthCol);
}
/* Restore original array pointer in tmp2 */
N_VSetArrayPointer(tmp2_data, tmp2);
/* Increment counter nfeD */
nfeD += N;
}
int FKINDenseJac(long int N, 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;
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);
jacdata = DENSE_COL(J,0);
/* Call user-supplied routine */
FK_DJAC(&N, uu_data, fval_data, jacdata, v1_data, v2_data, &ier);
return(ier);
}
static int KINDenseDQJac(long int n, DenseMat J,
N_Vector u, N_Vector fu, void *jac_data,
N_Vector tmp1, N_Vector tmp2)
{
realtype inc, inc_inv, ujsaved, ujscale, sign;
realtype *tmp2_data, *u_data, *uscale_data;
N_Vector ftemp, jthCol;
long int j;
int retval;
KINMem kin_mem;
KINDenseMem kindense_mem;
/* jac_data points to kin_mem */
kin_mem = (KINMem) jac_data;
kindense_mem = (KINDenseMem) lmem;
/* Save pointer to the array in tmp2 */
tmp2_data = N_VGetArrayPointer(tmp2);
/* Rename work vectors for readibility */
ftemp = tmp1;
jthCol = tmp2;
/* Obtain pointers to the data for u and uscale */
u_data = N_VGetArrayPointer(u);
uscale_data = N_VGetArrayPointer(uscale);
/* This is the only for loop for 0..N-1 in KINSOL */
for (j = 0; j < n; j++) {
/* Generate the jth col of J(u) */
N_VSetArrayPointer(DENSE_COL(J,j), jthCol);
ujsaved = u_data[j];
ujscale = ONE/uscale_data[j];
sign = (ujsaved >= ZERO) ? ONE : -ONE;
inc = sqrt_relfunc*MAX(ABS(ujsaved), ujscale)*sign;
u_data[j] += inc;
retval = func(u, ftemp, f_data);
if (retval != 0) return(-1);
u_data[j] = ujsaved;
inc_inv = ONE/inc;
N_VLinearSum(inc_inv, ftemp, -inc_inv, fu, jthCol);
}
/* Restore original array pointer in tmp2 */
N_VSetArrayPointer(tmp2_data, tmp2);
/* Increment counter nfeD */
nfeD += n;
return(0);
}
int FCVDenseJac(int N, realtype t,
N_Vector y, N_Vector fy,
DlsMat J, void *user_data,
N_Vector vtemp1, N_Vector vtemp2, N_Vector vtemp3)
{
int ier;
realtype *ydata, *fydata, *jacdata, *v1data, *v2data, *v3data;
realtype h;
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);
jacdata = DENSE_COL(J,0);
CV_userdata = (FCVUserData) user_data;
FCV_DJAC(&N, &t, ydata, fydata, jacdata, &h,
CV_userdata->ipar, CV_userdata->rpar, v1data, v2data, v3data, &ier);
return(ier);
}
void FCVDenseJac(long int N, DenseMat 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;
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);
jacdata = DENSE_COL(J,0);
FCV_DJAC(&N, &t, ydata, fydata, jacdata,
ewtdata, &h, v1data, v2data, v3data);
N_VDestroy(ewt);
}
int mtlb_IdaDenseJacB(long int NeqB, realtype tt,
N_Vector yy, N_Vector yp,
N_Vector yyB, N_Vector ypB, N_Vector rrB,
realtype c_jB, void *jac_dataB,
DenseMat JacB,
N_Vector tmp1B, N_Vector tmp2B,
N_Vector tmp3B)
{
double *JB_data;
long int 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_djac");
JB_data = mxGetPr(mx_out[0]);
for (i=0; i<NB; i++)
memcpy(DENSE_COL(JacB,i), JB_data + i*NB, NB*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);
}
int mtlb_IdaDenseJac(long int Neq, realtype tt,
N_Vector yy, N_Vector yp, N_Vector rr,
realtype c_j, void *jac_data,
DenseMat Jac,
N_Vector tmp1, N_Vector tmp2,
N_Vector tmp3)
{
double *J_data;
long int 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_djac");
/* Extract data */
J_data = mxGetPr(mx_out[0]);
for (i=0; i<N; i++)
memcpy(DENSE_COL(Jac,i), J_data + i*N, N*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_CVodeDenseJacB(long int NeqB, 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];
int i, 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_djacB");
JB_data = mxGetPr(mx_out[0]);
for (i=0;i<NB;i++)
memcpy(DENSE_COL(JB,i), JB_data + i*NB, NB*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);
}
static void
CVDenseDQJac(integertype N, DenseMat J, RhsFn f, void *f_data,
realtype tn, N_Vector y, N_Vector fy, N_Vector ewt,
realtype h, realtype uround, void *jac_data,
long int *nfePtr, N_Vector vtemp1,
N_Vector vtemp2, N_Vector vtemp3)
{
realtype fnorm, minInc, inc, inc_inv, yjsaved, srur;
realtype *y_data, *ewt_data;
N_Vector ftemp, jthCol;
M_Env machEnv;
integertype j;
machEnv = y->menv; /* Get machine environment */
ftemp = vtemp1; /* Rename work vector for use as f vector value */
/* Obtain pointers to the data for ewt, y */
ewt_data = N_VGetData(ewt);
y_data = N_VGetData(y);
/* Set minimum increment based on uround and norm of f */
srur = RSqrt(uround);
fnorm = N_VWrmsNorm(fy, ewt);
minInc = (fnorm != ZERO) ?
(MIN_INC_MULT * ABS(h) * uround * N * fnorm) : ONE;
jthCol = N_VMake(N, y_data, machEnv); /* j loop overwrites this data address */
/* This is the only for loop for 0..N-1 in CVODE */
for (j = 0; j < N; j++)
{
/* Generate the jth col of J(tn,y) */
N_VSetData(DENSE_COL(J, j), jthCol);
yjsaved = y_data[j];
inc = MAX(srur * ABS(yjsaved), minInc / ewt_data[j]);
y_data[j] += inc;
f(N, tn, y, ftemp, f_data);
inc_inv = ONE / inc;
N_VLinearSum(inc_inv, ftemp, -inc_inv, fy, jthCol);
y_data[j] = yjsaved;
}
N_VDispose(jthCol);
/* Increment counter nfe = *nfePtr */
*nfePtr += N;
}
int mxW_CVodeDenseJac(long int Neq, 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 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_djac");
/* Extract data */
J_data = mxGetPr(mx_out[0]);
for (i=0;i<N;i++)
memcpy(DENSE_COL(J,i), J_data + i*N, N*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);
}
/* C interface to user-supplied Fortran routine FARKDMASS; see
farkode.h for additional information */
int FARKLapackDenseMass(long int N, realtype t, DlsMat M,
void *user_data, N_Vector vtemp1,
N_Vector vtemp2, N_Vector vtemp3)
{
int ier;
realtype *massdata, *v1data, *v2data, *v3data;
FARKUserData ARK_userdata;
v1data = N_VGetArrayPointer(vtemp1);
v2data = N_VGetArrayPointer(vtemp2);
v3data = N_VGetArrayPointer(vtemp3);
massdata = DENSE_COL(M,0);
ARK_userdata = (FARKUserData) user_data;
FARK_DMASS(&N, &t, massdata, ARK_userdata->ipar, ARK_userdata->rpar,
v1data, v2data, v3data, &ier);
return(ier);
}
int mxW_KINDenseJac(long int Neq,
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 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_djac");
J_data = mxGetPr(mx_out[0]);
for (i=0;i<N;i++) memcpy(DENSE_COL(J,i), J_data + i*N, N*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);
}
/* The C function FARKLapackDenseJac interfaces between ARKODE
and a Fortran subroutine FARKDJAC for solution of a linear
system using Lapack with dense Jacobian approximation.
Addresses of arguments are passed to FARKDJAC, using the macro
DENSE_COL and the routine N_VGetArrayPointer from NVECTOR */
int FARKLapackDenseJac(long int N, realtype t, N_Vector y,
N_Vector fy, DlsMat J, void *user_data,
N_Vector vtemp1, N_Vector vtemp2,
N_Vector vtemp3)
{
int ier;
realtype *ydata, *fydata, *jacdata, *v1data, *v2data, *v3data;
realtype h;
FARKUserData ARK_userdata;
ARKodeGetLastStep(ARK_arkodemem, &h);
ydata = N_VGetArrayPointer(y);
fydata = N_VGetArrayPointer(fy);
v1data = N_VGetArrayPointer(vtemp1);
v2data = N_VGetArrayPointer(vtemp2);
v3data = N_VGetArrayPointer(vtemp3);
jacdata = DENSE_COL(J,0);
ARK_userdata = (FARKUserData) user_data;
FARK_DJAC(&N, &t, ydata, fydata, jacdata, &h, ARK_userdata->ipar,
ARK_userdata->rpar, v1data, v2data, v3data, &ier);
return(ier);
}
int cvDlsDenseDQJac(long int N, realtype t,
N_Vector y, N_Vector fy,
DlsMat Jac, void *data,
N_Vector tmp1, N_Vector tmp2, N_Vector tmp3)
{
realtype fnorm, minInc, inc, inc_inv, yjsaved, srur;
realtype *tmp2_data, *y_data, *ewt_data;
N_Vector ftemp, jthCol;
long int j;
int retval = 0;
CVodeMem cv_mem;
CVDlsMem cvdls_mem;
/* data points to cvode_mem */
cv_mem = (CVodeMem) data;
cvdls_mem = (CVDlsMem) lmem;
/* Save pointer to the array in tmp2 */
tmp2_data = N_VGetArrayPointer(tmp2);
/* Rename work vectors for readibility */
ftemp = tmp1;
jthCol = tmp2;
/* Obtain pointers to the data for ewt, y */
ewt_data = N_VGetArrayPointer(ewt);
y_data = N_VGetArrayPointer(y);
/* Set minimum increment based on uround and norm of f */
srur = RSqrt(uround);
fnorm = N_VWrmsNorm(fy, ewt);
minInc = (fnorm != ZERO) ?
(MIN_INC_MULT * ABS(h) * uround * N * fnorm) : ONE;
for (j = 0; j < N; j++) {
/* Generate the jth col of J(tn,y) */
N_VSetArrayPointer(DENSE_COL(Jac,j), jthCol);
yjsaved = y_data[j];
inc = MAX(srur*ABS(yjsaved), minInc/ewt_data[j]);
y_data[j] += inc;
retval = f(t, y, ftemp, user_data);
nfeDQ++;
if (retval != 0) break;
y_data[j] = yjsaved;
inc_inv = ONE/inc;
N_VLinearSum(inc_inv, ftemp, -inc_inv, fy, jthCol);
DENSE_COL(Jac,j) = N_VGetArrayPointer(jthCol);
}
/* Restore original array pointer in tmp2 */
N_VSetArrayPointer(tmp2_data, tmp2);
return(retval);
}
int kinDlsDenseDQJac(long int N,
N_Vector u, N_Vector fu,
DlsMat Jac, void *data,
N_Vector tmp1, N_Vector tmp2)
{
realtype inc, inc_inv, ujsaved, ujscale, sign;
realtype *tmp2_data, *u_data, *uscale_data;
N_Vector ftemp, jthCol;
int retval = 0;
long int j;
KINMem kin_mem;
KINDlsMem kindls_mem;
/* data points to kin_mem */
kin_mem = (KINMem) data;
kindls_mem = (KINDlsMem) lmem;
/* Save pointer to the array in tmp2 */
tmp2_data = N_VGetArrayPointer(tmp2);
/* Rename work vectors for readibility */
ftemp = tmp1;
jthCol = tmp2;
/* Obtain pointers to the data for u and uscale */
u_data = N_VGetArrayPointer(u);
uscale_data = N_VGetArrayPointer(uscale);
/* This is the only for loop for 0..N-1 in KINSOL */
for (j = 0; j < N; j++)
{
/* Generate the jth col of Jac(u) */
N_VSetArrayPointer(DENSE_COL(Jac, j), jthCol);
ujsaved = u_data[j];
ujscale = ONE / uscale_data[j];
sign = (ujsaved >= ZERO) ? ONE : -ONE;
inc = sqrt_relfunc * MAX(ABS(ujsaved), ujscale) * sign;
u_data[j] += inc;
retval = func(u, ftemp, user_data);
nfeDQ++;
if (retval != 0)
{
break;
}
u_data[j] = ujsaved;
inc_inv = ONE / inc;
N_VLinearSum(inc_inv, ftemp, -inc_inv, fu, jthCol);
}
/* Restore original array pointer in tmp2 */
N_VSetArrayPointer(tmp2_data, tmp2);
return(retval);
}
/*
* -----------------------------------------------------------------
* 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 = RSqrt(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 = MAX( srur * MAX( ABS(yj), ABS(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 (ABS(conj) == ONE)
{
if ((yj + inc)*conj < ZERO)
{
inc = -inc;
}
}
else if (ABS(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);
}
/*
* -----------------------------------------------------------------
* cpDlsDenseDQJacImpl
* -----------------------------------------------------------------
* This routine generates a dense difference quotient approximation to
* the Jacobian F_y' + gamma*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 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 cpDlsDenseDQJacImpl(int N, 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)
{
realtype inc, inc_inv, yj, ypj, srur;
realtype *tmp2_data, *y_data, *yp_data, *ewt_data;
N_Vector ftemp, jthCol;
int j;
int retval = 0;
CPodeMem cp_mem;
CPDlsMem cpdls_mem;
/* jac_data points to cpode_mem */
cp_mem = (CPodeMem) jac_data;
cpdls_mem = (CPDlsMem) lmem;
/* Save pointer to the array in tmp2 */
tmp2_data = N_VGetArrayPointer(tmp2);
/* Rename work vectors for readibility */
ftemp = tmp1;
jthCol = tmp2;
/* Obtain pointers to the data for ewt, y, and yp */
ewt_data = N_VGetArrayPointer(ewt);
y_data = N_VGetArrayPointer(y);
yp_data = N_VGetArrayPointer(yp);
/* Set minimum increment based on uround and norm of f */
srur = RSqrt(uround);
/* Generate each column of the Jacobian M = F_y' + gamma * F_y
as delta(F)/delta(y_j). */
for (j = 0; j < N; 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 h*yp_j. */
inc = MAX( srur * MAX( ABS(yj), ABS(h*ypj) ) , ONE/ewt_data[j] );
if (h*ypj < ZERO) inc = -inc;
inc = (yj + inc) - yj;
/* Increment y_j and yp_j, call res, and break on error return. */
y_data[j] += gamma*inc;
yp_data[j] += inc;
retval = fi(t, y, yp, ftemp, f_data);
nfeDQ++;
if (retval != 0) break;
/* Generate the jth col of J(tn,y) */
inc_inv = ONE/inc;
N_VLinearSum(inc_inv, ftemp, -inc_inv, r, 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);
}
