/***
KLU
***/
int KLU::Factor() {
int status;
int ndim;
_NRC = _nnz;
ndim = _dim;
memcpy(&_rows[0], _rows_ptr, _nnz*sizeof(int));
memcpy(&_cols[0], _cols_ptr, _nnz*sizeof(int));
memcpy(&_vals[0], _vals_ptr, _nnz*sizeof(double));
_Ap.size(_dim+1);
_Ai.size(_nnz);
_Ax.size(_nnz);
status = umfpack_di_triplet_to_col (ndim,ndim, _NRC, &_rows[0], &_cols[0], &_vals[0],
&_Ap[0], &_Ai[0], &_Ax[0], (int*)NULL) ;
if (status < 0 ) {
fprintf(stderr,"KLU: umfpack_di_triplet_to_col failed\n");
return (-1);
}
klu_common Common;
klu_defaults( &Common );
klu_numeric *Num;
if ( _Symbolic == NULL ) _Symbolic = (void*)klu_analyze(ndim, &_Ap[0], &_Ai[0], &Common);
if ( _Symbolic == NULL ) {
fprintf(stderr,"KLU: symbolic analysis failed\n");
return (-1);
}
if ( _Numeric ) {
Num = (klu_numeric*)_Numeric;
klu_free_numeric( &Num, &Common);
}
_Numeric = (void*)klu_factor(&_Ap[0], &_Ai[0], &_Ax[0], (klu_symbolic*)_Symbolic, &Common);
if ( _Numeric == NULL ) {
fprintf(stderr,"KLU: numeric factorization failed\n");
return (-1);
}
_is_factored = 1;
return 0;
}
/*! \fn free memory for linear system solver Klu
*
*/
int
freeKluData(void **voiddata)
{
TRACE_PUSH
DATA_KLU* data = (DATA_KLU*) *voiddata;
free(data->Ap);
free(data->Ai);
free(data->Ax);
free(data->work);
if(data->symbolic)
klu_free_symbolic(&data->symbolic, &data->common);
if(data->numeric)
klu_free_numeric(&data->numeric, &data->common);
TRACE_POP
return 0;
}
static int IDAKLUFree(IDAMem IDA_mem)
{
IDASlsMem idasls_mem;
KLUData klu_data;
idasls_mem = (IDASlsMem) IDA_mem->ida_lmem;
klu_data = (KLUData) idasls_mem->s_solver_data;
klu_free_numeric(&(klu_data->s_Numeric), &(klu_data->s_Common));
klu_free_symbolic(&(klu_data->s_Symbolic), &(klu_data->s_Common));
if (idasls_mem->s_JacMat) {
DestroySparseMat(idasls_mem->s_JacMat);
idasls_mem->s_JacMat = NULL;
}
free(klu_data);
free(IDA_mem->ida_lmem);
return(IDASLS_SUCCESS);
}
static int IDAKLUSetup(IDAMem IDA_mem, N_Vector yyp, N_Vector ypp,
N_Vector rrp, N_Vector tmp1, N_Vector tmp2,
N_Vector tmp3)
{
int retval;
realtype tn, cj;
IDASlsMem idasls_mem;
IDASlsSparseJacFn jaceval;
KLUData klu_data;
SlsMat JacMat;
void *jacdata;
realtype uround_twothirds;
uround_twothirds = SUNRpowerR(IDA_mem->ida_uround,TWOTHIRDS);
idasls_mem = (IDASlsMem) (IDA_mem->ida_lmem);
tn = IDA_mem->ida_tn;
cj = IDA_mem->ida_cj;
klu_data = (KLUData) idasls_mem->s_solver_data;
jaceval = idasls_mem->s_jaceval;
jacdata = idasls_mem->s_jacdata;
JacMat = idasls_mem->s_JacMat;
/* Check that Jacobian eval routine is set */
if (jaceval == NULL) {
IDAProcessError(IDA_mem, IDASLS_JAC_NOSET, "IDASLS", "IDAKLUSetup",
MSGSP_JAC_NOSET);
free(idasls_mem); idasls_mem = NULL;
return(IDASLS_JAC_NOSET);
}
/* Increment nje counter and call Jacobian eval routine. */
idasls_mem->s_nje++;
retval = jaceval(tn, cj, yyp, ypp, rrp, JacMat, jacdata,
tmp1, tmp2, tmp3);
if (retval < 0) {
IDAProcessError(IDA_mem, IDASLS_JACFUNC_UNRECVR, "IDASLS",
"IDAKLUSetup", MSGSP_JACFUNC_FAILED);
idasls_mem->s_last_flag = IDASLS_JACFUNC_UNRECVR;
return(IDASLS_JACFUNC_UNRECVR);
}
if (retval > 0) {
idasls_mem->s_last_flag = IDASLS_JACFUNC_RECVR;
return(+1);
}
if (idasls_mem->s_first_factorize) {
/* ------------------------------------------------------------
Get the symbolic factorization
------------------------------------------------------------*/
/* Update the ordering option with any user-updated values from
calls to IDAKLUSetOrdering */
klu_data->s_Common.ordering = klu_data->s_ordering;
klu_data->s_Symbolic = klu_analyze(JacMat->N, JacMat->colptrs,
JacMat->rowvals, &(klu_data->s_Common));
if (klu_data->s_Symbolic == NULL) {
IDAProcessError(IDA_mem, IDASLS_PACKAGE_FAIL, "IDASLS", "IDAKLUSetup",
MSGSP_PACKAGE_FAIL);
return(IDASLS_PACKAGE_FAIL);
}
/* ------------------------------------------------------------
Compute the LU factorization of the Jacobian.
------------------------------------------------------------*/
klu_data->s_Numeric = klu_factor(JacMat->colptrs, JacMat->rowvals, JacMat->data,
klu_data->s_Symbolic, &(klu_data->s_Common));
if (klu_data->s_Numeric == NULL) {
IDAProcessError(IDA_mem, IDASLS_PACKAGE_FAIL, "IDASLS", "IDAKLUSetup",
MSGSP_PACKAGE_FAIL);
return(IDASLS_PACKAGE_FAIL);
}
idasls_mem->s_first_factorize = 0;
}
else {
retval = klu_refactor(JacMat->colptrs, JacMat->rowvals, JacMat->data,
klu_data->s_Symbolic, klu_data->s_Numeric,
&(klu_data->s_Common));
if (retval == 0) {
IDAProcessError(IDA_mem, IDASLS_PACKAGE_FAIL, "IDASLS", "idaKLUSetup",
MSGSP_PACKAGE_FAIL);
return(IDASLS_PACKAGE_FAIL);
}
/*-----------------------------------------------------------
Check if a cheap estimate of the reciprocal of the condition
number is getting too small. If so, delete
the prior numeric factorization and recompute it.
-----------------------------------------------------------*/
retval = klu_rcond(klu_data->s_Symbolic, klu_data->s_Numeric,
&(klu_data->s_Common));
if (retval == 0) {
IDAProcessError(IDA_mem, IDASLS_PACKAGE_FAIL, "IDASLS", "idaKLUSetup",
MSGSP_PACKAGE_FAIL);
return(IDASLS_PACKAGE_FAIL);
}
if ( (klu_data->s_Common.rcond) < uround_twothirds ) {
/* Condition number may be getting large.
Compute more accurate estimate */
retval = klu_condest(JacMat->colptrs, JacMat->data,
klu_data->s_Symbolic, klu_data->s_Numeric,
&(klu_data->s_Common));
if (retval == 0) {
IDAProcessError(IDA_mem, IDASLS_PACKAGE_FAIL, "IDASLS", "idaKLUSetup",
MSGSP_PACKAGE_FAIL);
return(IDASLS_PACKAGE_FAIL);
}
if ( (klu_data->s_Common.condest) >
(1.0/uround_twothirds) ) {
/* More accurate estimate also says condition number is
large, so recompute the numeric factorization */
klu_free_numeric(&(klu_data->s_Numeric), &(klu_data->s_Common));
klu_data->s_Numeric = klu_factor(JacMat->colptrs, JacMat->rowvals,
JacMat->data, klu_data->s_Symbolic,
&(klu_data->s_Common));
if (klu_data->s_Numeric == NULL) {
IDAProcessError(IDA_mem, IDASLS_PACKAGE_FAIL, "IDASLS",
"IDAKLUSetup", MSGSP_PACKAGE_FAIL);
return(IDASLS_PACKAGE_FAIL);
}
}
}
}
idasls_mem->s_last_flag = IDASLS_SUCCESS;
return(0);
}
int IDAKLUReInit(void *ida_mem_v, int n, int nnz, int reinit_type)
{
IDAMem ida_mem;
IDASlsMem idasls_mem;
KLUData klu_data;
SlsMat JacMat;
/* Return immediately if ida_mem is NULL. */
if (ida_mem_v == NULL) {
IDAProcessError(NULL, IDASLS_MEM_NULL, "IDASLS", "IDAKLUReInit",
MSGSP_IDAMEM_NULL);
return(IDASLS_MEM_NULL);
}
ida_mem = (IDAMem) ida_mem_v;
/* Return immediately if ark_lmem is NULL. */
if (ida_mem->ida_lmem == NULL) {
IDAProcessError(NULL, IDASLS_LMEM_NULL, "IDASLS", "IDAKLUReInit",
MSGSP_LMEM_NULL);
return(IDASLS_LMEM_NULL);
}
idasls_mem = (IDASlsMem) (ida_mem->ida_lmem);
klu_data = (KLUData) idasls_mem->s_solver_data;
/* Return if reinit_type is not valid */
if ((reinit_type != 1) && (reinit_type != 2)) {
IDAProcessError(NULL, IDASLS_ILL_INPUT, "IDASLS", "IDAKLUReInit",
MSGSP_ILL_INPUT);
return(IDASLS_ILL_INPUT);
}
JacMat = idasls_mem->s_JacMat;
if (reinit_type == 1) {
/* Destroy previous Jacobian information */
if (idasls_mem->s_JacMat) {
DestroySparseMat(idasls_mem->s_JacMat);
}
/* Allocate memory for the sparse Jacobian */
idasls_mem->s_JacMat = NewSparseMat(n, n, nnz);
if (idasls_mem->s_JacMat == NULL) {
IDAProcessError(ida_mem, IDASLS_MEM_FAIL, "IDASLS", "IDAKLU",
MSGSP_MEM_FAIL);
return(IDASLS_MEM_FAIL);
}
}
/* Free the prior factorazation and reset for first factorization */
if( klu_data->s_Symbolic != NULL)
klu_free_symbolic(&(klu_data->s_Symbolic), &(klu_data->s_Common));
if( klu_data->s_Numeric != NULL)
klu_free_numeric(&(klu_data->s_Numeric), &(klu_data->s_Common));
idasls_mem->s_first_factorize = 1;
idasls_mem->s_last_flag = IDASLS_SUCCESS;
return(0);
}
/*---------------------------------------------------------------
arkMassKLUSetup:
This routine does the setup operations for the ARKMassKLU
linear solver module. It calls the mass matrix evaluation
routine, updates counters, and calls the LU factorization
routine. The return value is either
ARkSLS_SUCCESS = 0 if successful,
+1 if the Meval routine failed recoverably or the
LU factorization failed, or
-1 if the Meval routine failed unrecoverably.
---------------------------------------------------------------*/
static int arkMassKLUSetup(ARKodeMem ark_mem, N_Vector vtemp1,
N_Vector vtemp2, N_Vector vtemp3)
{
ARKSlsMassMem arksls_mem;
KLUData klu_data;
int retval;
realtype uround_twothirds;
uround_twothirds = SUNRpowerR(ark_mem->ark_uround,TWOTHIRDS);
arksls_mem = (ARKSlsMassMem) ark_mem->ark_mass_mem;
klu_data = (KLUData) arksls_mem->s_solver_data;
/* Check that mass matrix eval routine is set */
if (arksls_mem->s_Meval == NULL) {
arkProcessError(ark_mem, ARKSLS_MASS_NOSET, "ARKSLS",
"arkMassKLUSetup", MSGSP_MASS_NOSET);
free(arksls_mem); arksls_mem = NULL;
return(ARKSLS_MASS_NOSET);
}
/* call Meval routine for new M matrix */
SparseSetMatToZero(arksls_mem->s_M);
retval = arksls_mem->s_Meval(ark_mem->ark_tn, arksls_mem->s_M,
arksls_mem->s_Mdata, vtemp1,
vtemp2, vtemp3);
arksls_mem->s_nme++;
if (retval < 0) {
arkProcessError(ark_mem, ARKSLS_MASSFUNC_UNRECVR, "ARKSLS",
"arkMassKLUSetup", MSGSP_MASSFUNC_FAILED);
arksls_mem->s_last_flag = ARKSLS_MASSFUNC_UNRECVR;
return(-1);
}
if (retval > 0) {
arksls_mem->s_last_flag = ARKSLS_MASSFUNC_RECVR;
return(1);
}
/* Copy M into M_lu for LU decomposition */
SparseCopyMat(arksls_mem->s_M, arksls_mem->s_M_lu);
/* On first decomposition, get the symbolic factorization */
if (arksls_mem->s_first_factorize) {
/* Update the ordering option with user-updated values */
klu_data->s_Common.ordering = klu_data->s_ordering;
/* Perform symbolic analysis of sparsity structure */
if (klu_data->s_Symbolic != NULL) {
klu_free_symbolic(&(klu_data->s_Symbolic), &(klu_data->s_Common));
}
klu_data->s_Symbolic = klu_analyze(arksls_mem->s_M_lu->N,
arksls_mem->s_M_lu->indexptrs,
arksls_mem->s_M_lu->indexvals,
&(klu_data->s_Common));
if (klu_data->s_Symbolic == NULL) {
arkProcessError(ark_mem, ARKSLS_PACKAGE_FAIL, "ARKSLS",
"ARKMassKLUSetup", MSGSP_PACKAGE_FAIL);
return(ARKSLS_PACKAGE_FAIL);
}
/* ------------------------------------------------------------
Compute the LU factorization of the Jacobian.
------------------------------------------------------------*/
if( klu_data->s_Numeric != NULL) {
klu_free_numeric(&(klu_data->s_Numeric), &(klu_data->s_Common));
}
klu_data->s_Numeric = klu_factor(arksls_mem->s_M_lu->indexptrs,
arksls_mem->s_M_lu->indexvals,
arksls_mem->s_M_lu->data,
klu_data->s_Symbolic,
&(klu_data->s_Common));
if (klu_data->s_Numeric == NULL) {
arkProcessError(ark_mem, ARKSLS_PACKAGE_FAIL, "ARKSLS",
"ARKMassKLUSetup", MSGSP_PACKAGE_FAIL);
return(ARKSLS_PACKAGE_FAIL);
}
arksls_mem->s_first_factorize = 0;
}
else {
retval = klu_refactor(arksls_mem->s_M_lu->indexptrs,
arksls_mem->s_M_lu->indexvals,
arksls_mem->s_M_lu->data,
klu_data->s_Symbolic, klu_data->s_Numeric,
&(klu_data->s_Common));
if (retval == 0) {
arkProcessError(ark_mem, ARKSLS_PACKAGE_FAIL, "ARKSLS",
"ARKMassKLUSetup", MSGSP_PACKAGE_FAIL);
return(ARKSLS_PACKAGE_FAIL);
}
/*-----------------------------------------------------------
Check if a cheap estimate of the reciprocal of the condition
number is getting too small. If so, delete
the prior numeric factorization and recompute it.
-----------------------------------------------------------*/
retval = klu_rcond(klu_data->s_Symbolic, klu_data->s_Numeric,
&(klu_data->s_Common));
if (retval == 0) {
arkProcessError(ark_mem, ARKSLS_PACKAGE_FAIL, "ARKSLS",
"ARKMassKLUSetup", MSGSP_PACKAGE_FAIL);
return(ARKSLS_PACKAGE_FAIL);
}
if ( (klu_data->s_Common.rcond) < uround_twothirds ) {
/* Condition number may be getting large.
Compute more accurate estimate */
retval = klu_condest(arksls_mem->s_M_lu->indexptrs,
arksls_mem->s_M_lu->data,
klu_data->s_Symbolic, klu_data->s_Numeric,
&(klu_data->s_Common));
if (retval == 0) {
arkProcessError(ark_mem, ARKSLS_PACKAGE_FAIL, "ARKSLS",
"ARKMassKLUSetup", MSGSP_PACKAGE_FAIL);
return(ARKSLS_PACKAGE_FAIL);
}
if ( (klu_data->s_Common.condest) >
(1.0/uround_twothirds) ) {
/* More accurate estimate also says condition number is
large, so recompute the numeric factorization */
klu_free_numeric(&(klu_data->s_Numeric), &(klu_data->s_Common));
klu_data->s_Numeric = klu_factor(arksls_mem->s_M_lu->indexptrs,
arksls_mem->s_M_lu->indexvals,
arksls_mem->s_M_lu->data,
klu_data->s_Symbolic,
&(klu_data->s_Common));
if (klu_data->s_Numeric == NULL) {
arkProcessError(ark_mem, ARKSLS_PACKAGE_FAIL, "ARKSLS",
"ARKMassKLUSetup", MSGSP_PACKAGE_FAIL);
return(ARKSLS_PACKAGE_FAIL);
}
}
}
}
arksls_mem->s_last_flag = ARKSLS_SUCCESS;
return(0);
}
/*---------------------------------------------------------------
ARKKLU
This routine initializes the memory record and sets various
function fields specific to the ARKode / KLU linear solver
module. ARKKLU first calls the existing lfree routine if this
is not NULL. Then it sets the ark_linit, ark_lsetup, ark_lsolve
and ark_lfree fields in (*arkode_mem) to be arkKLUInit,
arkKLUSetup, arkKLUSolve and arkKLUFree, respectively. It
allocates memory for a structure of type ARKSlsMemRec and sets
the ark_lmem field in (*arkode_mem) to the address of this
structure. It sets setupNonNull in (*arkode_mem) to TRUE.
Finally, it allocates memory for KLU. The return value is
ARKSLS_SUCCESS = 0, ARKSLS_LMEM_FAIL = -1, or
ARKSLS_ILL_INPUT = -2.
NOTE: The KLU linear solver assumes a serial implementation
of the NVECTOR package. Therefore, ARKKLU will first
test for a compatible N_Vector internal representation
by checking that the function N_VGetArrayPointer exists.
---------------------------------------------------------------*/
int ARKKLU(void *arkode_mem, int n, int nnz, int sparsetype)
{
ARKodeMem ark_mem;
ARKSlsMem arksls_mem;
KLUData klu_data;
int flag;
/* Return immediately if ark_mem is NULL. */
if (arkode_mem == NULL) {
arkProcessError(NULL, ARKSLS_MEM_NULL, "ARKSLS",
"ARKKLU", MSGSP_ARKMEM_NULL);
return(ARKSLS_MEM_NULL);
}
ark_mem = (ARKodeMem) arkode_mem;
/* Test if the NVECTOR package is compatible with the solver */
if (ark_mem->ark_tempv->ops->nvgetarraypointer == NULL) {
arkProcessError(ark_mem, ARKSLS_ILL_INPUT, "ARKSLS",
"ARKKLU", MSGSP_BAD_NVECTOR);
return(ARKSLS_ILL_INPUT);
}
if (ark_mem->ark_lfree != NULL) ark_mem->ark_lfree(ark_mem);
/* Set four main function fields in ark_mem. */
ark_mem->ark_linit = arkKLUInit;
ark_mem->ark_lsetup = arkKLUSetup;
ark_mem->ark_lsolve = arkKLUSolve;
ark_mem->ark_lfree = arkKLUFree;
ark_mem->ark_lsolve_type = 3;
/* Get memory for ARKSlsMemRec. */
arksls_mem = (ARKSlsMem) malloc(sizeof(struct ARKSlsMemRec));
if (arksls_mem == NULL) {
arkProcessError(ark_mem, ARKSLS_MEM_FAIL, "ARKSLS",
"ARKKLU", MSGSP_MEM_FAIL);
return(ARKSLS_MEM_FAIL);
}
/* Get memory for KLUData. */
klu_data = (KLUData) malloc(sizeof(struct KLUDataRec));
if (klu_data == NULL) {
arkProcessError(ark_mem, ARKSLS_MEM_FAIL, "ARKSLS",
"ARKKLU", MSGSP_MEM_FAIL);
free(arksls_mem); arksls_mem = NULL;
return(ARKSLS_MEM_FAIL);
}
/* Initialize Jacobian-related data */
arksls_mem->s_Jeval = NULL;
arksls_mem->s_Jdata = NULL;
ark_mem->ark_setupNonNull = TRUE;
arksls_mem->sparsetype = sparsetype;
/* Initialize counters */
arksls_mem->s_nje = 0;
arksls_mem->s_first_factorize = 1;
arksls_mem->s_nstlj = 0;
/* Allocate memory for the sparse Jacobian */
arksls_mem->s_A = NULL;
arksls_mem->s_A = SparseNewMat(n, n, nnz, sparsetype);
if (arksls_mem->s_A == NULL) {
arkProcessError(ark_mem, ARKSLS_MEM_FAIL, "ARKSLS",
"ARKKLU", MSGSP_MEM_FAIL);
free(klu_data); klu_data = NULL;
free(arksls_mem); arksls_mem = NULL;
return(ARKSLS_MEM_FAIL);
}
/* Allocate memory for saved sparse Jacobian */
arksls_mem->s_savedJ = NULL;
arksls_mem->s_savedJ = SparseNewMat(n, n, nnz, sparsetype);
if (arksls_mem->s_savedJ == NULL) {
arkProcessError(ark_mem, ARKSLS_MEM_FAIL, "ARKSLS",
"ARKKLU", MSGSP_MEM_FAIL);
SparseDestroyMat(arksls_mem->s_A);
free(klu_data); klu_data = NULL;
free(arksls_mem); arksls_mem = NULL;
return(ARKSLS_MEM_FAIL);
}
/* Initialize KLU structures */
switch (sparsetype) {
case CSC_MAT:
klu_data->sun_klu_solve = &klu_solve;
break;
case CSR_MAT:
klu_data->sun_klu_solve = &klu_tsolve;
break;
default:
SparseDestroyMat(arksls_mem->s_A);
SparseDestroyMat(arksls_mem->s_savedJ);
free(klu_data); klu_data = NULL;
free(arksls_mem); arksls_mem = NULL;
return(ARKSLS_ILL_INPUT);
}
klu_data->s_Symbolic = NULL;
klu_data->s_Numeric = NULL;
/* Set default parameters for KLU */
flag = klu_defaults(&klu_data->s_Common);
if (flag == 0) {
arkProcessError(ark_mem, ARKSLS_MEM_FAIL, "ARKSLS",
"ARKKLU", MSGSP_MEM_FAIL);
klu_free_numeric(&(klu_data->s_Numeric), &(klu_data->s_Common));
free(klu_data->s_Numeric); klu_data->s_Numeric = NULL;
klu_free_symbolic(&(klu_data->s_Symbolic), &(klu_data->s_Common));
free(klu_data->s_Symbolic); klu_data->s_Symbolic = NULL;
SparseDestroyMat(arksls_mem->s_A);
SparseDestroyMat(arksls_mem->s_savedJ);
free(klu_data); klu_data = NULL;
free(arksls_mem); arksls_mem = NULL;
return(ARKSLS_MEM_FAIL);
}
/* Set ordering to COLAMD as the arkode default use.
Users can set a different value with ARKKLUSetOrdering,
and the user-set value is loaded before any call to klu_analyze in
ARKKLUSetup. */
klu_data->s_ordering = 1;
klu_data->s_Common.ordering = klu_data->s_ordering;
/* Attach linear solver memory to the integrator memory */
arksls_mem->s_solver_data = (void *) klu_data;
ark_mem->ark_lmem = arksls_mem;
arksls_mem->s_last_flag = ARKSLS_SUCCESS;
return(ARKSLS_SUCCESS);
}
/*---------------------------------------------------------------
arkKLUSetup:
This routine does the setup operations for the ARKKLU linear
solver module. It calls the Jacobian evaluation routine,
updates counters, and calls the LU factorization routine.
The return value is either
ARKSLS_SUCCESS = 0 if successful,
+1 if the jac routine failed recoverably or the
LU factorization failed, or
-1 if the jac routine failed unrecoverably.
---------------------------------------------------------------*/
static int arkKLUSetup(ARKodeMem ark_mem, int convfail,
N_Vector ypred, N_Vector fpred,
booleantype *jcurPtr, N_Vector vtemp1,
N_Vector vtemp2, N_Vector vtemp3)
{
booleantype jbad, jok;
realtype dgamma;
ARKSlsMem arksls_mem;
ARKSlsMassMem arksls_mass_mem;
KLUData klu_data;
int retval;
realtype uround_twothirds;
uround_twothirds = SUNRpowerR(ark_mem->ark_uround,TWOTHIRDS);
arksls_mem = (ARKSlsMem) ark_mem->ark_lmem;
klu_data = (KLUData) arksls_mem->s_solver_data;
/* Check that Jacobian eval routine is set */
if (arksls_mem->s_Jeval == NULL) {
arkProcessError(ark_mem, ARKSLS_JAC_NOSET, "ARKSLS",
"arkKLUSetup", MSGSP_JAC_NOSET);
free(arksls_mem); arksls_mem = NULL;
return(ARKSLS_JAC_NOSET);
}
/* 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 > arksls_mem->s_nstlj + ARKS_MSBJ) ||
((convfail == ARK_FAIL_BAD_J) && (dgamma < ARKS_DGMAX)) ||
(convfail == ARK_FAIL_OTHER);
jok = !jbad;
/* If jok = TRUE, use saved copy of J */
if (jok) {
*jcurPtr = FALSE;
SparseCopyMat(arksls_mem->s_savedJ, arksls_mem->s_A);
/* If jok = FALSE, call jac routine for new J value */
} else {
arksls_mem->s_nje++;
arksls_mem->s_nstlj = ark_mem->ark_nst;
*jcurPtr = TRUE;
SparseSetMatToZero(arksls_mem->s_A);
retval = arksls_mem->s_Jeval(ark_mem->ark_tn, ypred, fpred,
arksls_mem->s_A, arksls_mem->s_Jdata,
vtemp1, vtemp2, vtemp3);
if (retval < 0) {
arkProcessError(ark_mem, ARKSLS_JACFUNC_UNRECVR, "ARKSLS",
"arkKLUSetup", MSGSP_JACFUNC_FAILED);
arksls_mem->s_last_flag = ARKSLS_JACFUNC_UNRECVR;
return(-1);
}
if (retval > 0) {
arksls_mem->s_last_flag = ARKSLS_JACFUNC_RECVR;
return(1);
}
SparseCopyMat(arksls_mem->s_A, arksls_mem->s_savedJ);
}
/* Scale J by -gamma */
SparseScaleMat(-ark_mem->ark_gamma, arksls_mem->s_A);
/* Add mass matrix to get A = M-gamma*J */
if (ark_mem->ark_mass_matrix) {
/* Compute mass matrix */
arksls_mass_mem = (ARKSlsMassMem) ark_mem->ark_mass_mem;
SparseSetMatToZero(arksls_mass_mem->s_M);
retval = arksls_mass_mem->s_Meval(ark_mem->ark_tn,
arksls_mass_mem->s_M,
arksls_mass_mem->s_Mdata,
vtemp1, vtemp2, vtemp3);
arksls_mass_mem->s_nme++;
if (retval < 0) {
arkProcessError(ark_mem, ARKSLS_MASSFUNC_UNRECVR, "ARKSLS",
"arkKLUSetup", MSGSP_MASSFUNC_FAILED);
arksls_mem->s_last_flag = ARKSLS_MASSFUNC_UNRECVR;
return(-1);
}
if (retval > 0) {
arksls_mem->s_last_flag = ARKSLS_MASSFUNC_RECVR;
return(1);
}
/* add to A */
retval = SparseAddMat(arksls_mem->s_A, arksls_mass_mem->s_M);
if (retval < 0) {
arkProcessError(ark_mem, ARKSLS_PACKAGE_FAIL, "ARKSLS",
"arkKLUSetup", "Error in adding mass matrix to Jacobian");
arksls_mem->s_last_flag = ARKSLS_PACKAGE_FAIL;
return(retval);
}
if (retval > 0) return(retval);
} else {
SparseAddIdentityMat(arksls_mem->s_A);
}
/* On first decomposition, get the symbolic factorization */
if (arksls_mem->s_first_factorize) {
/* Update the ordering option with user-updated values */
klu_data->s_Common.ordering = klu_data->s_ordering;
/* Perform symbolic analysis of sparsity structure */
if (klu_data->s_Symbolic != NULL) {
klu_free_symbolic(&(klu_data->s_Symbolic), &(klu_data->s_Common));
}
klu_data->s_Symbolic = klu_analyze(arksls_mem->s_A->NP,
arksls_mem->s_A->indexptrs,
arksls_mem->s_A->indexvals,
&(klu_data->s_Common));
if (klu_data->s_Symbolic == NULL) {
arkProcessError(ark_mem, ARKSLS_PACKAGE_FAIL, "ARKSLS",
"ARKKLUSetup", MSGSP_PACKAGE_FAIL);
return(ARKSLS_PACKAGE_FAIL);
}
/* ------------------------------------------------------------
Compute the LU factorization of the Jacobian.
------------------------------------------------------------*/
if( klu_data->s_Numeric != NULL) {
klu_free_numeric(&(klu_data->s_Numeric), &(klu_data->s_Common));
}
klu_data->s_Numeric = klu_factor(arksls_mem->s_A->indexptrs,
arksls_mem->s_A->indexvals,
arksls_mem->s_A->data,
klu_data->s_Symbolic,
&(klu_data->s_Common));
if (klu_data->s_Numeric == NULL) {
arkProcessError(ark_mem, ARKSLS_PACKAGE_FAIL, "ARKSLS",
"ARKKLUSetup", MSGSP_PACKAGE_FAIL);
return(ARKSLS_PACKAGE_FAIL);
}
arksls_mem->s_first_factorize = 0;
}
else {
retval = klu_refactor(arksls_mem->s_A->indexptrs,
arksls_mem->s_A->indexvals,
arksls_mem->s_A->data,
klu_data->s_Symbolic, klu_data->s_Numeric,
&(klu_data->s_Common));
if (retval == 0) {
arkProcessError(ark_mem, ARKSLS_PACKAGE_FAIL, "ARKSLS",
"ARKKLUSetup", MSGSP_PACKAGE_FAIL);
return(ARKSLS_PACKAGE_FAIL);
}
/*-----------------------------------------------------------
Check if a cheap estimate of the reciprocal of the condition
number is getting too small. If so, delete
the prior numeric factorization and recompute it.
-----------------------------------------------------------*/
retval = klu_rcond(klu_data->s_Symbolic, klu_data->s_Numeric,
&(klu_data->s_Common));
if (retval == 0) {
arkProcessError(ark_mem, ARKSLS_PACKAGE_FAIL, "ARKSLS",
"ARKKLUSetup", MSGSP_PACKAGE_FAIL);
return(ARKSLS_PACKAGE_FAIL);
}
if ( (klu_data->s_Common.rcond) < uround_twothirds ) {
/* Condition number may be getting large.
Compute more accurate estimate */
retval = klu_condest(arksls_mem->s_A->indexptrs,
arksls_mem->s_A->data,
klu_data->s_Symbolic, klu_data->s_Numeric,
&(klu_data->s_Common));
if (retval == 0) {
arkProcessError(ark_mem, ARKSLS_PACKAGE_FAIL, "ARKSLS",
"ARKKLUSetup", MSGSP_PACKAGE_FAIL);
return(ARKSLS_PACKAGE_FAIL);
}
if ( (klu_data->s_Common.condest) >
(1.0/uround_twothirds) ) {
/* More accurate estimate also says condition number is
large, so recompute the numeric factorization */
klu_free_numeric(&(klu_data->s_Numeric), &(klu_data->s_Common));
klu_data->s_Numeric = klu_factor(arksls_mem->s_A->indexptrs,
arksls_mem->s_A->indexvals,
arksls_mem->s_A->data,
klu_data->s_Symbolic,
&(klu_data->s_Common));
if (klu_data->s_Numeric == NULL) {
arkProcessError(ark_mem, ARKSLS_PACKAGE_FAIL, "ARKSLS",
"ARKKLUSetup", MSGSP_PACKAGE_FAIL);
return(ARKSLS_PACKAGE_FAIL);
}
}
}
}
arksls_mem->s_last_flag = ARKSLS_SUCCESS;
return(0);
}
static int cvKLUSetup(CVodeMem cv_mem, int convfail, N_Vector ypred,
N_Vector fpred, booleantype *jcurPtr,
N_Vector vtemp1, N_Vector vtemp2, N_Vector vtemp3)
{
booleantype jbad, jok;
int retval;
long int nst, nstlj;
realtype tn, gamma, gammap, dgamma;
CVSlsMem cvsls_mem;
CVSlsSparseJacFn jaceval;
KLUData klu_data;
SlsMat JacMat, savedJ;
void *jacdata;
realtype uround_twothirds;
uround_twothirds = SUNRpowerR(cv_mem->cv_uround,TWOTHIRDS);
cvsls_mem = (CVSlsMem) (cv_mem->cv_lmem);
tn = cv_mem->cv_tn;
gamma = cv_mem->cv_gamma;
gammap = cv_mem->cv_gammap;
nst = cv_mem->cv_nst;
klu_data = (KLUData) cvsls_mem->s_solver_data;
jaceval = cvsls_mem->s_jaceval;
jacdata = cvsls_mem->s_jacdata;
JacMat = cvsls_mem->s_JacMat;
savedJ = cvsls_mem->s_savedJ;
nstlj = cvsls_mem->s_nstlj;
/* Check that Jacobian eval routine is set */
if (jaceval == NULL) {
cvProcessError(cv_mem, CVSLS_JAC_NOSET, "CVSLS", "cvKLUSetup",
MSGSP_JAC_NOSET);
free(cvsls_mem); cvsls_mem = NULL;
return(CVSLS_JAC_NOSET);
}
/* Determine whether Jacobian needs to be recalculated */
dgamma = SUNRabs((gamma/gammap) - ONE);
jbad = (nst == 0) || (nst > nstlj + CVS_MSBJ) ||
((convfail == CV_FAIL_BAD_J) && (dgamma < CVS_DGMAX)) ||
(convfail == CV_FAIL_OTHER);
jok = !jbad;
if (jok) {
/* If jok = TRUE, use saved copy of J */
*jcurPtr = FALSE;
SparseCopyMat(savedJ, JacMat);
} else {
/* If jok = FALSE, call jac routine for new J value */
cvsls_mem->s_nje++;
cvsls_mem->s_nstlj = nst;
*jcurPtr = TRUE;
SparseSetMatToZero(JacMat);
retval = jaceval(tn, ypred, fpred, JacMat, jacdata, vtemp1, vtemp2, vtemp3);
if (retval < 0) {
cvProcessError(cv_mem, CVSLS_JACFUNC_UNRECVR, "CVSLS", "cvKLUSetup", MSGSP_JACFUNC_FAILED);
cvsls_mem->s_last_flag = CVSLS_JACFUNC_UNRECVR;
return(-1);
}
if (retval > 0) {
cvsls_mem->s_last_flag = CVSLS_JACFUNC_RECVR;
return(1);
}
SparseCopyMat(JacMat, savedJ);
}
/* Scale and add I to get M = I - gamma*J */
SparseScaleMat(-gamma, JacMat);
SparseAddIdentityMat(JacMat);
if (cvsls_mem->s_first_factorize) {
/* ------------------------------------------------------------
Get the symbolic factorization
------------------------------------------------------------*/
/* Update the ordering option with any user-updated values from
calls to CVKLUSetOrdering */
klu_data->s_Common.ordering = klu_data->s_ordering;
if (klu_data->s_Symbolic != NULL) {
klu_free_symbolic(&(klu_data->s_Symbolic), &(klu_data->s_Common));
}
klu_data->s_Symbolic = klu_analyze(JacMat->NP, JacMat->indexptrs,
JacMat->indexvals, &(klu_data->s_Common));
if (klu_data->s_Symbolic == NULL) {
cvProcessError(cv_mem, CVSLS_PACKAGE_FAIL, "CVSLS", "CVKLUSetup",
MSGSP_PACKAGE_FAIL);
return(CVSLS_PACKAGE_FAIL);
}
/* ------------------------------------------------------------
Compute the LU factorization of the Jacobian.
------------------------------------------------------------*/
/* If klu_factor previously called, free data */
if( klu_data->s_Numeric != NULL) {
klu_free_numeric(&(klu_data->s_Numeric), &(klu_data->s_Common));
}
klu_data->s_Numeric = klu_factor(JacMat->indexptrs, JacMat->indexvals,
JacMat->data,
klu_data->s_Symbolic, &(klu_data->s_Common));
if (klu_data->s_Numeric == NULL) {
cvProcessError(cv_mem, CVSLS_PACKAGE_FAIL, "CVSLS", "CVKLUSetup",
MSGSP_PACKAGE_FAIL);
return(CVSLS_PACKAGE_FAIL);
}
cvsls_mem->s_first_factorize = 0;
}
else {
retval = klu_refactor(JacMat->indexptrs, JacMat->indexvals, JacMat->data,
klu_data->s_Symbolic, klu_data->s_Numeric,
&(klu_data->s_Common));
if (retval == 0) {
cvProcessError(cv_mem, CVSLS_PACKAGE_FAIL, "CVSLS", "cvKLUSetup",
MSGSP_PACKAGE_FAIL);
return(CVSLS_PACKAGE_FAIL);
}
/*-----------------------------------------------------------
Check if a cheap estimate of the reciprocal of the condition
number is getting too small. If so, delete
the prior numeric factorization and recompute it.
-----------------------------------------------------------*/
retval = klu_rcond(klu_data->s_Symbolic, klu_data->s_Numeric,
&(klu_data->s_Common));
if (retval == 0) {
cvProcessError(cv_mem, CVSLS_PACKAGE_FAIL, "CVSLS", "CVKLUSetup",
MSGSP_PACKAGE_FAIL);
return(CVSLS_PACKAGE_FAIL);
}
if ( (klu_data->s_Common.rcond) < uround_twothirds ) {
/* Condition number may be getting large.
Compute more accurate estimate */
retval = klu_condest(JacMat->indexptrs, JacMat->data,
klu_data->s_Symbolic, klu_data->s_Numeric,
&(klu_data->s_Common));
if (retval == 0) {
cvProcessError(cv_mem, CVSLS_PACKAGE_FAIL, "CVSLS", "CVKLUSetup",
MSGSP_PACKAGE_FAIL);
return(CVSLS_PACKAGE_FAIL);
}
if ( (klu_data->s_Common.condest) >
(1.0/uround_twothirds) ) {
/* More accurate estimate also says condition number is
large, so recompute the numeric factorization */
klu_free_numeric(&(klu_data->s_Numeric), &(klu_data->s_Common));
klu_data->s_Numeric = klu_factor(JacMat->indexptrs, JacMat->indexvals,
JacMat->data, klu_data->s_Symbolic,
&(klu_data->s_Common));
if (klu_data->s_Numeric == NULL) {
cvProcessError(cv_mem, CVSLS_PACKAGE_FAIL, "CVSLS", "CVKLUSetup",
MSGSP_PACKAGE_FAIL);
return(CVSLS_PACKAGE_FAIL);
}
}
}
}
cvsls_mem->s_last_flag = CVSLS_SUCCESS;
return(0);
}
/*
Setup KLU for a linear solve. This function factors the Jacobian matrix
before handing off the factors for a back solve. Optionally, this function also
computes a new fill-reducing ordering (using KLU) in the case that the matrix
graph has been updated.
*/
int SetupKINKlu(KINMem kin_memory){
//get the KINKlu memory block
KINKluMem kin_klu_mem=(KINKluMem)kin_memory->kin_lmem;
if(!kin_klu_mem) return 1;
//grab appropriate klu objects
cs_di *jac=kin_klu_mem->jac;
klu_symbolic *symb=kin_klu_mem->symbolic;
klu_numeric *numeric=kin_klu_mem->numeric;
klu_common *comm=&(kin_klu_mem->klu_comm);
int n=kin_klu_mem->n, update_fr_order=0;
//call the jacobian evaluation function
kin_klu_mem->jac_fun(n, kin_memory->kin_uu, kin_memory->kin_fval, jac, kin_memory->kin_user_data, &update_fr_order, kin_memory->kin_vtemp1, kin_memory->kin_vtemp2);
/*
if a new fill-reducing ordering has been requested, or if the graph and values have been specified but no ordering has been computed yet, perform the computation
*/
if(update_fr_order){
//if a symbolic object already exists, free it
if(symb){
klu_free_symbolic(&symb, comm);
kin_klu_mem->symbolic=NULL;
}
//perform the fill-reducing ordering
symb=klu_analyze(n, jac->p, jac->i, comm);
if(!symb) return 1;
kin_klu_mem->symbolic=symb;
/*
now we need to perform a numeric factorization. first, free an existing
numeric factorization if there is one.
*/
if(numeric){
klu_free_numeric(&numeric, comm);
kin_klu_mem->numeric=NULL;
}
//perform the factorization
numeric=klu_factor(jac->p, jac->i, jac->x, symb, comm);
/*
check if the factorization was successful and return if not
*/
if(!numeric){
klu_free_symbolic(&symb, comm);
kin_klu_mem->symbolic=NULL;
return 1;
}
kin_klu_mem->numeric=numeric;
//otherwise, the factorization was a success and we can return
return(KINDLS_SUCCESS);
}
/*
if a new fill-reducing ordering is not necessary, we can proceed with factorization. first, check if a numeric factorization exists. if not, compute it
*/
if(!numeric)
{
//perform the factorization
numeric=klu_factor(jac->p, jac->i, jac->x, symb, comm);
/*
check if the factorization was successful and return if not
*/
if(!numeric) return 1;
kin_klu_mem->numeric=numeric;
return(KINDLS_SUCCESS);
}
/*
if a symbolic and numeric factorization already exist, try a refactor using the old numeric factorization. this is much faster than a full numeric factorization and requires no new memory
*/
klu_refactor(jac->p, jac->i, jac->x, symb, numeric, comm);
#ifdef _VERBOSE
/*
check the pivot growth factor. i confess that i dont understand what this
factor means, but a small value is supposed to indicate numerical
instability for testing i'm going to compute it and do a full numerical
factorization if it's too small.
*/
klu_rgrowth(jac->p, jac->i, jac->x, symb, numeric, comm);
/*
print the growth factor to the console for testing
*/
printf("Reciprocal pivot growth after refactor: %1.5e\n\n", kin_klu_mem->klu_comm.rgrowth);
#endif
//return
return(KINDLS_SUCCESS);
};
int main (void)
{
KLU_common Common ;
cholmod_sparse *A, *A2 ;
cholmod_dense *X, *B ;
cholmod_common ch ;
Int *Ap, *Ai, *Puser, *Quser, *Gunk ;
double *Ax, *Bx, *Xx, *A2x ;
double one [2], zero [2], xsave, maxerr ;
Int n, i, j, nz, save, isreal, k, nan ;
KLU_symbolic *Symbolic, *Symbolic2 ;
KLU_numeric *Numeric ;
one [0] = 1 ;
one [1] = 0 ;
zero [0] = 0 ;
zero [1] = 0 ;
printf ("klu test: -------------------------------------------------\n") ;
OK (klu_defaults (&Common)) ;
CHOLMOD_start (&ch) ;
ch.print = 0 ;
normal_memory_handler (&Common) ;
/* ---------------------------------------------------------------------- */
/* read in a sparse matrix from stdin */
/* ---------------------------------------------------------------------- */
A = CHOLMOD_read_sparse (stdin, &ch) ;
if (A->nrow != A->ncol || A->stype != 0)
{
fprintf (stderr, "error: only square unsymmetric matrices handled\n") ;
CHOLMOD_free_sparse (&A, &ch) ;
return (0) ;
}
if (!(A->xtype == CHOLMOD_REAL || A->xtype == CHOLMOD_COMPLEX))
{
fprintf (stderr, "error: only real or complex matrices hanlded\n") ;
CHOLMOD_free_sparse (&A, &ch) ;
return (0) ;
}
n = A->nrow ;
Ap = A->p ;
Ai = A->i ;
Ax = A->x ;
nz = Ap [n] ;
isreal = (A->xtype == CHOLMOD_REAL) ;
/* ---------------------------------------------------------------------- */
/* construct random permutations */
/* ---------------------------------------------------------------------- */
Puser = randperm (n, n) ;
Quser = randperm (n, n) ;
/* ---------------------------------------------------------------------- */
/* select known solution to Ax=b */
/* ---------------------------------------------------------------------- */
X = CHOLMOD_allocate_dense (n, NRHS, n, A->xtype, &ch) ;
Xx = X->x ;
for (j = 0 ; j < NRHS ; j++)
{
for (i = 0 ; i < n ; i++)
{
if (isreal)
{
Xx [i] = 1 + ((double) i) / ((double) n) + j * 100;
}
else
{
Xx [2*i ] = 1 + ((double) i) / ((double) n) + j * 100 ;
Xx [2*i+1] = - ((double) i+1) / ((double) n + j) ;
if (j == NRHS-1)
{
Xx [2*i+1] = 0 ; /* zero imaginary part */
}
else if (j == NRHS-2)
{
Xx [2*i] = 0 ; /* zero real part */
}
}
}
Xx += isreal ? n : 2*n ;
}
/* B = A*X */
B = CHOLMOD_allocate_dense (n, NRHS, n, A->xtype, &ch) ;
CHOLMOD_sdmult (A, 0, one, zero, X, B, &ch) ;
Bx = B->x ;
/* ---------------------------------------------------------------------- */
/* test KLU */
/* ---------------------------------------------------------------------- */
test_memory_handler (&Common) ;
maxerr = do_solves (A, B, X, Puser, Quser, &Common, &ch, &nan) ;
/* ---------------------------------------------------------------------- */
/* basic error checking */
/* ---------------------------------------------------------------------- */
FAIL (klu_defaults (NULL)) ;
FAIL (klu_extract (NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL,
NULL, NULL, NULL, NULL, NULL, NULL, NULL)) ;
FAIL (klu_extract (NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL,
NULL, NULL, NULL, NULL, NULL, NULL, &Common)) ;
FAIL (klu_z_extract (NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL,
NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL)) ;
FAIL (klu_z_extract (NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL,
NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, &Common)) ;
FAIL (klu_analyze (0, NULL, NULL, NULL)) ;
FAIL (klu_analyze (0, NULL, NULL, &Common)) ;
FAIL (klu_analyze_given (0, NULL, NULL, NULL, NULL, NULL)) ;
FAIL (klu_analyze_given (0, NULL, NULL, NULL, NULL, &Common)) ;
FAIL (klu_cholmod (0, NULL, NULL, NULL, NULL)) ;
FAIL (klu_factor (NULL, NULL, NULL, NULL, NULL)) ;
FAIL (klu_factor (NULL, NULL, NULL, NULL, &Common)) ;
FAIL (klu_z_factor (NULL, NULL, NULL, NULL, NULL)) ;
FAIL (klu_z_factor (NULL, NULL, NULL, NULL, &Common)) ;
FAIL (klu_refactor (NULL, NULL, NULL, NULL, NULL, NULL)) ;
FAIL (klu_refactor (NULL, NULL, NULL, NULL, NULL, &Common)) ;
FAIL (klu_z_refactor (NULL, NULL, NULL, NULL, NULL, NULL)) ;
FAIL (klu_z_refactor (NULL, NULL, NULL, NULL, NULL, &Common)) ;
FAIL (klu_rgrowth (NULL, NULL, NULL, NULL, NULL, NULL)) ;
FAIL (klu_rgrowth (NULL, NULL, NULL, NULL, NULL, &Common)) ;
FAIL (klu_z_rgrowth (NULL, NULL, NULL, NULL, NULL, NULL)) ;
FAIL (klu_z_rgrowth (NULL, NULL, NULL, NULL, NULL, &Common)) ;
FAIL (klu_condest (NULL, NULL, NULL, NULL, NULL)) ;
FAIL (klu_condest (NULL, NULL, NULL, NULL, &Common)) ;
FAIL (klu_z_condest (NULL, NULL, NULL, NULL, NULL)) ;
FAIL (klu_z_condest (NULL, NULL, NULL, NULL, &Common)) ;
FAIL (klu_flops (NULL, NULL, NULL)) ;
FAIL (klu_flops (NULL, NULL, &Common)) ;
FAIL (klu_z_flops (NULL, NULL, NULL)) ;
FAIL (klu_z_flops (NULL, NULL, &Common)) ;
FAIL (klu_rcond (NULL, NULL, NULL)) ;
FAIL (klu_rcond (NULL, NULL, &Common)) ;
FAIL (klu_z_rcond (NULL, NULL, NULL)) ;
FAIL (klu_z_rcond (NULL, NULL, &Common)) ;
FAIL (klu_free_symbolic (NULL, NULL)) ;
OK (klu_free_symbolic (NULL, &Common)) ;
FAIL (klu_free_numeric (NULL, NULL)) ;
OK (klu_free_numeric (NULL, &Common)) ;
FAIL (klu_z_free_numeric (NULL, NULL)) ;
OK (klu_z_free_numeric (NULL, &Common)) ;
FAIL (klu_scale (0, 0, NULL, NULL, NULL, NULL, NULL, NULL)) ;
FAIL (klu_scale (0, 0, NULL, NULL, NULL, NULL, NULL, &Common)) ;
OK (klu_scale (-1, 0, NULL, NULL, NULL, NULL, NULL, &Common)) ;
FAIL (klu_z_scale (0, 0, NULL, NULL, NULL, NULL, NULL, NULL)) ;
FAIL (klu_z_scale (0, 0, NULL, NULL, NULL, NULL, NULL, &Common)) ;
OK (klu_z_scale (-1, 0, NULL, NULL, NULL, NULL, NULL, &Common)) ;
FAIL (klu_solve (NULL, NULL, 0, 0, NULL, NULL)) ;
FAIL (klu_solve (NULL, NULL, 0, 0, NULL, &Common)) ;
FAIL (klu_z_solve (NULL, NULL, 0, 0, NULL, NULL)) ;
FAIL (klu_z_solve (NULL, NULL, 0, 0, NULL, &Common)) ;
FAIL (klu_tsolve (NULL, NULL, 0, 0, NULL, NULL)) ;
FAIL (klu_tsolve (NULL, NULL, 0, 0, NULL, &Common)) ;
FAIL (klu_z_tsolve (NULL, NULL, 0, 0, NULL, 0, NULL)) ;
FAIL (klu_z_tsolve (NULL, NULL, 0, 0, NULL, 0, &Common)) ;
FAIL (klu_malloc (0, 0, NULL)) ;
FAIL (klu_malloc (0, 0, &Common)) ;
FAIL (klu_malloc (Int_MAX, 1, &Common)) ;
FAIL (klu_realloc (0, 0, 0, NULL, NULL)) ;
FAIL (klu_realloc (0, 0, 0, NULL, &Common)) ;
FAIL (klu_realloc (Int_MAX, 1, 0, NULL, &Common)) ;
Gunk = (Int *) klu_realloc (1, 0, sizeof (Int), NULL, &Common) ;
OK (Gunk) ;
OK (klu_realloc (Int_MAX, 1, sizeof (Int), Gunk, &Common)) ;
OK (Common.status == KLU_TOO_LARGE) ;
klu_free (Gunk, 1, sizeof (Int), &Common) ;
/* ---------------------------------------------------------------------- */
/* mangle the matrix, and other error checking */
/* ---------------------------------------------------------------------- */
printf ("\nerror handling:\n") ;
Symbolic = klu_analyze (n, Ap, Ai, &Common) ;
OK (Symbolic) ;
Xx = X->x ;
if (nz > 0)
{
/* ------------------------------------------------------------------ */
/* row index out of bounds */
/* ------------------------------------------------------------------ */
save = Ai [0] ;
Ai [0] = -1 ;
FAIL (klu_analyze (n, Ap, Ai, &Common)) ;
if (isreal)
{
FAIL (klu_scale (1, n, Ap, Ai, Ax, Xx, Puser, &Common)) ;
}
else
{
FAIL (klu_z_scale (1, n, Ap, Ai, Ax, Xx, Puser, &Common)) ;
}
Ai [0] = save ;
/* ------------------------------------------------------------------ */
/* row index out of bounds */
/* ------------------------------------------------------------------ */
save = Ai [0] ;
Ai [0] = Int_MAX ;
FAIL (klu_analyze (n, Ap, Ai, &Common)) ;
if (isreal)
{
FAIL (klu_scale (1, n, Ap, Ai, Ax, Xx, Puser, &Common)) ;
}
else
{
FAIL (klu_z_scale (1, n, Ap, Ai, Ax, Xx, Puser, &Common)) ;
}
Ai [0] = save ;
/* ------------------------------------------------------------------ */
/* column pointers mangled */
/* ------------------------------------------------------------------ */
save = Ap [n] ;
Ap [n] = -1 ;
FAIL (klu_analyze (n, Ap, Ai, &Common)) ;
if (isreal)
{
FAIL (klu_scale (1, n, Ap, Ai, Ax, Xx, Puser, &Common)) ;
}
else
{
FAIL (klu_z_scale (1, n, Ap, Ai, Ax, Xx, Puser, &Common)) ;
}
Ap [n] = save ;
/* ------------------------------------------------------------------ */
/* column pointers mangled */
/* ------------------------------------------------------------------ */
save = Ap [n] ;
Ap [n] = Ap [n-1] - 1 ;
FAIL (klu_analyze (n, Ap, Ai, &Common)) ;
if (isreal)
{
FAIL (klu_scale (1, n, Ap, Ai, Ax, Xx, Puser, &Common)) ;
}
else
{
FAIL (klu_z_scale (1, n, Ap, Ai, Ax, Xx, Puser, &Common)) ;
}
Ap [n] = save ;
/* ------------------------------------------------------------------ */
/* duplicates */
/* ------------------------------------------------------------------ */
if (n > 1 && Ap [1] - Ap [0] > 1)
{
save = Ai [1] ;
Ai [1] = Ai [0] ;
FAIL (klu_analyze (n, Ap, Ai, &Common)) ;
if (isreal)
{
FAIL (klu_scale (1, n, Ap, Ai, Ax, Xx, Puser, &Common)) ;
}
else
{
FAIL (klu_z_scale (1, n, Ap, Ai, Ax, Xx, Puser, &Common)) ;
}
Ai [1] = save ;
}
/* ------------------------------------------------------------------ */
/* invalid ordering */
/* ------------------------------------------------------------------ */
save = Common.ordering ;
Common.ordering = 42 ;
FAIL (klu_analyze (n, Ap, Ai, &Common)) ;
Common.ordering = save ;
/* ------------------------------------------------------------------ */
/* invalid ordering (klu_cholmod, with NULL user_ordering) */
/* ------------------------------------------------------------------ */
save = Common.ordering ;
Common.user_order = NULL ;
Common.ordering = 3 ;
FAIL (klu_analyze (n, Ap, Ai, &Common)) ;
Common.ordering = save ;
}
/* ---------------------------------------------------------------------- */
/* tests with valid symbolic factorization */
/* ---------------------------------------------------------------------- */
Common.halt_if_singular = FALSE ;
Common.scale = 0 ;
Numeric = NULL ;
if (nz > 0)
{
/* ------------------------------------------------------------------ */
/* Int overflow */
/* ------------------------------------------------------------------ */
if (n == 100)
{
Common.ordering = 2 ;
Symbolic2 = klu_analyze (n, Ap, Ai, &Common) ;
OK (Symbolic2) ;
Common.memgrow = Int_MAX ;
if (isreal)
{
Numeric = klu_factor (Ap, Ai, Ax, Symbolic2, &Common) ;
}
else
{
Numeric = klu_z_factor (Ap, Ai, Ax, Symbolic2, &Common) ;
}
Common.memgrow = 1.2 ;
Common.ordering = 0 ;
klu_free_symbolic (&Symbolic2, &Common) ;
klu_free_numeric (&Numeric, &Common) ;
}
/* ------------------------------------------------------------------ */
/* Int overflow again */
/* ------------------------------------------------------------------ */
Common.initmem = Int_MAX ;
Common.initmem_amd = Int_MAX ;
if (isreal)
{
Numeric = klu_factor (Ap, Ai, Ax, Symbolic, &Common) ;
}
else
{
Numeric = klu_z_factor (Ap, Ai, Ax, Symbolic, &Common) ;
}
Common.initmem = 10 ;
Common.initmem_amd = 1.2 ;
klu_free_numeric (&Numeric, &Common) ;
/* ------------------------------------------------------------------ */
/* mangle the matrix */
/* ------------------------------------------------------------------ */
save = Ai [0] ;
Ai [0] = -1 ;
if (isreal)
{
Numeric = klu_factor (Ap, Ai, Ax, Symbolic, &Common) ;
}
else
{
Numeric = klu_z_factor (Ap, Ai, Ax, Symbolic, &Common) ;
}
FAIL (Numeric) ;
Ai [0] = save ;
/* ------------------------------------------------------------------ */
/* nan and inf handling */
/* ------------------------------------------------------------------ */
xsave = Ax [0] ;
Ax [0] = one [0] / zero [0] ;
if (isreal)
{
Numeric = klu_factor (Ap, Ai, Ax, Symbolic, &Common) ;
klu_rcond (Symbolic, Numeric, &Common) ;
klu_condest (Ap, Ax, Symbolic, Numeric, &Common) ;
}
else
{
Numeric = klu_z_factor (Ap, Ai, Ax, Symbolic, &Common) ;
klu_z_rcond (Symbolic, Numeric, &Common) ;
klu_z_condest (Ap, Ax, Symbolic, Numeric, &Common) ;
}
printf ("Nan case: rcond %g condest %g\n",
Common.rcond, Common.condest) ;
OK (Numeric) ;
Ax [0] = xsave ;
/* ------------------------------------------------------------------ */
/* mangle the matrix again */
/* ------------------------------------------------------------------ */
save = Ai [0] ;
Ai [0] = -1 ;
if (isreal)
{
FAIL (klu_refactor (Ap, Ai, Ax, Symbolic, Numeric, &Common)) ;
}
else
{
FAIL (klu_z_refactor (Ap, Ai, Ax, Symbolic, Numeric, &Common)) ;
}
Ai [0] = save ;
/* ------------------------------------------------------------------ */
/* all zero */
/* ------------------------------------------------------------------ */
A2 = CHOLMOD_copy_sparse (A, &ch) ;
A2x = A2->x ;
for (k = 0 ; k < nz * (isreal ? 1:2) ; k++)
{
A2x [k] = 0 ;
}
for (Common.halt_if_singular = 0 ; Common.halt_if_singular <= 1 ;
Common.halt_if_singular++)
{
for (Common.scale = -1 ; Common.scale <= 2 ; Common.scale++)
{
if (isreal)
{
klu_refactor (Ap, Ai, A2x, Symbolic, Numeric, &Common) ;
klu_condest (Ap, A2x, Symbolic, Numeric, &Common) ;
}
else
{
klu_z_refactor (Ap, Ai, A2x, Symbolic, Numeric, &Common) ;
klu_z_condest (Ap, A2x, Symbolic, Numeric, &Common) ;
}
OK (Common.status = KLU_SINGULAR) ;
}
}
CHOLMOD_free_sparse (&A2, &ch) ;
/* ------------------------------------------------------------------ */
/* all one, or all 1i for complex case */
/* ------------------------------------------------------------------ */
A2 = CHOLMOD_copy_sparse (A, &ch) ;
A2x = A2->x ;
for (k = 0 ; k < nz ; k++)
{
if (isreal)
{
A2x [k] = 1 ;
}
else
{
A2x [2*k ] = 0 ;
A2x [2*k+1] = 1 ;
}
}
Common.halt_if_singular = 0 ;
Common.scale = 0 ;
if (isreal)
{
klu_refactor (Ap, Ai, A2x, Symbolic, Numeric, &Common) ;
klu_condest (Ap, A2x, Symbolic, Numeric, &Common) ;
}
else
{
klu_z_refactor (Ap, Ai, A2x, Symbolic, Numeric, &Common) ;
klu_z_condest (Ap, A2x, Symbolic, Numeric, &Common) ;
}
OK (Common.status = KLU_SINGULAR) ;
CHOLMOD_free_sparse (&A2, &ch) ;
}
klu_free_symbolic (&Symbolic, &Common) ;
if (isreal)
{
klu_free_numeric (&Numeric, &Common) ;
}
else
{
klu_z_free_numeric (&Numeric, &Common) ;
}
/* ---------------------------------------------------------------------- */
/* free problem and quit */
/* ---------------------------------------------------------------------- */
CHOLMOD_free_dense (&X, &ch) ;
CHOLMOD_free_dense (&B, &ch) ;
CHOLMOD_free_sparse (&A, &ch) ;
free (Puser) ;
free (Quser) ;
CHOLMOD_finish (&ch) ;
fprintf (stderr, " maxerr %10.3e", maxerr) ;
printf (" maxerr %10.3e", maxerr) ;
if (maxerr < 1e-8)
{
fprintf (stderr, " test passed") ;
printf (" test passed") ;
}
else
{
fprintf (stderr, " test FAILED") ;
printf (" test FAILED") ;
}
if (nan)
{
fprintf (stderr, " *") ;
printf (" *") ;
}
fprintf (stderr, "\n") ;
printf ("\n-----------------------------------------------------------\n") ;
return (0) ;
}
static double do_1_solve (cholmod_sparse *A, cholmod_dense *B,
cholmod_dense *Xknown, Int *Puser, Int *Quser,
KLU_common *Common, cholmod_common *ch, Int *nan)
{
Int *Ai, *Ap ;
double *Ax, *Bx, *Xknownx, *Xx, *Ax2, *Axx ;
KLU_symbolic *Symbolic = NULL ;
KLU_numeric *Numeric = NULL ;
cholmod_dense *X = NULL, *R = NULL ;
cholmod_sparse *AT = NULL, *A2 = NULL, *AT2 = NULL ;
double one [2], minusone [2],
rnorm, anorm, bnorm, xnorm, relresid, relerr, err = 0. ;
Int i, j, nrhs2, isreal, n, nrhs, transpose, step, k, save, tries ;
printf ("\ndo_1_solve: btf "ID" maxwork %g scale "ID" ordering "ID" user: "******" P,Q: %d halt: "ID"\n",
Common->btf, Common->maxwork, Common->scale, Common->ordering,
Common->user_data ? (*((Int *) Common->user_data)) : -1,
(Puser != NULL || Quser != NULL), Common->halt_if_singular) ;
fflush (stdout) ;
fflush (stderr) ;
CHOLMOD_print_sparse (A, "A", ch) ;
CHOLMOD_print_dense (B, "B", ch) ;
Ap = A->p ;
Ai = A->i ;
Ax = A->x ;
n = A->nrow ;
isreal = (A->xtype == CHOLMOD_REAL) ;
Bx = B->x ;
Xknownx = Xknown->x ;
nrhs = B->ncol ;
one [0] = 1 ;
one [1] = 0 ;
minusone [0] = -1 ;
minusone [1] = 0 ;
/* ---------------------------------------------------------------------- */
/* symbolic analysis */
/* ---------------------------------------------------------------------- */
Symbolic = NULL ;
my_tries = 0 ;
for (tries = 0 ; Symbolic == NULL && my_tries == 0 ; tries++)
{
my_tries = tries ;
if (Puser != NULL || Quser != NULL)
{
Symbolic = klu_analyze_given (n, Ap, Ai, Puser, Quser, Common) ;
}
else
{
Symbolic = klu_analyze (n, Ap, Ai, Common) ;
}
}
printf ("sym try "ID" btf "ID" ordering "ID"\n",
tries, Common->btf, Common->ordering) ;
if (Symbolic == NULL)
{
printf ("Symbolic is null\n") ;
return (998) ;
}
my_tries = -1 ;
/* create a modified version of A */
A2 = CHOLMOD_copy_sparse (A, ch) ;
Ax2 = A2->x ;
my_srand (42) ;
for (k = 0 ; k < Ap [n] * (isreal ? 1:2) ; k++)
{
Ax2 [k] = Ax [k] *
(1 + 1e-4 * ((double) my_rand ( )) / ((double) MY_RAND_MAX)) ;
}
AT = isreal ? NULL : CHOLMOD_transpose (A, 1, ch) ;
AT2 = isreal ? NULL : CHOLMOD_transpose (A2, 1, ch) ;
/* ---------------------------------------------------------------------- */
/* factorize then solve */
/* ---------------------------------------------------------------------- */
for (step = 1 ; step <= 3 ; step++)
{
printf ("step: "ID"\n", step) ;
fflush (stdout) ;
/* ------------------------------------------------------------------ */
/* factorization or refactorization */
/* ------------------------------------------------------------------ */
/* step 1: factor
step 2: refactor with same A
step 3: refactor with modified A, and scaling forced on
and solve each time
*/
if (step == 1)
{
/* numeric factorization */
Numeric = NULL ;
my_tries = 0 ;
for (tries = 0 ; Numeric == NULL && my_tries == 0 ; tries++)
{
my_tries = tries ;
if (isreal)
{
Numeric = klu_factor (Ap, Ai, Ax, Symbolic, Common) ;
}
else
{
Numeric = klu_z_factor (Ap, Ai, Ax, Symbolic, Common) ;
}
}
printf ("num try "ID" btf "ID"\n", tries, Common->btf) ;
my_tries = -1 ;
if (Common->status == KLU_OK ||
(Common->status == KLU_SINGULAR && !Common->halt_if_singular))
{
OK (Numeric) ;
}
else
{
FAIL (Numeric) ;
}
if (Common->status < KLU_OK)
{
printf ("factor failed: "ID"\n", Common->status) ;
}
}
else if (step == 2)
{
/* numeric refactorization with same values, same scaling */
if (isreal)
{
klu_refactor (Ap, Ai, Ax, Symbolic, Numeric, Common) ;
}
else
{
klu_z_refactor (Ap, Ai, Ax, Symbolic, Numeric, Common) ;
}
}
else
{
/* numeric refactorization with different values */
save = Common->scale ;
if (Common->scale == 0)
{
Common->scale = 1 ;
}
for (tries = 0 ; tries <= 1 ; tries++)
{
my_tries = tries ;
if (isreal)
{
klu_refactor (Ap, Ai, Ax2, Symbolic, Numeric, Common) ;
}
else
{
klu_z_refactor (Ap, Ai, Ax2, Symbolic, Numeric, Common) ;
}
}
my_tries = -1 ;
Common->scale = save ;
}
if (Common->status == KLU_SINGULAR)
{
printf ("# singular column : "ID"\n", Common->singular_col) ;
}
/* ------------------------------------------------------------------ */
/* diagnostics */
/* ------------------------------------------------------------------ */
Axx = (step == 3) ? Ax2 : Ax ;
if (isreal)
{
klu_rgrowth (Ap, Ai, Axx, Symbolic, Numeric, Common) ;
klu_condest (Ap, Axx, Symbolic, Numeric, Common) ;
klu_rcond (Symbolic, Numeric, Common) ;
klu_flops (Symbolic, Numeric, Common) ;
}
else
{
klu_z_rgrowth (Ap, Ai, Axx, Symbolic, Numeric, Common) ;
klu_z_condest (Ap, Axx, Symbolic, Numeric, Common) ;
klu_z_rcond (Symbolic, Numeric, Common) ;
klu_z_flops (Symbolic, Numeric, Common) ;
}
printf ("growth %g condest %g rcond %g flops %g\n",
Common->rgrowth, Common->condest, Common->rcond, Common->flops) ;
ludump (Symbolic, Numeric, isreal, ch, Common) ;
if (Numeric == NULL || Common->status < KLU_OK)
{
continue ;
}
/* ------------------------------------------------------------------ */
/* solve */
/* ------------------------------------------------------------------ */
/* forward/backsolve to solve A*X=B or A'*X=B */
for (transpose = (isreal ? 0 : -1) ; transpose <= 1 ; transpose++)
{
for (nrhs2 = 1 ; nrhs2 <= nrhs ; nrhs2++)
{
/* mangle B so that it has only nrhs2 columns */
B->ncol = nrhs2 ;
X = CHOLMOD_copy_dense (B, ch) ;
CHOLMOD_print_dense (X, "X before solve", ch) ;
Xx = X->x ;
if (isreal)
{
if (transpose)
{
/* solve A'x=b */
klu_tsolve (Symbolic, Numeric, n, nrhs2, Xx, Common) ;
}
else
{
/* solve A*x=b */
klu_solve (Symbolic, Numeric, n, nrhs2, Xx, Common) ;
}
}
else
{
if (transpose)
{
/* solve A'x=b (if 1) or A.'x=b (if -1) */
klu_z_tsolve (Symbolic, Numeric, n, nrhs2, Xx,
(transpose == 1), Common) ;
}
else
{
/* solve A*x=b */
klu_z_solve (Symbolic, Numeric, n, nrhs2, Xx, Common) ;
}
}
CHOLMOD_print_dense (X, "X", ch) ;
/* compute the residual, R = B-A*X, B-A'*X, or B-A.'*X */
R = CHOLMOD_copy_dense (B, ch) ;
if (transpose == -1)
{
/* R = B-A.'*X (use A.' explicitly) */
CHOLMOD_sdmult ((step == 3) ? AT2 : AT,
0, minusone, one, X, R, ch) ;
}
else
{
/* R = B-A*X or B-A'*X */
CHOLMOD_sdmult ((step == 3) ? A2 :A,
transpose, minusone, one, X, R, ch) ;
}
CHOLMOD_print_dense (R, "R", ch) ;
/* compute the norms of R, A, X, and B */
rnorm = CHOLMOD_norm_dense (R, 1, ch) ;
anorm = CHOLMOD_norm_sparse ((step == 3) ? A2 : A, 1, ch) ;
xnorm = CHOLMOD_norm_dense (X, 1, ch) ;
bnorm = CHOLMOD_norm_dense (B, 1, ch) ;
CHOLMOD_free_dense (&R, ch) ;
/* relative residual = norm (r) / (norm (A) * norm (x)) */
relresid = rnorm ;
if (anorm > 0)
{
relresid /= anorm ;
}
if (xnorm > 0)
{
relresid /= xnorm ;
}
if (SCALAR_IS_NAN (relresid))
{
*nan = TRUE ;
}
else
{
err = MAX (err, relresid) ;
}
/* relative error = norm (x - xknown) / norm (xknown) */
/* overwrite X with X - Xknown */
if (transpose || step == 3)
{
/* not computed */
relerr = -1 ;
}
else
{
for (j = 0 ; j < nrhs2 ; j++)
{
for (i = 0 ; i < n ; i++)
{
if (isreal)
{
Xx [i+j*n] -= Xknownx [i+j*n] ;
}
else
{
Xx [2*(i+j*n) ] -= Xknownx [2*(i+j*n) ] ;
Xx [2*(i+j*n)+1] -= Xknownx [2*(i+j*n)+1] ;
}
}
}
relerr = CHOLMOD_norm_dense (X, 1, ch) ;
xnorm = CHOLMOD_norm_dense (Xknown, 1, ch) ;
if (xnorm > 0)
{
relerr /= xnorm ;
}
if (SCALAR_IS_NAN (relerr))
{
*nan = TRUE ;
}
else
{
err = MAX (relerr, err) ;
}
}
CHOLMOD_free_dense (&X, ch) ;
printf (ID" "ID" relresid %10.3g relerr %10.3g %g\n",
transpose, nrhs2, relresid, relerr, err) ;
B->ncol = nrhs ; /* restore B */
}
}
}
/* ---------------------------------------------------------------------- */
/* free factorization and temporary matrices, and return */
/* ---------------------------------------------------------------------- */
klu_free_symbolic (&Symbolic, Common) ;
if (isreal)
{
klu_free_numeric (&Numeric, Common) ;
}
else
{
klu_z_free_numeric (&Numeric, Common) ;
}
CHOLMOD_free_sparse (&A2, ch) ;
CHOLMOD_free_sparse (&AT, ch) ;
CHOLMOD_free_sparse (&AT2, ch) ;
fflush (stdout) ;
fflush (stderr) ;
return (err) ;
}
