/*---------------------------------------------------------------
ARKBandPrecSetup:
Together ARKBandPrecSetup and ARKBandPrecSolve use a banded
difference quotient Jacobian to create a preconditioner.
ARKBandPrecSetup calculates a new J, if necessary, then
calculates P = I - gamma*J, and does an LU factorization of P.
The parameters of ARKBandPrecSetup are as follows:
t is the current value of the independent variable.
y is the current value of the dependent variable vector,
namely the predicted value of y(t).
fy is the vector f(t,y).
jok is an input flag indicating whether Jacobian-related
data needs to be recomputed, as follows:
jok == FALSE means recompute Jacobian-related data
from scratch.
jok == TRUE means that Jacobian data from the
previous PrecSetup call will be reused
(with the current value of gamma).
A ARKBandPrecSetup call with jok == TRUE should only
occur after a call with jok == FALSE.
*jcurPtr is a pointer to an output integer flag which is
set by ARKBandPrecond as follows:
*jcurPtr = TRUE if Jacobian data was recomputed.
*jcurPtr = FALSE if Jacobian data was not recomputed,
but saved data was reused.
gamma is the scalar appearing in the Newton matrix.
bp_data is a pointer to preconditoner data (set by ARKBandPrecInit)
tmp1, tmp2, and tmp3 are pointers to memory allocated
for vectors of length N for work space. This
routine uses only tmp1 and tmp2.
The value to be returned by the ARKBandPrecSetup function is
0 if successful, or
1 if the band factorization failed.
---------------------------------------------------------------*/
static int ARKBandPrecSetup(realtype t, N_Vector y, N_Vector fy,
booleantype jok, booleantype *jcurPtr,
realtype gamma, void *bp_data,
N_Vector tmp1, N_Vector tmp2, N_Vector tmp3)
{
ARKBandPrecData pdata;
ARKodeMem ark_mem;
int retval;
long int ier;
/* Assume matrix and lpivots have already been allocated. */
pdata = (ARKBandPrecData) bp_data;
ark_mem = (ARKodeMem) pdata->arkode_mem;
if (jok) {
/* If jok = TRUE, use saved copy of J. */
*jcurPtr = FALSE;
BandCopy(pdata->savedJ, pdata->savedP, pdata->mu, pdata->ml);
} else {
/* If jok = FALSE, call ARKBandPDQJac for new J value. */
*jcurPtr = TRUE;
SetToZero(pdata->savedJ);
retval = ARKBandPDQJac(pdata, t, y, fy, tmp1, tmp2);
if (retval < 0) {
arkProcessError(ark_mem, -1, "ARKBANDPRE", "ARKBandPrecSetup", MSGBP_RHSFUNC_FAILED);
return(-1);
}
if (retval > 0) {
return(1);
}
BandCopy(pdata->savedJ, pdata->savedP, pdata->mu, pdata->ml);
}
/* Scale and add I to get savedP = I - gamma*J. */
BandScale(-gamma, pdata->savedP);
AddIdentity(pdata->savedP);
/* Do LU factorization of matrix. */
ier = BandGBTRF(pdata->savedP, pdata->lpivots);
/* Return 0 if the LU was complete; otherwise return 1. */
if (ier > 0) return(1);
return(0);
}
static int CVBBDPrecSetup(realtype t, N_Vector y, N_Vector fy,
booleantype jok, booleantype *jcurPtr,
realtype gamma, void *bbd_data,
N_Vector tmp1, N_Vector tmp2, N_Vector tmp3)
{
int ier;
CVBBDPrecData pdata;
CVodeMem cv_mem;
int retval;
pdata = (CVBBDPrecData) bbd_data;
cv_mem = (CVodeMem) pdata->cvode_mem;
if (jok) {
/* If jok = TRUE, use saved copy of J */
*jcurPtr = FALSE;
BandCopy(savedJ, savedP, mukeep, mlkeep);
} else {
/* Otherwise call CVBBDDQJac for new J value */
*jcurPtr = TRUE;
SetToZero(savedJ);
retval = CVBBDDQJac(pdata, t, y, tmp1, tmp2, tmp3);
if (retval < 0) {
CVProcessError(cv_mem, -1, "CVBBDPRE", "CVBBDPrecSetup", MSGBBD_FUNC_FAILED);
return(-1);
}
if (retval > 0) {
return(1);
}
BandCopy(savedJ, savedP, mukeep, mlkeep);
}
/* Scale and add I to get P = I - gamma*J */
BandScale(-gamma, savedP);
AddIdentity(savedP);
/* Do LU factorization of P in place */
ier = BandGBTRF(savedP, pivots);
/* Return 0 if the LU was complete; otherwise return 1 */
if (ier > 0) return(1);
return(0);
}
static int cvBandPrecSetup(realtype t, N_Vector y, N_Vector fy,
booleantype jok, booleantype *jcurPtr,
realtype gamma, void *bp_data,
N_Vector tmp1, N_Vector tmp2, N_Vector tmp3)
{
CVBandPrecData pdata;
CVodeMem cv_mem;
int retval;
/* Assume matrix and pivots have already been allocated. */
pdata = (CVBandPrecData) bp_data;
cv_mem = (CVodeMem) pdata->cvode_mem;
if (jok) {
/* If jok = TRUE, use saved copy of J. */
*jcurPtr = FALSE;
BandCopy(savedJ, savedP, mu, ml);
} else {
/* If jok = FALSE, call cvBandPrecDQJac for new J value. */
*jcurPtr = TRUE;
SetToZero(savedJ);
retval = cvBandPrecDQJac(pdata, t, y, fy, tmp1, tmp2);
if (retval < 0) {
cvProcessError(cv_mem, -1, "CVBANDPRE", "cvBandPrecSetup", MSGBP_RHSFUNC_FAILED);
return(-1);
}
if (retval > 0) {
return(1);
}
BandCopy(savedJ, savedP, mu, ml);
}
/* Scale and add I to get savedP = I - gamma*J. */
BandScale(-gamma, savedP);
AddIdentity(savedP);
/* Do LU factorization of matrix. */
retval = BandGBTRF(savedP, pivots);
/* Return 0 if the LU was complete; otherwise return 1. */
if (retval > 0) return(1);
return(0);
}
static int cvDenseSetup(CVodeMem cv_mem, int convfail, N_Vector ypred,
N_Vector fpred, booleantype *jcurPtr,
N_Vector vtemp1, N_Vector vtemp2, N_Vector vtemp3)
{
CVDlsMem cvdls_mem;
booleantype jbad, jok;
realtype dgamma;
int retval;
long int ier;
cvdls_mem = (CVDlsMem) lmem;
/* Use nst, gamma/gammap, and convfail to set J eval. flag jok */
dgamma = ABS((gamma/gammap) - ONE);
jbad = (nst == 0) || (nst > nstlj + CVD_MSBJ) ||
((convfail == CV_FAIL_BAD_J) && (dgamma < CVD_DGMAX)) ||
(convfail == CV_FAIL_OTHER);
jok = !jbad;
if (jok) {
/* If jok = TRUE, use saved copy of J */
*jcurPtr = FALSE;
DenseCopy(savedJ, M);
} else {
/* If jok = FALSE, call jac routine for new J value */
nje++;
nstlj = nst;
*jcurPtr = TRUE;
SetToZero(M);
retval = jac(n, tn, ypred, fpred, M, J_data, vtemp1, vtemp2, vtemp3);
if (retval < 0) {
cvProcessError(cv_mem, CVDLS_JACFUNC_UNRECVR, "CVSDENSE", "cvDenseSetup", MSGD_JACFUNC_FAILED);
last_flag = CVDLS_JACFUNC_UNRECVR;
return(-1);
}
if (retval > 0) {
last_flag = CVDLS_JACFUNC_RECVR;
return(1);
}
DenseCopy(M, savedJ);
}
/* Scale and add I to get M = I - gamma*J */
DenseScale(-gamma, M);
AddIdentity(M);
/* Do LU factorization of M */
ier = DenseGETRF(M, lpivots);
/* Return 0 if the LU was complete; otherwise return 1 */
last_flag = ier;
if (ier > 0) return(1);
return(0);
}
CAMLprim value c_densematrix_add_identity(value va)
{
CAMLparam1(va);
AddIdentity(DLSMAT(va));
CAMLreturn (Val_unit);
}
/*
* cvLapackBandSetup does the setup operations for the band linear solver.
* It makes a decision whether or not to call the Jacobian evaluation
* routine based on various state variables, and if not it uses the
* saved copy. In any case, it constructs the Newton matrix M = I - gamma*J,
* updates counters, and calls the band LU factorization routine.
*/
static int cvLapackBandSetup(CVodeMem cv_mem, int convfail,
N_Vector yP, N_Vector fctP,
booleantype *jcurPtr,
N_Vector tmp1, N_Vector tmp2, N_Vector tmp3)
{
CVDlsMem cvdls_mem;
realtype dgamma, fact;
booleantype jbad, jok;
int ier, retval, one = 1;
cvdls_mem = (CVDlsMem) lmem;
/* Use nst, gamma/gammap, and convfail to set J eval. flag jok */
dgamma = ABS((gamma/gammap) - ONE);
jbad = (nst == 0) || (nst > nstlj + CVD_MSBJ) ||
((convfail == CV_FAIL_BAD_J) && (dgamma < CVD_DGMAX)) ||
(convfail == CV_FAIL_OTHER);
jok = !jbad;
if (jok) {
/* If jok = TRUE, use saved copy of J */
*jcurPtr = FALSE;
dcopy_f77(&(savedJ->ldata), savedJ->data, &one, M->data, &one);
} else {
/* If jok = FALSE, call jac routine for new J value */
nje++;
nstlj = nst;
*jcurPtr = TRUE;
SetToZero(M);
retval = bjac(n, mu, ml, tn, yP, fctP, M, J_data, tmp1, tmp2, tmp3);
if (retval == 0) {
dcopy_f77(&(M->ldata), M->data, &one, savedJ->data, &one);
} else if (retval < 0) {
cvProcessError(cv_mem, CVDLS_JACFUNC_UNRECVR, "CVSLAPACK", "cvLapackBandSetup", MSGD_JACFUNC_FAILED);
last_flag = CVDLS_JACFUNC_UNRECVR;
return(-1);
} else if (retval > 0) {
last_flag = CVDLS_JACFUNC_RECVR;
return(1);
}
}
/* Scale J by - gamma */
fact = -gamma;
dscal_f77(&(M->ldata), &fact, M->data, &one);
/* Add identity to get M = I - gamma*J*/
AddIdentity(M);
/* Do LU factorization of M */
dgbtrf_f77(&n, &n, &ml, &mu, M->data, &(M->ldim), pivots, &ier);
/* Return 0 if the LU was complete; otherwise return 1 */
last_flag = ier;
if (ier > 0) return(1);
return(0);
}
/*---------------------------------------------------------------
arkLapackBandSetup does the setup operations for the band linear
solver. It makes a decision whether or not to call the Jacobian
evaluation routine based on various state variables, and if not
it uses the saved copy. In any case, it constructs the Newton
matrix A = M - gamma*J, updates counters, and calls the band LU
factorization routine.
---------------------------------------------------------------*/
static int arkLapackBandSetup(ARKodeMem ark_mem, int convfail,
N_Vector yP, N_Vector fctP,
booleantype *jcurPtr, N_Vector tmp1,
N_Vector tmp2, N_Vector tmp3)
{
ARKDlsMem arkdls_mem;
ARKDlsMassMem arkdls_mass_mem;
realtype dgamma, fact, *Acol_j, *Mcol_j;
booleantype jbad, jok;
int ier, retval, one = 1;
int intn, iml, imu, lenmat, ldmat, i, j, colSize;
arkdls_mem = (ARKDlsMem) ark_mem->ark_lmem;
intn = (int) arkdls_mem->d_n;
iml = (int) arkdls_mem->d_ml;
imu = (int) arkdls_mem->d_mu;
lenmat = arkdls_mem->d_M->ldata;
ldmat = arkdls_mem->d_M->ldim;
/* 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 > arkdls_mem->d_nstlj + ARKD_MSBJ) ||
((convfail == ARK_FAIL_BAD_J) && (dgamma < ARKD_DGMAX)) ||
(convfail == ARK_FAIL_OTHER);
jok = !jbad;
/* If jok = TRUE, use saved copy of J */
if (jok) {
*jcurPtr = FALSE;
dcopy_f77(&lenmat, arkdls_mem->d_savedJ->data,
&one, arkdls_mem->d_M->data, &one);
/* If jok = FALSE, call jac routine for new J value */
} else {
arkdls_mem->d_nje++;
arkdls_mem->d_nstlj = ark_mem->ark_nst;
*jcurPtr = TRUE;
SetToZero(arkdls_mem->d_M);
retval = arkdls_mem->d_bjac(arkdls_mem->d_n, arkdls_mem->d_mu,
arkdls_mem->d_ml, ark_mem->ark_tn,
yP, fctP, arkdls_mem->d_M,
arkdls_mem->d_J_data, tmp1, tmp2, tmp3);
if (retval == 0) {
dcopy_f77(&lenmat, arkdls_mem->d_M->data, &one,
arkdls_mem->d_savedJ->data, &one);
} else if (retval < 0) {
arkProcessError(ark_mem, ARKDLS_JACFUNC_UNRECVR, "ARKLAPACK",
"arkLapackBandSetup", MSGD_JACFUNC_FAILED);
arkdls_mem->d_last_flag = ARKDLS_JACFUNC_UNRECVR;
return(-1);
} else if (retval > 0) {
arkdls_mem->d_last_flag = ARKDLS_JACFUNC_RECVR;
return(1);
}
}
/* Scale J by -gamma */
fact = -ark_mem->ark_gamma;
dscal_f77(&lenmat, &fact, arkdls_mem->d_M->data, &one);
/* Add mass matrix to get A = M-gamma*J*/
if (ark_mem->ark_mass_matrix) {
/* Compute mass matrix */
arkdls_mass_mem = (ARKDlsMassMem) ark_mem->ark_mass_mem;
SetToZero(arkdls_mass_mem->d_M);
retval = arkdls_mass_mem->d_bmass(arkdls_mass_mem->d_n, arkdls_mass_mem->d_mu,
arkdls_mass_mem->d_ml, ark_mem->ark_tn,
arkdls_mass_mem->d_M, arkdls_mass_mem->d_M_data,
tmp1, tmp2, tmp3);
arkdls_mass_mem->d_nme++;
if (retval < 0) {
arkProcessError(ark_mem, ARKDLS_MASSFUNC_UNRECVR, "ARKLAPACK",
"arkLapackBandSetup", MSGD_MASSFUNC_FAILED);
arkdls_mem->d_last_flag = ARKDLS_MASSFUNC_UNRECVR;
return(-1);
}
if (retval > 0) {
arkdls_mem->d_last_flag = ARKDLS_MASSFUNC_RECVR;
return(1);
}
/* Add to A -- CURRENTLY ASSUMES THAT BOTH MATRICES HAVE
THE SAME BAND STRUCTURE AND COLUMN SIZE */
colSize = arkdls_mem->d_M->mu + arkdls_mem->d_M->ml + 1;
for (j=0; j<arkdls_mem->d_M->M; j++) {
Acol_j = arkdls_mem->d_M->cols[j] + arkdls_mem->d_M->s_mu - arkdls_mem->d_M->mu;
Mcol_j = arkdls_mass_mem->d_M->cols[j] + arkdls_mass_mem->d_M->s_mu
- arkdls_mass_mem->d_M->mu;
for (i=0; i<colSize; i++)
Acol_j[i] += Mcol_j[i];
}
} else {
AddIdentity(arkdls_mem->d_M);
}
/* Do LU factorization of M */
dgbtrf_f77(&intn, &intn, &iml, &imu, arkdls_mem->d_M->data,
&ldmat, arkdls_mem->d_pivots, &ier);
/* Return 0 if the LU was complete; otherwise return 1 */
arkdls_mem->d_last_flag = (long int) ier;
if (ier > 0) return(1);
return(0);
}