static int KINDenseSetup(KINMem kin_mem)
{
KINDenseMem kindense_mem;
long int ier;
int retval;
kindense_mem = (KINDenseMem) lmem;
nje++;
DenseZero(J);
retval = jac(n, J, uu, fval, J_data, vtemp1, vtemp2);
if (retval != 0) {
last_flag = -1;
return(-1);
}
/* Do LU factorization of J */
ier = DenseGETRF(J, pivots);
/* Return 0 if the LU was complete; otherwise return -1 */
last_flag = ier;
if (ier > 0) return(-1);
return(0);
}
CAMLprim value c_densematrix_getrf(value va, value vp)
{
CAMLparam2(va, vp);
int r = DenseGETRF(DLSMAT(va), LONG_ARRAY(vp));
if (r != 0) {
caml_raise_with_arg(DLS_EXN(ZeroDiagonalElement),
Val_int(r));
}
CAMLreturn (Val_unit);
}
static int IDADenseSetup(IDAMem IDA_mem, N_Vector yyp, N_Vector ypp,
N_Vector rrp, N_Vector tmp1, N_Vector tmp2,
N_Vector tmp3)
{
int retval;
long int retfac;
IDADlsMem idadls_mem;
idadls_mem = (IDADlsMem) lmem;
/* Increment nje counter. */
nje++;
/* Zero out JJ; call Jacobian routine jac; return if it failed. */
SetToZero(JJ);
retval = djac(neq, tn, cj, yyp, ypp, rrp, JJ, jacdata,
tmp1, tmp2, tmp3);
if (retval < 0)
{
IDAProcessError(IDA_mem, IDADLS_JACFUNC_UNRECVR, "IDADENSE", "IDADenseSetup", MSGD_JACFUNC_FAILED);
last_flag = IDADLS_JACFUNC_UNRECVR;
return(-1);
}
if (retval > 0)
{
last_flag = IDADLS_JACFUNC_RECVR;
return(+1);
}
/* Do LU factorization of JJ; return success or fail flag. */
retfac = DenseGETRF(JJ, lpivots);
if (retfac != 0)
{
last_flag = retfac;
return(+1);
}
last_flag = IDADLS_SUCCESS;
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);
}
static int cpDenseProjSetup(CPodeMem cp_mem, N_Vector y, N_Vector cy,
N_Vector c_tmp1, N_Vector c_tmp2, N_Vector s_tmp1)
{
long int ier;
CPDlsProjMem cpdlsP_mem;
realtype **g_mat, *col_i, *s_tmpd;
long int i, j, k;
int retval;
cpdlsP_mem = (CPDlsProjMem) lmemP;
g_mat = G->cols;
/*
* Initialize Jacobian matrix to 0 and call Jacobian function
* G will contain the Jacobian transposed.
*/
DenseZero(G);
retval = jacP(nc, ny, tn, y, cy, G, JP_data, c_tmp1, c_tmp2);
njeP++;
if (retval < 0) {
cpProcessError(cp_mem, CPDIRECT_JACFUNC_UNRECVR, "CPDENSE", "cpDenseProjSetup", MSGD_JACFUNC_FAILED);
return(-1);
} else if (retval > 0) {
return(1);
}
/* Save Jacobian before factorization for possible use by lmultP */
DenseCopy(G, savedG);
/* Factorize G, depending on ftype */
switch (ftype) {
case CPDIRECT_LU:
/*
* LU factorization of G^T
*
* 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 1 if factorization failed.
*/
ier = DenseGETRF(G, pivotsP);
if (ier > 0) return(1);
/*
* 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++) {
for (i=nc-2; i>=0; i--) {
col_i = g_mat[i];
for (k=i+1; k<nc; k++) g_mat[i][j] -= col_i[k]*g_mat[k][j];
}
}
/*
* Build K = D1 + S^T * D2 * S
* Compute and store only the lower triangular part of K.
*/
if (pnorm == CP_PROJ_L2NORM) cpdLUcomputeKI(cp_mem);
else cpdLUcomputeKD(cp_mem, s_tmp1);
/*
* Perform Cholesky decomposition of K (in place, gaxpy version)
*
* K = C*C^T
*
* After factorization, the lower triangular part of K contains C.
*
* Return 1 if factorization failed.
*/
ier = DensePOTRF(K);
if (ier > 0) return(1);
break;
case CPDIRECT_QR:
/*
* Thin QR factorization of G^T
*
* G^T = Q * R
*
* After factorization, the upper trianguler 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.
*/
/* Use s_tmp1 as workspace */
s_tmpd = N_VGetArrayPointer(s_tmp1);
ier = DenseGEQRF(G, beta, s_tmpd);
/* If projecting in WRMS norm */
if (pnorm == CP_PROJ_ERRNORM) {
/* Build K = Q^T * D^(-1) * Q */
cpdQRcomputeKD(cp_mem, s_tmp1);
/* Perform Cholesky decomposition of K */
ier = DensePOTRF(K);
if (ier > 0) return(1);
}
break;
case CPDIRECT_SC:
/*
* Build K = G*D^(-1)*G^T
* Compute and store only the lower triangular part of K.
*/
if (pnorm == CP_PROJ_L2NORM) cpdSCcomputeKI(cp_mem);
else cpdSCcomputeKD(cp_mem, s_tmp1);
/*
* Perform Cholesky decomposition of K (in place, gaxpy version)
*
* K = C*C^T
*
* After factorization, the lower triangular part of K contains C.
*
* Return 1 if factorization failed.
*/
ier = DensePOTRF(K);
if (ier > 0) return(1);
break;
}
return(0);
}
static int cpDenseSetup(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)
{
booleantype jbad, jok;
realtype dgamma;
long int ier;
CPDlsMem cpdls_mem;
int retval;
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;
/* Test if it is enough to use a saved Jacobian copy */
if (jok) {
*jcurPtr = FALSE;
DenseCopy(savedJ, M);
} else {
nstlj = nst;
*jcurPtr = TRUE;
DenseZero(M);
retval = jacE(n, tn, yP, fctP, M, J_data, tmp1, tmp2, tmp3);
nje++;
if (retval < 0) {
cpProcessError(cp_mem, CPDIRECT_JACFUNC_UNRECVR, "CPDENSE", "cpDenseSetup", MSGD_JACFUNC_FAILED);
last_flag = CPDIRECT_JACFUNC_UNRECVR;
return(-1);
}
if (retval > 0) {
last_flag = CPDIRECT_JACFUNC_RECVR;
return(1);
}
DenseCopy(M, savedJ);
}
/* Scale and add I to get M = I - gamma*J */
DenseScale(-gamma, M);
DenseAddI(M);
break;
case CP_IMPL:
/* Initialize Jacobian to 0 and call Jacobian function */
DenseZero(M);
retval = jacI(n, tn, gamma, yP, ypP, fctP, M, J_data, tmp1, tmp2, tmp3);
nje++;
if (retval < 0) {
cpProcessError(cp_mem, CPDIRECT_JACFUNC_UNRECVR, "CPDENSE", "cpDenseSetup", MSGD_JACFUNC_FAILED);
last_flag = CPDIRECT_JACFUNC_UNRECVR;
return(-1);
}
if (retval > 0) {
last_flag = CPDIRECT_JACFUNC_RECVR;
return(1);
}
break;
}
/* Do LU factorization of M */
ier = DenseGETRF(M, pivots);
/* Return 0 if the LU was complete; otherwise return 1 */
last_flag = ier;
if (ier > 0) return(1);
return(0);
}
