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)
{
long int ier;
CVBandPrecData pdata;
/* Assume matrix and pivots have already been allocated. */
pdata = (CVBandPrecData) bp_data;
if (jok) {
/* If jok = TRUE, use saved copy of J. */
*jcurPtr = FALSE;
BandCopy(savedJ, savedP, mu, ml);
} else {
/* If jok = FALSE, call CVBandPDQJac for new J value. */
*jcurPtr = TRUE;
BandZero(savedJ);
CVBandPDQJac(pdata, t, y, fy, tmp1, tmp2);
BandCopy(savedJ, savedP, mu, ml);
}
/* Scale and add I to get savedP = I - gamma*J. */
BandScale(-gamma, savedP);
BandAddI(savedP);
/* Do LU factorization of matrix. */
ier = BandFactor(savedP, pivots);
/* 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)
{
long int ier;
CVBBDPrecData pdata;
pdata = (CVBBDPrecData) bbd_data;
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;
BandZero(savedJ);
CVBBDDQJac(pdata, t, y, tmp1, tmp2, tmp3);
nge += 1 + MIN(mldq + mudq + 1, Nlocal);
BandCopy(savedJ, savedP, mukeep, mlkeep);
}
/* Scale and add I to get P = I - gamma*J */
BandScale(-gamma, savedP);
BandAddI(savedP);
/* Do LU factorization of P in place */
ier = BandFactor(savedP, pivots);
/* Return 0 if the LU was complete; otherwise return 1 */
if (ier > 0) return(1);
return(0);
}
/*---------------------------------------------------------------
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 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)
{
long int ier;
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 CVBandPDQJac for new J value. */
*jcurPtr = TRUE;
BandZero(savedJ);
retval = CVBandPDQJac(pdata, t, y, fy, tmp1, tmp2);
if (retval < 0) {
CVProcessError(cv_mem, CVBANDPRE_RHSFUNC_UNRECVR, "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);
BandAddI(savedP);
/* Do LU factorization of matrix. */
ier = BandFactor(savedP, pivots);
/* 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 CVBandSetup(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;
long int ier;
CVBandMem cvband_mem;
cvband_mem = (CVBandMem) lmem;
/* Use nst, gamma/gammap, and convfail to set J eval. flag jok */
dgamma = ABS((gamma/gammap) - ONE);
jbad = (nst == 0) || (nst > nstlj + CVB_MSBJ) ||
((convfail == CV_FAIL_BAD_J) && (dgamma < CVB_DGMAX)) ||
(convfail == CV_FAIL_OTHER);
jok = !jbad;
if (jok) {
/* If jok = TRUE, use saved copy of J */
*jcurPtr = FALSE;
BandCopy(savedJ, M, mu, ml);
} else {
/* If jok = FALSE, call jac routine for new J value */
nje++;
nstlj = nst;
*jcurPtr = TRUE;
BandZero(M);
jac(n, mu, ml, M, tn, ypred, fpred, J_data, vtemp1, vtemp2, vtemp3);
BandCopy(M, savedJ, mu, ml);
}
/* Scale and add I to get M = I - gamma*J */
BandScale(-gamma, M);
BandAddI(M);
/* Do LU factorization of M */
ier = BandFactor(M, pivots);
/* Return 0 if the LU was complete; otherwise return 1 */
if (ier > 0) {
last_flag = ier;
return(1);
}
last_flag = CVBAND_SUCCESS;
return(0);
}
int PVBBDPrecon(integer N, real t, N_Vector y, N_Vector fy,
boole jok, boole *jcurPtr, real gamma, N_Vector ewt,
real h, real uround, long int *nfePtr, void *P_data,
N_Vector vtemp1, N_Vector vtemp2, N_Vector vtemp3)
{
integer Nlocal, ier;
real rely, srur;
PVBBDData pdata;
pdata = (PVBBDData)P_data;
Nlocal = N_VLOCLENGTH(y);
if (jok) {
/* If jok = TRUE, use saved copy of J */
*jcurPtr = FALSE;
BandCopy(savedJ, savedP, mukeep, mlkeep);
} else {
/* Otherwise call PVBBDDQJac for new J value */
*jcurPtr = TRUE;
BandZero(savedJ);
/* Set relative increment for y via dqrely and uround */
srur = RSqrt(uround);
rely = (dqrely == ZERO) ? srur : dqrely;
PVBBDDQJac(Nlocal, mudq, mldq, mukeep, mlkeep, rely, gloc, cfn, savedJ,
f_data, t, y, ewt, h, uround, vtemp1, vtemp2, vtemp3);
nge += 1 + MIN(mldq + mudq + 1, Nlocal);
BandCopy(savedJ, savedP, mukeep, mlkeep);
}
/* Scale and add I to get P = I - gamma*J */
BandScale(-gamma, savedP);
BandAddI(savedP);
/* Do LU factorization of P in place */
ier = BandFactor(savedP, pivots);
/* Return 0 if the LU was complete; otherwise return 1 */
if (ier > 0) return(1);
return(0);
}
CAMLprim value c_bandmatrix_copy(value va, value vb,
value vcopymu, value vcopyml)
{
CAMLparam4(va, vb, vcopymu, vcopyml);
long int copymu = Long_val(vcopymu);
long int copyml = Long_val(vcopyml);
DlsMat ma = DLSMAT(va);
DlsMat mb = DLSMAT(vb);
#if SUNDIALS_ML_SAFE == 1
long int copysize = copymu + copyml + 1;
long int a_bandwidth = ma->s_mu + ma->ml + 1;
long int b_bandwidth = mb->s_mu + mb->ml + 1;
if (copymu > ma->s_mu || copymu > mb->s_mu
|| copysize > a_bandwidth || copysize > b_bandwidth)
caml_invalid_argument("BandMatrix.blit: invalid arguments.");
#endif
BandCopy(ma, mb, copymu, copyml);
CAMLreturn (Val_unit);
}
static int cvBandSetup(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 ier, retval;
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;
BandCopy(savedJ, M, mu, ml);
} else {
/* If jok = FALSE, call jac routine for new J value */
nje++;
nstlj = nst;
*jcurPtr = TRUE;
SetToZero(M);
retval = jac(n, mu, ml, tn, ypred, fpred, M, J_data, vtemp1, vtemp2, vtemp3);
if (retval < 0) {
cvProcessError(cv_mem, CVDLS_JACFUNC_UNRECVR, "CVSBAND", "cvBandSetup", MSGD_JACFUNC_FAILED);
last_flag = CVDLS_JACFUNC_UNRECVR;
return(-1);
}
if (retval > 0) {
last_flag = CVDLS_JACFUNC_RECVR;
return(1);
}
BandCopy(M, savedJ, mu, ml);
}
/* Scale and add I to get M = I - gamma*J */
BandScale(-gamma, M);
AddIdentity(M);
/* Do LU factorization of M */
ier = BandGBTRF(M, pivots);
/* Return 0 if the LU was complete; otherwise return 1 */
if (ier > 0) {
last_flag = ier;
return(1);
}
last_flag = CVDLS_SUCCESS;
return(0);
}
