/*
This will prep KLU for subsequent linear solves by computing an initial fill-reducing ordering and numeric factorization (if values are available) of the user-supplied Jacobian.
*/
int InitKINKlu(KINMem kin_memory){
//check inputs
if(!kin_memory) return 1;
//grab the kinklu block
KINKluMem kin_klu_mem=(KINKluMem)kin_memory->kin_lmem;
if(!kin_klu_mem) return 1;
kin_memory->kin_inexact_ls=FALSE;
kin_memory->kin_setupNonNull=TRUE;
//grab klu objects from kinklu memory
int n=kin_klu_mem->n, ok;
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);
//if theres no jacobian to try factoring, we're done
if(!jac) return 1;
//check for, and delete if necessary, existing klu symbolic and numeric objects.
if(symb){klu_free_symbolic(&symb, comm); symb=NULL; kin_klu_mem->symbolic=NULL;}
if(numeric){klu_free_numeric(&numeric, comm); numeric=NULL; kin_klu_mem->numeric=NULL;}
ok=klu_defaults(comm);
//attempt the symbolic factorization.
symb=klu_analyze(n, jac->p, jac->i, comm);
//if there's an error doing the factorization, abort. don't delete the jacobian passed in, but null the kinklu jac pointer
if(!symb) return 1;
//otherwise, assign the kinklu symbolic pointer and indicate that the jacobian has been fill-reduced
kin_klu_mem->symbolic=symb;
kin_klu_mem->is_fill_reduced=1;
//do numeric factor if values are available
/*
if(jac->x){
//try factorization. on failure, free the previous symbolic object and return.
numeric = klu_factor(jac->p, jac->i, jac->x, symb, comm);
if(!numeric){
klu_free_symbolic(&symb, comm);
kin_klu_mem->symbolic = NULL;
return 1;
}
//otherwise, assign the kinklu numeric pointer and return.
kin_klu_mem->numeric = numeric;
}*/
return 0;
};
int main (void)
{
klu_symbolic *Symbolic ;
klu_numeric *Numeric ;
klu_common Common ;
int i ;
klu_defaults (&Common) ;
Symbolic = klu_analyze (n, Ap, Ai, &Common) ;
Numeric = klu_factor (Ap, Ai, Ax, Symbolic, &Common) ;
klu_solve (Symbolic, Numeric, 5, 1, b, &Common) ;
klu_free_symbolic (&Symbolic, &Common) ;
klu_free_numeric (&Numeric, &Common) ;
for (i = 0 ; i < n ; i++) printf ("x [%d] = %g\n", i, b [i]) ;
return (0) ;
}
/***
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;
}
int KLUSystem::Factor()
{
// first convert the triplets to column-compressed form, and prep the columns
if (T22) {
compress_partitions ();
} else { // otherwise, compression and factoring has already been done
if (m_fltBus) return -1; // was found singular before
return 1; // was found okay before
}
// then factor Y22
if (Numeric) klu_z_free_numeric (&Numeric, &Common);
if (Symbolic) klu_free_symbolic (&Symbolic, &Common);
Numeric = NULL;
Symbolic = NULL;
if (Y22) {
Symbolic = klu_analyze (Y22->n, Y22->p, Y22->i, &Common);
Numeric = klu_z_factor (Y22->p, Y22->i, Y22->x, Symbolic, &Common);
m_fltBus = Common.singular_col;
if (Common.singular_col < Y22->n) {
++m_fltBus; // for 1-based NexHarm row numbers
m_fltBus += 0; // skip over the voltage source buses
} else {
m_fltBus = 0; // no singular submatrix was found
}
if (Common.status == KLU_OK) {
// compute size of the factorization
m_NZpost += (Numeric->lnz + Numeric->unz - Numeric->n +
((Numeric->Offp) ? (Numeric->Offp [Numeric->n]) : 0));
return 1;
} else if (Common.status == KLU_SINGULAR) {
return -1;
} else { // KLU_OUT_OF_MEMORY, KLU_INVALID, or KLU_TOO_LARGE
if (!m_fltBus) {
m_fltBus = 1; // this is the flag for unsuccessful factorization
}
return 0;
}
}
return 1;
}
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);
}
/*---------------------------------------------------------------
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);
}
/*---------------------------------------------------------------
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);
}
/*! \fn solve linear system with Klu method
*
* \param [in] [data]
* [sysNumber] index of the corresponding linear system
*
*
* author: wbraun
*/
int
solveKlu(DATA *data, threadData_t *threadData, int sysNumber)
{
void *dataAndThreadData[2] = {data, threadData};
LINEAR_SYSTEM_DATA* systemData = &(data->simulationInfo->linearSystemData[sysNumber]);
DATA_KLU* solverData = (DATA_KLU*)systemData->solverData;
int i, j, status = 0, success = 0, n = systemData->size, eqSystemNumber = systemData->equationIndex, indexes[2] = {1,eqSystemNumber};
infoStreamPrintWithEquationIndexes(LOG_LS, 0, indexes, "Start solving Linear System %d (size %d) at time %g with Klu Solver",
eqSystemNumber, (int) systemData->size,
data->localData[0]->timeValue);
rt_ext_tp_tick(&(solverData->timeClock));
if (0 == systemData->method)
{
/* set A matrix */
solverData->Ap[0] = 0;
systemData->setA(data, threadData, systemData);
solverData->Ap[solverData->n_row] = solverData->nnz;
if (ACTIVE_STREAM(LOG_LS_V))
{
infoStreamPrint(LOG_LS_V, 1, "Matrix A");
printMatrixCSR(solverData->Ap, solverData->Ai, solverData->Ax, n);
messageClose(LOG_LS_V);
}
/* set b vector */
systemData->setb(data, threadData, systemData);
} else {
solverData->Ap[0] = 0;
/* calculate jacobian -> matrix A*/
if(systemData->jacobianIndex != -1){
getAnalyticalJacobian(data, threadData, sysNumber);
} else {
assertStreamPrint(threadData, 1, "jacobian function pointer is invalid" );
}
solverData->Ap[solverData->n_row] = solverData->nnz;
/* calculate vector b (rhs) */
memcpy(solverData->work, systemData->x, sizeof(double)*solverData->n_row);
residual_wrapper(solverData->work, systemData->b, dataAndThreadData, sysNumber);
}
infoStreamPrint(LOG_LS, 0, "### %f time to set Matrix A and vector b.", rt_ext_tp_tock(&(solverData->timeClock)));
if (ACTIVE_STREAM(LOG_LS_V))
{
if (ACTIVE_STREAM(LOG_LS_V))
{
infoStreamPrint(LOG_LS_V, 1, "Old solution x:");
for(i = 0; i < solverData->n_row; ++i)
infoStreamPrint(LOG_LS_V, 0, "[%d] %s = %g", i+1, modelInfoGetEquation(&data->modelData->modelDataXml,eqSystemNumber).vars[i], systemData->x[i]);
messageClose(LOG_LS_V);
}
infoStreamPrint(LOG_LS_V, 1, "Matrix A n_rows = %d", solverData->n_row);
for (i=0; i<solverData->n_row; i++){
infoStreamPrint(LOG_LS_V, 0, "%d. Ap => %d -> %d", i, solverData->Ap[i], solverData->Ap[i+1]);
for (j=solverData->Ap[i]; j<solverData->Ap[i+1]; j++){
infoStreamPrint(LOG_LS_V, 0, "A[%d,%d] = %f", i, solverData->Ai[j], solverData->Ax[j]);
}
}
messageClose(LOG_LS_V);
for (i=0; i<solverData->n_row; i++)
infoStreamPrint(LOG_LS_V, 0, "b[%d] = %e", i, systemData->b[i]);
}
rt_ext_tp_tick(&(solverData->timeClock));
/* symbolic pre-ordering of A to reduce fill-in of L and U */
if (0 == solverData->numberSolving)
{
infoStreamPrint(LOG_LS_V, 0, "Perform analyze settings:\n - ordering used: %d\n - current status: %d", solverData->common.ordering, solverData->common.status);
solverData->symbolic = klu_analyze(solverData->n_col, solverData->Ap, solverData->Ai, &solverData->common);
}
/* compute the LU factorization of A */
if (0 == solverData->common.status){
solverData->numeric = klu_factor(solverData->Ap, solverData->Ai, solverData->Ax, solverData->symbolic, &solverData->common);
}
if (0 == solverData->common.status){
if (1 == systemData->method){
if (klu_solve(solverData->symbolic, solverData->numeric, solverData->n_col, 1, systemData->b, &solverData->common)){
success = 1;
}
} else {
if (klu_tsolve(solverData->symbolic, solverData->numeric, solverData->n_col, 1, systemData->b, &solverData->common)){
success = 1;
}
}
}
infoStreamPrint(LOG_LS, 0, "Solve System: %f", rt_ext_tp_tock(&(solverData->timeClock)));
/* print solution */
if (1 == success){
if (1 == systemData->method){
/* take the solution */
for(i = 0; i < solverData->n_row; ++i)
systemData->x[i] += systemData->b[i];
/* update inner equations */
residual_wrapper(systemData->x, solverData->work, dataAndThreadData, sysNumber);
} else {
/* the solution is automatically in x */
memcpy(systemData->x, systemData->b, sizeof(double)*systemData->size);
}
if (ACTIVE_STREAM(LOG_LS_V))
{
infoStreamPrint(LOG_LS_V, 1, "Solution x:");
infoStreamPrint(LOG_LS_V, 0, "System %d numVars %d.", eqSystemNumber, modelInfoGetEquation(&data->modelData->modelDataXml,eqSystemNumber).numVar);
for(i = 0; i < systemData->size; ++i)
infoStreamPrint(LOG_LS_V, 0, "[%d] %s = %g", i+1, modelInfoGetEquation(&data->modelData->modelDataXml,eqSystemNumber).vars[i], systemData->x[i]);
messageClose(LOG_LS_V);
}
}
else
{
warningStreamPrint(LOG_STDOUT, 0,
"Failed to solve linear system of equations (no. %d) at time %f, system status %d.",
(int)systemData->equationIndex, data->localData[0]->timeValue, status);
}
solverData->numberSolving += 1;
return success;
}
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) ;
}
