/*
* idaLapackBandSolve handles the solve operation for the band linear solver
* by calling the band backsolve routine.
*/
static int idaLapackBandSolve(IDAMem IDA_mem, N_Vector b, N_Vector weight,
N_Vector yC, N_Vector ypC, N_Vector fctC)
{
IDADlsMem idadls_mem;
realtype *bd, fact;
int ier, one = 1;
int intn, iml, imu, ldmat;
idadls_mem = (IDADlsMem) lmem;
intn = (int) n;
iml = (int) ml;
imu = (int) mu;
ldmat = JJ->ldim;
bd = N_VGetArrayPointer(b);
dgbtrs_f77("N", &intn, &iml, &imu, &one, JJ->data, &ldmat, pivots, bd, &intn, &ier, 1);
if (ier > 0) return(1);
/* For BDF, scale the correction to account for change in cj */
if (cjratio != ONE) {
fact = TWO/(ONE + cjratio);
dscal_f77(&intn, &fact, bd, &one);
}
last_flag = IDADLS_SUCCESS;
return(0);
}
/*
* cvLapackBandSolve handles the solve operation for the band linear solver
* by calling the band backsolve routine.
*/
static int cvLapackBandSolve(CVodeMem cv_mem, N_Vector b, N_Vector weight,
N_Vector yC, N_Vector fctC)
{
CVDlsMem cvdls_mem;
realtype *bd, fact;
int ier, one = 1;
int intn, iml, imu, ldmat;
cvdls_mem = (CVDlsMem) lmem;
intn = (int) n;
iml = (int) ml;
imu = (int) mu;
ldmat = M->ldim;
bd = N_VGetArrayPointer(b);
dgbtrs_f77("N", &intn, &iml, &imu, &one, M->data, &ldmat, pivots, bd, &intn, &ier, 1);
if (ier > 0) return(1);
/* For BDF, scale the correction to account for change in gamma */
if ((lmm == CV_BDF) && (gamrat != ONE)) {
fact = TWO/(ONE + gamrat);
dscal_f77(&intn, &fact, bd, &one);
}
last_flag = CVDLS_SUCCESS;
return(0);
}
/*
* idaLapackDenseSolve handles the solve operation for the dense linear solver
* by calling the dense backsolve routine.
*/
static int idaLapackDenseSolve(IDAMem IDA_mem, N_Vector b, N_Vector weight,
N_Vector yC, N_Vector ypC, N_Vector fctC)
{
IDADlsMem idadls_mem;
realtype *bd, fact;
int ier, one = 1;
int intn;
idadls_mem = (IDADlsMem) lmem;
intn = (int) n;
bd = N_VGetArrayPointer(b);
dgetrs_f77("N", &intn, &one, JJ->data, &intn, pivots, bd, &intn, &ier, 1);
if (ier > 0) return(1);
/* Scale the correction to account for change in cj. */
if (cjratio != ONE) {
fact = TWO/(ONE + cjratio);
dscal_f77(&intn, &fact, bd, &one);
}
last_flag = IDADLS_SUCCESS;
return(0);
}
/*---------------------------------------------------------------
arkLapackDenseSolve handles the solve operation for the dense
linear solver by calling the dense backsolve routine.
---------------------------------------------------------------*/
static int arkLapackDenseSolve(ARKodeMem ark_mem, N_Vector b,
N_Vector weight, N_Vector yC,
N_Vector fctC)
{
ARKDlsMem arkdls_mem;
realtype *bd, fact;
int ier, one = 1;
int intn;
arkdls_mem = (ARKDlsMem) ark_mem->ark_lmem;
intn = (int) arkdls_mem->d_n;
bd = N_VGetArrayPointer(b);
dgetrs_f77("N", &intn, &one, arkdls_mem->d_M->data, &intn,
arkdls_mem->d_pivots, bd, &intn, &ier, 1);
if (ier > 0) return(1);
/* scale the correction to account for change in gamma */
if (ark_mem->ark_gamrat != ONE) {
fact = TWO/(ONE + ark_mem->ark_gamrat);
dscal_f77(&intn, &fact, bd, &one);
}
arkdls_mem->d_last_flag = ARKDLS_SUCCESS;
return(0);
}
/*
* cpLapackBandSolve handles the solve operation for the band linear solver
* by calling the band backsolve routine.
*/
static int cpLapackBandSolve(CPodeMem cp_mem, N_Vector b, N_Vector weight,
N_Vector yC, N_Vector ypC, N_Vector fctC)
{
CPDlsMem cpdls_mem;
realtype *bd, fact;
int ier, one = 1;
cpdls_mem = (CPDlsMem) lmem;
bd = N_VGetArrayPointer(b);
dgbtrs_f77("N", &n, &ml, &mu, &one, M->data, &(M->ldim), pivots, bd, &n, &ier, 1);
if (ier > 0) return(1);
/* For BDF, scale the correction to account for change in gamma */
if ((lmm_type == CP_BDF) && (gamrat != ONE)) {
fact = TWO/(ONE + gamrat);
dscal_f77(&n, &fact, bd, &one);
}
last_flag = CPDIRECT_SUCCESS;
return(0);
}
/*
* 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);
}
/*
* cpLapackBandSetup 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 (for explicit ODE only). In any case, it constructs
* the Newton matrix M = I - gamma*J or M = F_y' - gamma*F_y, updates
* counters, and calls the band LU factorization routine.
*/
static int cpLapackBandSetup(CPodeMem cp_mem, int convfail,
N_Vector yP, N_Vector ypP, N_Vector fctP,
booleantype *jcurPtr,
N_Vector tmp1, N_Vector tmp2, N_Vector tmp3)
{
CPDlsMem cpdls_mem;
realtype dgamma, fact;
booleantype jbad, jok;
int ier, retval, one = 1;
cpdls_mem = (CPDlsMem) lmem;
switch (ode_type) {
case CP_EXPL:
/* Use nst, gamma/gammap, and convfail to set J eval. flag jok */
dgamma = ABS((gamma/gammap) - ONE);
jbad = (nst == 0) || (nst > nstlj + CPD_MSBJ) ||
((convfail == CP_FAIL_BAD_J) && (dgamma < CPD_DGMAX)) ||
(convfail == CP_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;
retval = bjacE(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) {
cpProcessError(cp_mem, CPDIRECT_JACFUNC_UNRECVR, "CPLAPACK", "cpLapackBandSetup", MSGD_JACFUNC_FAILED);
last_flag = CPDIRECT_JACFUNC_UNRECVR;
return(-1);
} else if (retval > 0) {
last_flag = CPDIRECT_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*/
LapackBandAddI(M);
break;
case CP_IMPL:
/* Call Jacobian function */
nje++;
retval = bjacI(n, mu, ml, tn, gamma, yP, ypP, fctP, M, J_data, tmp1, tmp2, tmp3);
if (retval == 0) {
break;
} else if (retval < 0) {
cpProcessError(cp_mem, CPDIRECT_JACFUNC_UNRECVR, "CPLAPACK", "cpLapackBandSetup", MSGD_JACFUNC_FAILED);
last_flag = CPDIRECT_JACFUNC_UNRECVR;
return(-1);
} else if (retval > 0) {
last_flag = CPDIRECT_JACFUNC_RECVR;
return(+1);
}
break;
}
/* 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);
}
