/*---------------------------------------------------------------
arkMassLapackDenseSetup does the setup operations for the dense
mass matrix solver. It calls the mass matrix evaluation routine,
updates counters, and calls the dense LU factorization routine.
---------------------------------------------------------------*/
static int arkMassLapackDenseSetup(ARKodeMem ark_mem, N_Vector tmp1,
N_Vector tmp2, N_Vector tmp3)
{
ARKDlsMassMem arkdls_mem;
int ier, retval;
int intn;
arkdls_mem = (ARKDlsMassMem) ark_mem->ark_mass_mem;
intn = (int) arkdls_mem->d_n;
SetToZero(arkdls_mem->d_M);
retval = arkdls_mem->d_dmass(arkdls_mem->d_n, 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",
"arkMassLapackDenseSetup", 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 */
dgetrf_f77(&intn, &intn, arkdls_mem->d_M->data,
&intn, 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);
}
/*
* idaLapackDenseSetup does the setup operations for the dense linear solver.
* It calls the Jacobian function to obtain the Newton matrix M = F_y + c_j*F_y',
* updates counters, and calls the dense LU factorization routine.
*/
static int idaLapackDenseSetup(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;
int intn;
idadls_mem = (IDADlsMem) lmem;
intn = (int) n;
/* Call Jacobian function */
nje++;
SetToZero(JJ);
retval = djac(n, tn, cj, yP, ypP, fctP, JJ, J_data, tmp1, tmp2, tmp3);
if (retval < 0) {
IDAProcessError(IDA_mem, IDADLS_JACFUNC_UNRECVR, "IDALAPACK", "idaLapackDenseSetup", 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 */
dgetrf_f77(&intn, &intn, JJ->data, &intn, pivots, &ier);
/* Return 0 if the LU was complete; otherwise return 1 */
last_flag = (long int) ier;
if (ier > 0) return(1);
return(0);
}
static int kinLapackDenseSetup(KINMem kin_mem)
{
KINDlsMem kindls_mem;
int ier, retval;
kindls_mem = (KINDlsMem) lmem;
nje++;
SetToZero(J);
retval = djac(n, uu, fval, J, J_data, vtemp1, vtemp2);
if (retval != 0) {
last_flag = -1;
return(-1);
}
/* Do LU factorization of J */
dgetrf_f77(&n, &n, 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);
}
/*
* cvLapackDenseSetup does the setup operations for the dense 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 dense LU factorization routine.
*/
static int cvLapackDenseSetup(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 = djac(n, 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", "cvLapackDenseSetup", 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 */
dgetrf_f77(&n, &n, 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);
}
/*---------------------------------------------------------------
arkLapackDenseSetup does the setup operations for the dense
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 dense LU factorization routine.
---------------------------------------------------------------*/
static int arkLapackDenseSetup(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, lenmat, i, j;
arkdls_mem = (ARKDlsMem) ark_mem->ark_lmem;
intn = (int) arkdls_mem->d_n;
lenmat = arkdls_mem->d_M->ldata ;
/* 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_djac(arkdls_mem->d_n, 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",
"arkLapackDenseSetup", 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_dmass(arkdls_mass_mem->d_n,
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, "ARKDENSE",
"arkLapackDenseSetup", 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 */
for (j=0; j<arkdls_mem->d_M->N; j++) {
Acol_j = arkdls_mem->d_M->cols[j];
Mcol_j = arkdls_mass_mem->d_M->cols[j];
for (i=0; i<arkdls_mem->d_M->M; i++)
Acol_j[i] += Mcol_j[i];
}
} else {
AddIdentity(arkdls_mem->d_M);
}
/* Do LU factorization of M */
dgetrf_f77(&intn, &intn, arkdls_mem->d_M->data,
&intn, 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);
}
/*
* cpLapackDenseSetup does the setup operations for the dense 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 dense LU factorization routine.
*/
static int cpLapackDenseSetup(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 = djacE(n, 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", "cpLapackDenseSetup", 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*/
LapackDenseAddI(M);
break;
case CP_IMPL:
/* Call Jacobian function */
nje++;
retval = djacI(n, 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", "cpLapackDenseSetup", 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 */
dgetrf_f77(&n, &n, 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);
}
/*
* cpLapackDenseProjSetup does the setup operations for the dense
* linear solver.
* It calls the Jacobian evaluation routine and, depending on ftype,
* it performs various factorizations.
*/
static int cpLapackDenseProjSetup(CPodeMem cp_mem, N_Vector y, N_Vector cy,
N_Vector c_tmp1, N_Vector c_tmp2, N_Vector s_tmp1)
{
int ier;
CPDlsProjMem cpdlsP_mem;
realtype *col_i, rim1, ri;
int i, j, nd, one = 1;
int retval;
realtype coef_1 = ONE, coef_0 = ZERO;
cpdlsP_mem = (CPDlsProjMem) lmemP;
nd = ny-nc;
/* Call Jacobian function (G will contain the Jacobian transposed) */
retval = djacP(nc, ny, tn, y, cy, G, JP_data, c_tmp1, c_tmp2);
njeP++;
if (retval < 0) {
cpProcessError(cp_mem, CPDIRECT_JACFUNC_UNRECVR, "CPLAPACK", "cpLapackDenseProjSetup", MSGD_JACFUNC_FAILED);
return(-1);
} else if (retval > 0) {
return(1);
}
/* Save Jacobian before factorization for possible use by lmultP */
dcopy_f77(&(G->ldata), G->data, &one, savedG->data, &one);
/* Factorize G, depending on ftype */
switch (ftype) {
case CPDIRECT_LU:
/*
* LU factorization of G^T with partial pivoting
* P*G^T = | U1^T | * L^T
* | U2^T |
* After factorization, P is encoded in pivotsP and
* G^T is overwritten with U1 (nc by nc unit upper triangular),
* U2 ( nc by ny-nc rectangular), and L (nc by nc lower triangular).
* Return ier if factorization failed.
*/
dgetrf_f77(&ny, &nc, G->data, &ny, pivotsP, &ier);
if (ier != 0) return(ier);
/*
* Build S = U1^{-1} * U2 (in place, S overwrites U2)
* For each row j of G, j = nc,...,ny-1, perform
* a backward substitution (row version).
* After this step, G^T contains U1, S, and L.
*/
for (j=nc; j<ny; j++)
dtrsv_f77("L", "T", "U", &nc, G->data, &ny, (G->data + j), &ny, 1, 1, 1);
/*
* Build K = D1 + S^T * D2 * S
* S^T is stored in g_mat[nc...ny-1][0...nc]
* Compute and store only the lower triangular part of K.
*/
if (pnorm == CP_PROJ_L2NORM) {
dsyrk_f77("L", "N", &nd, &nc, &coef_1, (G->data + nc), &ny, &coef_0, K->data, &nd, 1, 1);
LapackDenseAddI(K);
} else {
cplLUcomputeKD(cp_mem, s_tmp1);
}
/*
* Perform Cholesky decomposition of K: K = C*C^T
* After factorization, the lower triangular part of K contains C.
* Return ier if factorization failed.
*/
dpotrf_f77("L", &nd, K->data, &nd, &ier, 1);
if (ier != 0) return(ier);
break;
case CPDIRECT_QR:
/*
* QR factorization of G^T: G^T = Q*R
* After factorization, the upper triangular part of G^T
* contains the matrix R. The lower trapezoidal part of
* G^T, together with the array beta, encodes the orthonormal
* columns of Q as elementary reflectors.
*/
dgeqrf_f77(&ny, &nc, G->data, &ny, beta, wrk, &len_wrk, &ier);
if (ier != 0) return(ier);
/* If projecting in WRMS norm */
if (pnorm == CP_PROJ_ERRNORM) {
/* Build K = Q^T * D^(-1) * Q */
cplQRcomputeKD(cp_mem, s_tmp1);
/* Perform Cholesky decomposition of K */
dpotrf_f77("L", &nc, K->data, &nc, &ier, 1);
if (ier != 0) return(ier);
}
break;
case CPDIRECT_QRP:
/*
* QR with pivoting factorization of G^T: G^T * P = Q * R.
* After factorization, the upper triangular part of G^T
* contains the matrix R. The lower trapezoidal part of
* G^T, together with the array beta, encodes the orthonormal
* columns of Q as elementary reflectors.
* The pivots are stored in 'pivotsP'.
*/
for (i=0; i<nc; i++) pivotsP[i] = 0;
dgeqp3_f77(&ny, &nc, G->data, &ny, pivotsP, beta, wrk, &len_wrk, &ier);
if (ier != 0) return(ier);
/*
* Determine the number of independent constraints.
* After the QR factorization, the diagonal elements of R should
* be in decreasing order of their absolute values.
*/
rim1 = ABS(G->data[0]);
for (i=1, nr=1; i<nc; i++, nr++) {
col_i = G->cols[i];
ri = ABS(col_i[i]);
if (ri < 100*uround) break;
if (ri/rim1 < RPowerR(uround, THREE/FOUR)) break;
}
/* If projecting in WRMS norm */
if (pnorm == CP_PROJ_ERRNORM) {
/* Build K = Q^T * D^(-1) * Q */
cplQRcomputeKD(cp_mem, s_tmp1);
/* Perform Cholesky decomposition of K */
dpotrf_f77("L", &nc, K->data, &nc, &ier, 1);
if (ier != 0) return(ier);
}
break;
case CPDIRECT_SC:
/*
* Build K = G*D^(-1)*G^T
* G^T is stored in g_mat[0...ny-1][0...nc]
* Compute and store only the lower triangular part of K.
*/
if (pnorm == CP_PROJ_L2NORM) {
dsyrk_f77("L", "T", &nc, &ny, &coef_1, G->data, &ny, &coef_0, K->data, &nc, 1, 1);
} else {
cplSCcomputeKD(cp_mem, s_tmp1);
}
/*
* Perform Cholesky decomposition of K: K = C*C^T
* After factorization, the lower triangular part of K contains C.
* Return 1 if factorization failed.
*/
dpotrf_f77("L", &nc, K->data, &nc, &ier, 1);
if (ier != 0) return(ier);
break;
}
return(0);
}
