/*-----------------------------------------------------------------
cvDlsDQJac
-----------------------------------------------------------------
This routine is a wrapper for the Dense and Band
implementations of the difference quotient Jacobian
approximation routines.
---------------------------------------------------------------*/
int cvDlsDQJac(realtype t, N_Vector y, N_Vector fy,
SUNMatrix Jac, void *cvode_mem, N_Vector tmp1,
N_Vector tmp2, N_Vector tmp3)
{
int retval;
CVodeMem cv_mem;
cv_mem = (CVodeMem) cvode_mem;
/* verify that Jac is non-NULL */
if (Jac == NULL) {
cvProcessError(cv_mem, CVDLS_LMEM_NULL, "CVDLS",
"cvDlsDQJac", MSGD_LMEM_NULL);
return(CVDLS_LMEM_NULL);
}
if (SUNMatGetID(Jac) == SUNMATRIX_DENSE) {
retval = cvDlsDenseDQJac(t, y, fy, Jac, cv_mem, tmp1);
} else if (SUNMatGetID(Jac) == SUNMATRIX_BAND) {
retval = cvDlsBandDQJac(t, y, fy, Jac, cv_mem, tmp1, tmp2);
} else if (SUNMatGetID(Jac) == SUNMATRIX_SPARSE) {
cvProcessError(cv_mem, CV_ILL_INPUT, "CVDLS",
"cvDlsDQJac",
"cvDlsDQJac not implemented for SUNMATRIX_SPARSE");
retval = CV_ILL_INPUT;
} else {
cvProcessError(cv_mem, CV_ILL_INPUT, "CVDLS",
"cvDlsDQJac",
"unrecognized matrix type for cvDlsDQJac");
retval = CV_ILL_INPUT;
}
return(retval);
}
sunindextype SUNBandMatrix_StoredUpperBandwidth(SUNMatrix A)
{
if (SUNMatGetID(A) == SUNMATRIX_BAND)
return SM_SUBAND_B(A);
else
return -1;
}
sunindextype SUNBandMatrix_LowerBandwidth(SUNMatrix A)
{
if (SUNMatGetID(A) == SUNMATRIX_BAND)
return SM_LBAND_B(A);
else
return -1;
}
sunindextype SUNBandMatrix_Columns(SUNMatrix A)
{
if (SUNMatGetID(A) == SUNMATRIX_BAND)
return SM_COLUMNS_B(A);
else
return -1;
}
sunindextype SUNBandMatrix_Rows(SUNMatrix A)
{
if (SUNMatGetID(A) == SUNMATRIX_BAND)
return SM_ROWS_B(A);
else
return -1;
}
void SUNBandMatrix_Print(SUNMatrix A, FILE* outfile)
{
sunindextype i, j, start, finish;
/* should not be called unless A is a band matrix;
otherwise return immediately */
if (SUNMatGetID(A) != SUNMATRIX_BAND)
return;
/* perform operation */
fprintf(outfile,"\n");
for (i=0; i<SM_ROWS_B(A); i++) {
start = SUNMAX(0, i-SM_LBAND_B(A));
finish = SUNMIN(SM_COLUMNS_B(A)-1, i+SM_UBAND_B(A));
for (j=0; j<start; j++)
fprintf(outfile,"%12s ","");
for (j=start; j<=finish; j++) {
#if defined(SUNDIALS_EXTENDED_PRECISION)
fprintf(outfile,"%12Lg ", SM_ELEMENT_B(A,i,j));
#elif defined(SUNDIALS_DOUBLE_PRECISION)
fprintf(outfile,"%12g ", SM_ELEMENT_B(A,i,j));
#else
fprintf(outfile,"%12g ", SM_ELEMENT_B(A,i,j));
#endif
}
fprintf(outfile,"\n");
}
fprintf(outfile,"\n");
return;
}
realtype* SUNBandMatrix_Column(SUNMatrix A, sunindextype j)
{
if (SUNMatGetID(A) == SUNMATRIX_BAND)
return SM_COLUMN_B(A,j);
else
return NULL;
}
realtype* SUNBandMatrix_Data(SUNMatrix A)
{
if (SUNMatGetID(A) == SUNMATRIX_BAND)
return SM_DATA_B(A);
else
return NULL;
}
sunindextype SUNBandMatrix_LDim(SUNMatrix A)
{
if (SUNMatGetID(A) == SUNMATRIX_BAND)
return SM_LDIM_B(A);
else
return -1;
}
/*-----------------------------------------------------------------
cvLsDQJac
This routine is a wrapper for the Dense and Band
implementations of the difference quotient Jacobian
approximation routines.
---------------------------------------------------------------*/
int cvLsDQJac(realtype t, N_Vector y, N_Vector fy,
SUNMatrix Jac, void *cvode_mem, N_Vector tmp1,
N_Vector tmp2, N_Vector tmp3)
{
CVodeMem cv_mem;
int retval;
/* access CVodeMem structure */
if (cvode_mem == NULL) {
cvProcessError(NULL, CVLS_MEM_NULL, "CVLS",
"cvLsDQJac", MSG_LS_CVMEM_NULL);
return(CVLS_MEM_NULL);
}
cv_mem = (CVodeMem) cvode_mem;
/* verify that Jac is non-NULL */
if (Jac == NULL) {
cvProcessError(cv_mem, CVLS_LMEM_NULL, "CVLS",
"cvLsDQJac", MSG_LS_LMEM_NULL);
return(CVLS_LMEM_NULL);
}
/* Verify that N_Vector supports required operations */
if (cv_mem->cv_tempv->ops->nvcloneempty == NULL ||
cv_mem->cv_tempv->ops->nvwrmsnorm == NULL ||
cv_mem->cv_tempv->ops->nvlinearsum == NULL ||
cv_mem->cv_tempv->ops->nvdestroy == NULL ||
cv_mem->cv_tempv->ops->nvscale == NULL ||
cv_mem->cv_tempv->ops->nvgetarraypointer == NULL ||
cv_mem->cv_tempv->ops->nvsetarraypointer == NULL) {
cvProcessError(cv_mem, CVLS_ILL_INPUT, "CVLS",
"cvLsDQJac", MSG_LS_BAD_NVECTOR);
return(CVLS_ILL_INPUT);
}
/* Call the matrix-structure-specific DQ approximation routine */
if (SUNMatGetID(Jac) == SUNMATRIX_DENSE) {
retval = cvLsDenseDQJac(t, y, fy, Jac, cv_mem, tmp1);
} else if (SUNMatGetID(Jac) == SUNMATRIX_BAND) {
retval = cvLsBandDQJac(t, y, fy, Jac, cv_mem, tmp1, tmp2);
} else {
cvProcessError(cv_mem, CVLS_ILL_INPUT, "CVLS", "cvLsDQJac",
"unrecognized matrix type for cvLsDQJac");
retval = CVLS_ILL_INPUT;
}
return(retval);
}
static booleantype SMCompatible_Band(SUNMatrix A, SUNMatrix B)
{
/* both matrices must be SUNMATRIX_BAND */
if (SUNMatGetID(A) != SUNMATRIX_BAND)
return SUNFALSE;
if (SUNMatGetID(B) != SUNMATRIX_BAND)
return SUNFALSE;
/* both matrices must have the same number of columns
(note that we do not check for identical bandwidth) */
if (SM_ROWS_B(A) != SM_ROWS_B(B))
return SUNFALSE;
if (SM_COLUMNS_B(A) != SM_COLUMNS_B(B))
return SUNFALSE;
return SUNTRUE;
}
int SUNMatZero_Band(SUNMatrix A)
{
sunindextype i;
realtype *Adata;
/* Verify that A is a band matrix */
if (SUNMatGetID(A) != SUNMATRIX_BAND)
return 1;
/* Perform operation */
Adata = SM_DATA_B(A);
for (i=0; i<SM_LDATA_B(A); i++)
Adata[i] = ZERO;
return 0;
}
static booleantype SMCompatible2_Band(SUNMatrix A, N_Vector x, N_Vector y)
{
/* matrix must be SUNMATRIX_BAND */
if (SUNMatGetID(A) != SUNMATRIX_BAND)
return SUNFALSE;
/* vectors must be one of {SERIAL, OPENMP, PTHREADS} */
if ( (N_VGetVectorID(x) != SUNDIALS_NVEC_SERIAL) &&
(N_VGetVectorID(x) != SUNDIALS_NVEC_OPENMP) &&
(N_VGetVectorID(x) != SUNDIALS_NVEC_PTHREADS) )
return SUNFALSE;
/* Optimally we would verify that the dimensions of A, x and y agree,
but since there is no generic 'length' routine for N_Vectors we cannot */
return SUNTRUE;
}
int SUNMatScaleAddI_Band(realtype c, SUNMatrix A)
{
sunindextype i, j;
realtype *A_colj;
/* Verify that A is a band matrix */
if (SUNMatGetID(A) != SUNMATRIX_BAND)
return 1;
/* Perform operation */
for (j=0; j<SM_COLUMNS_B(A); j++) {
A_colj = SM_COLUMN_B(A,j);
for (i=-SM_UBAND_B(A); i<=SM_LBAND_B(A); i++)
A_colj[i] *= c;
SM_ELEMENT_B(A,j,j) += ONE;
}
return 0;
}
int SUNLinSolSetup_LapackDense(SUNLinearSolver S, SUNMatrix A)
{
int n, ier;
/* check for valid inputs */
if ( (A == NULL) || (S == NULL) )
return(SUNLS_MEM_NULL);
/* Ensure that A is a dense matrix */
if (SUNMatGetID(A) != SUNMATRIX_DENSE) {
LASTFLAG(S) = SUNLS_ILL_INPUT;
return(LASTFLAG(S));
}
/* Call LAPACK to do LU factorization of A */
n = SUNDenseMatrix_Rows(A);
xgetrf_f77(&n, &n, SUNDenseMatrix_Data(A), &n, PIVOTS(S), &ier);
LASTFLAG(S) = (long int) ier;
if (ier > 0)
return(SUNLS_LUFACT_FAIL);
if (ier < 0)
return(SUNLS_PACKAGE_FAIL_UNREC);
return(SUNLS_SUCCESS);
}
/*-----------------------------------------------------------------
cvLsInitialize
This routine performs remaining initializations specific
to the iterative linear solver interface (and solver itself)
-----------------------------------------------------------------*/
int cvLsInitialize(CVodeMem cv_mem)
{
CVLsMem cvls_mem;
int retval;
/* access CVLsMem structure */
if (cv_mem->cv_lmem==NULL) {
cvProcessError(cv_mem, CVLS_LMEM_NULL, "CVLS",
"cvLsInitialize", MSG_LS_LMEM_NULL);
return(CVLS_LMEM_NULL);
}
cvls_mem = (CVLsMem) cv_mem->cv_lmem;
/* Test for valid combinations of matrix & Jacobian routines: */
if (cvls_mem->A == NULL) {
/* If SUNMatrix A is NULL: ensure 'jac' function pointer is NULL */
cvls_mem->jacDQ = SUNFALSE;
cvls_mem->jac = NULL;
cvls_mem->J_data = NULL;
} else if (cvls_mem->jacDQ) {
/* If A is non-NULL, and 'jac' is not user-supplied:
- if A is dense or band, ensure that our DQ approx. is used
- otherwise => error */
retval = 0;
if (cvls_mem->A->ops->getid) {
if ( (SUNMatGetID(cvls_mem->A) == SUNMATRIX_DENSE) ||
(SUNMatGetID(cvls_mem->A) == SUNMATRIX_BAND) ) {
cvls_mem->jac = cvLsDQJac;
cvls_mem->J_data = cv_mem;
} else {
retval++;
}
} else {
retval++;
}
if (retval) {
cvProcessError(cv_mem, CVLS_ILL_INPUT, "CVLS", "cvLsInitialize",
"No Jacobian constructor available for SUNMatrix type");
cvls_mem->last_flag = CVLS_ILL_INPUT;
return(CVLS_ILL_INPUT);
}
} else {
/* If A is non-NULL, and 'jac' is user-supplied,
reset J_data pointer (just in case) */
cvls_mem->J_data = cv_mem->cv_user_data;
}
/* reset counters */
cvLsInitializeCounters(cvls_mem);
/* Set Jacobian-related fields, based on jtimesDQ */
if (cvls_mem->jtimesDQ) {
cvls_mem->jtsetup = NULL;
cvls_mem->jtimes = cvLsDQJtimes;
cvls_mem->jt_data = cv_mem;
} else {
cvls_mem->jt_data = cv_mem->cv_user_data;
}
/* if A is NULL and psetup is not present, then cvLsSetup does
not need to be called, so set the lsetup function to NULL */
if ( (cvls_mem->A == NULL) && (cvls_mem->pset == NULL) )
cv_mem->cv_lsetup = NULL;
/* Call LS initialize routine, and return result */
cvls_mem->last_flag = SUNLinSolInitialize(cvls_mem->LS);
return(cvls_mem->last_flag);
}
/* ----------------------------------------------------------------------
* Check matrix
* --------------------------------------------------------------------*/
int check_matrix(SUNMatrix A, SUNMatrix B, realtype tol)
{
int failure = 0;
realtype *Adata, *Bdata;
sunindextype *Aindexptrs, *Bindexptrs;
sunindextype *Aindexvals, *Bindexvals;
sunindextype i, ANP, BNP, Annz, Bnnz;
/* get matrix pointers */
Adata = SUNSparseMatrix_Data(A);
Aindexptrs = SUNSparseMatrix_IndexPointers(A);
Aindexvals = SUNSparseMatrix_IndexValues(A);
ANP = SUNSparseMatrix_NP(A);
Annz = Aindexptrs[ANP];
Bdata = SUNSparseMatrix_Data(B);
Bindexptrs = SUNSparseMatrix_IndexPointers(B);
Bindexvals = SUNSparseMatrix_IndexValues(B);
BNP = SUNSparseMatrix_NP(B);
Bnnz = Bindexptrs[BNP];
/* matrices must have same sparsetype, shape and actual data lengths */
if (SUNMatGetID(A) != SUNMatGetID(B)) {
printf(">>> ERROR: check_matrix: Different storage types (%d vs %d)\n",
SUNMatGetID(A), SUNMatGetID(B));
return(1);
}
if (SUNSparseMatrix_SparseType(A) != SUNSparseMatrix_SparseType(B)) {
printf(">>> ERROR: check_matrix: Different storage types (%d vs %d)\n",
SUNSparseMatrix_SparseType(A), SUNSparseMatrix_SparseType(B));
return(1);
}
if (SUNSparseMatrix_Rows(A) != SUNSparseMatrix_Rows(B)) {
printf(">>> ERROR: check_matrix: Different numbers of rows (%ld vs %ld)\n",
(long int) SUNSparseMatrix_Rows(A), (long int) SUNSparseMatrix_Rows(B));
return(1);
}
if (SUNSparseMatrix_Columns(A) != SUNSparseMatrix_Columns(B)) {
printf(">>> ERROR: check_matrix: Different numbers of columns (%ld vs %ld)\n",
(long int) SUNSparseMatrix_Columns(A),
(long int) SUNSparseMatrix_Columns(B));
return(1);
}
if (Annz != Bnnz) {
printf(">>> ERROR: check_matrix: Different numbers of nonzeos (%ld vs %ld)\n",
(long int) Annz, (long int) Bnnz);
return(1);
}
/* compare sparsity patterns */
for (i=0; i<ANP; i++)
failure += (Aindexptrs[i] != Bindexptrs[i]);
if (failure > ZERO) {
printf(">>> ERROR: check_matrix: Different indexptrs \n");
return(1);
}
for (i=0; i<Annz; i++)
failure += (Aindexvals[i] != Bindexvals[i]);
if (failure > ZERO) {
printf(">>> ERROR: check_matrix: Different indexvals \n");
return(1);
}
/* compare matrix values */
for(i=0; i<Annz; i++)
failure += FNEQ(Adata[i], Bdata[i], tol);
if (failure > ZERO) {
printf(">>> ERROR: check_matrix: Different entries \n");
return(1);
}
return(0);
}
SUNLinearSolver SUNLinSol_LapackDense(N_Vector y, SUNMatrix A)
{
SUNLinearSolver S;
SUNLinearSolver_Ops ops;
SUNLinearSolverContent_LapackDense content;
sunindextype MatrixRows, VecLength;
/* Check compatibility with supplied SUNMatrix and N_Vector */
if (SUNMatGetID(A) != SUNMATRIX_DENSE)
return(NULL);
if (SUNDenseMatrix_Rows(A) != SUNDenseMatrix_Columns(A))
return(NULL);
MatrixRows = SUNDenseMatrix_Rows(A);
if ( (N_VGetVectorID(y) != SUNDIALS_NVEC_SERIAL) &&
(N_VGetVectorID(y) != SUNDIALS_NVEC_OPENMP) &&
(N_VGetVectorID(y) != SUNDIALS_NVEC_PTHREADS) )
return(NULL);
/* optimally this function would be replaced with a generic N_Vector routine */
VecLength = GlobalVectorLength_LapDense(y);
if (MatrixRows != VecLength)
return(NULL);
/* Create linear solver */
S = NULL;
S = (SUNLinearSolver) malloc(sizeof *S);
if (S == NULL) return(NULL);
/* Create linear solver operation structure */
ops = NULL;
ops = (SUNLinearSolver_Ops) malloc(sizeof(struct _generic_SUNLinearSolver_Ops));
if (ops == NULL) { free(S); return(NULL); }
/* Attach operations */
ops->gettype = SUNLinSolGetType_LapackDense;
ops->initialize = SUNLinSolInitialize_LapackDense;
ops->setup = SUNLinSolSetup_LapackDense;
ops->solve = SUNLinSolSolve_LapackDense;
ops->lastflag = SUNLinSolLastFlag_LapackDense;
ops->space = SUNLinSolSpace_LapackDense;
ops->free = SUNLinSolFree_LapackDense;
ops->setatimes = NULL;
ops->setpreconditioner = NULL;
ops->setscalingvectors = NULL;
ops->numiters = NULL;
ops->resnorm = NULL;
ops->resid = NULL;
/* Create content */
content = NULL;
content = (SUNLinearSolverContent_LapackDense)
malloc(sizeof(struct _SUNLinearSolverContent_LapackDense));
if (content == NULL) { free(ops); free(S); return(NULL); }
/* Fill content */
content->N = MatrixRows;
content->last_flag = 0;
content->pivots = NULL;
content->pivots = (sunindextype *) malloc(MatrixRows * sizeof(sunindextype));
if (content->pivots == NULL) {
free(content); free(ops); free(S); return(NULL);
}
/* Attach content and ops */
S->content = content;
S->ops = ops;
return(S);
}
