/*
* idaLapackBandSetup does the setup operations for the band linear solver.
* It calls the Jacobian function to obtain the Newton matrix M = F_y + c_j*F_y',
* updates counters, and calls the band LU factorization routine.
*/
static int idaLapackBandSetup(IDAMem IDA_mem,
N_Vector yP, N_Vector ypP, N_Vector fctP,
N_Vector tmp1, N_Vector tmp2, N_Vector tmp3)
{
IDADlsMem idadls_mem;
int ier, retval;
idadls_mem = (IDADlsMem) lmem;
/* Call Jacobian function */
nje++;
SetToZero(JJ);
retval = bjac(n, mu, ml, tn, cj, yP, ypP, fctP, JJ, J_data, tmp1, tmp2, tmp3);
if (retval < 0) {
IDAProcessError(IDA_mem, IDADLS_JACFUNC_UNRECVR, "IDALAPACK", "idaLapackBandSetup", MSGD_JACFUNC_FAILED);
last_flag = IDADLS_JACFUNC_UNRECVR;
return(-1);
} else if (retval > 0) {
last_flag = IDADLS_JACFUNC_RECVR;
return(+1);
}
/* Do LU factorization of M */
dgbtrf_f77(&n, &n, &ml, &mu, JJ->data, &(JJ->ldim), pivots, &ier);
/* Return 0 if the LU was complete; otherwise return 1 */
last_flag = ier;
if (ier > 0) return(1);
return(0);
}
/*---------------------------------------------------------------
arkMassLapackBandSetup does the setup operations for the band
mass matrix solver. It constructs the mass matrix M, updates
counters, and calls the band LU factorization routine.
---------------------------------------------------------------*/
static int arkMassLapackBandSetup(ARKodeMem ark_mem, N_Vector tmp1,
N_Vector tmp2, N_Vector tmp3)
{
ARKDlsMassMem arkdls_mem;
int ier, retval;
int intn, iml, imu, ldmat;
arkdls_mem = (ARKDlsMassMem) ark_mem->ark_mass_mem;
intn = (int) arkdls_mem->d_n;
iml = (int) arkdls_mem->d_ml;
imu = (int) arkdls_mem->d_mu;
ldmat = arkdls_mem->d_M->ldim;
SetToZero(arkdls_mem->d_M);
retval = arkdls_mem->d_bmass(arkdls_mem->d_n, arkdls_mem->d_mu,
arkdls_mem->d_ml, ark_mem->ark_tn,
arkdls_mem->d_M, arkdls_mem->d_M_data,
tmp1, tmp2, tmp3);
arkdls_mem->d_nme++;
if (retval < 0) {
arkProcessError(ark_mem, ARKDLS_MASSFUNC_UNRECVR, "ARKLAPACK",
"arkMassLapackBandSetup", MSGD_MASSFUNC_FAILED);
arkdls_mem->d_last_flag = ARKDLS_MASSFUNC_UNRECVR;
return(-1);
} else if (retval > 0) {
arkdls_mem->d_last_flag = ARKDLS_MASSFUNC_RECVR;
return(1);
}
/* 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);
}
static int kinLapackBandSetup(KINMem kin_mem)
{
KINDlsMem kindls_mem;
int ier, retval;
kindls_mem = (KINDlsMem) lmem;
nje++;
SetToZero(J);
retval = bjac(n, mu, ml, uu, fval, J, J_data, vtemp1, vtemp2);
if (retval != 0) {
last_flag = -1;
return(-1);
}
/* Do LU factorization of J */
dgbtrf_f77(&n, &n, &ml, &mu, J->data, &(J->ldim), pivots, &ier);
/* Return 0 if the LU was complete; otherwise return -1 */
last_flag = ier;
if (ier > 0) return(-1);
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);
}
