/* symbolic ordering and analysis for QR or LU */
css *cs_sqr (CS_INT order, const cs *A, CS_INT qr)
{
CS_INT n, k, ok = 1, *post ;
css *S ;
if (!CS_CSC (A)) return (NULL) ; /* check inputs */
n = A->n ;
S = cs_calloc (1, sizeof (css)) ; /* allocate result S */
if (!S) return (NULL) ; /* out of memory */
S->q = cs_amd (order, A) ; /* fill-reducing ordering */
if (order && !S->q) return (cs_sfree (S)) ;
if (qr) /* QR symbolic analysis */
{
cs *C = order ? cs_permute (A, NULL, S->q, 0) : ((cs *) A) ;
S->parent = cs_etree (C, 1) ; /* etree of C'*C, where C=A(:,q) */
post = cs_post (S->parent, n) ;
S->cp = cs_counts (C, S->parent, post, 1) ; /* col counts chol(C'*C) */
cs_free (post) ;
ok = C && S->parent && S->cp && cs_vcount (C, S) ;
if (ok) for (S->unz = 0, k = 0 ; k < n ; k++) S->unz += S->cp [k] ;
if (order) cs_spfree (C) ;
}
else
{
S->unz = 4*(A->p [n]) + n ; /* for LU factorization only, */
S->lnz = S->unz ; /* guess nnz(L) and nnz(U) */
}
return (ok ? S : cs_sfree (S)) ; /* return result S */
}
css *cs_schol(int order, const cs *A) {
int n, *c, *post, *P;
cs *C;
css *S;
if (!CS_CSC (A))
return (NULL); /* check inputs */
n = A->n;
S = (css *) cs_calloc(1, sizeof(css)); /* allocate result S */
if (!S)
return (NULL); /* out of memory */
P = cs_amd(order, A); /* P = amd(A+A'), or natural */
S->pinv = cs_pinv(P, n); /* find inverse permutation */
cs_free(P);
if (order && !S->pinv)
return (cs_sfree(S));
C = cs_symperm(A, S->pinv, 0); /* C = spones(triu(A(P,P))) */
S->parent = cs_etree(C, 0); /* find etree of C */
post = cs_post(S->parent, n); /* postorder the etree */
c = cs_counts(C, S->parent, post, 0); /* find column counts of chol(C) */
cs_free(post);
cs_spfree(C);
S->cp = (int *) cs_malloc(n + 1, sizeof(int)); /* allocate result S->cp */
S->unz = S->lnz = cs_cumsum(S->cp, c, n); /* find column pointers for L */
cs_free(c);
return ((S->lnz >= 0) ? S : cs_sfree(S));
}
void free_var(ode_workspace *odews)
{
if (odews->W->buf != NULL) free(odews->W->buf);
if (odews->W->flag != NULL) free(odews->W->flag);
if (odews->W->level != NULL) free(odews->W->level);
if (odews->W->l != NULL) free(odews->W->l);
if (odews->W->x != NULL) free(odews->W->x);
if (odews->W->y != NULL) free(odews->W->y);
if (odews->W->b != NULL) free(odews->W->b);
if (odews->W->u != NULL) free(odews->W->u);
if (odews->W->v != NULL) free(odews->W->v);
if (odews->W->p != NULL) free(odews->W->p);
if (odews->W->q != NULL) free(odews->W->q);
if (odews->W->w != NULL) free(odews->W->w);
if (odews->W->ucomm != NULL) free(odews->W->ucomm);
if (odews->W->vcomm != NULL) free(odews->W->vcomm);
if (odews->W->gcomm != NULL) free(odews->W->gcomm);
if (odews->W->xn != NULL) free(odews->W->xn);
if (odews->W->xm != NULL) free(odews->W->xm);
if (odews->W->level0 != NULL) free(odews->W->level0);
if (odews->W->b0 != NULL) free(odews->W->b0);
if (odews->W->p0 != NULL) free(odews->W->p0);
if (odews->W->q0 != NULL) free(odews->W->q0);
if (odews->W->xn0 != NULL) free(odews->W->xn0);
if (odews->W->J != NULL) cs_spfree(odews->W->J);
if (odews->W->dfdx->r != NULL) free(odews->W->dfdx->r);
if (odews->W->dfdx->g != NULL) free(odews->W->dfdx->g);
if (odews->W->dfdx->A != NULL) cs_spfree(odews->W->dfdx->A);
if (odews->W->dfdx != NULL) free(odews->W->dfdx);
if (odews->W->A != NULL) cs_spfree(odews->W->A);
if (odews->W->At != NULL) cs_spfree(odews->W->At);
if (odews->W->A_A != NULL) cs_spfree(odews->W->A_A);
if (odews->W->A_At != NULL) cs_spfree(odews->W->A_At);
if (odews->W->dpdgneg != NULL) cs_spfree(odews->W->dpdgneg);
if (odews->W->dfdp->r != NULL) free(odews->W->dfdp->r);
if (odews->W->dfdp->g != NULL) free(odews->W->dfdp->g);
if (odews->W->dfdp->A != NULL) cs_spfree(odews->W->dfdp->A);
if (odews->W->dfdp != NULL) free(odews->W->dfdp);
if (odews->W->G != NULL) cs_spfree(odews->W->G);
if (odews->W->dgdx != NULL) cs_spfree(odews->W->dgdx);
if (odews->W->Proj != NULL) cs_spfree(odews->W->Proj);
if (odews->W->symbchol != NULL) cs_sfree(odews->W->symbchol);
if (odews->W->symbchol_reduced != NULL) cs_sfree(odews->W->symbchol_reduced);
if (odews->W->nvu_w->dfdx_pattern != NULL) cs_spfree(odews->W->nvu_w->dfdx_pattern);
if (odews->W->nvu_w->dfdp_pattern != NULL) cs_spfree(odews->W->nvu_w->dfdp_pattern);
if (odews->W->nvu_w != NULL) free(odews->W->nvu_w);
if (odews->W->symbchol0 != NULL) cs_sfree(odews->W->symbchol0);
if (odews->W->G0 != NULL) cs_spfree(odews->W->G0);
if (odews->W->A0 != NULL) cs_spfree(odews->W->A0);
if (odews->W->A0t != NULL) cs_spfree(odews->W->A0t);
if (odews->W != NULL) free(odews->W);
if (odews->N != NULL) cs_nfree(odews->N);
if (odews->y != NULL) free(odews->y);
if (odews->f != NULL) free(odews->f);
}
/**
* Copy the contents of S to a css_LU or css_QR object and,
* optionally, free S or free both S and the pointers to its contents.
*
* @param a css object to be converted
* @param cl the name of the S4 class of the object to be generated
* @param dofree 0 - don't free a; > 0 cs_free a; < 0 Free a
* @param m number of rows in original matrix
* @param n number of columns in original matrix
*
* @return SEXP containing a copy of S
*/
SEXP Matrix_css_to_SEXP(css *S, char *cl, int dofree, int m, int n)
{
SEXP ans;
char *valid[] = {"css_LU", "css_QR", ""};
int *nz, ctype = Matrix_check_class(cl, valid);
if (ctype < 0)
error("Inappropriate class '%s' for Matrix_css_to_SEXP", cl);
ans = PROTECT(NEW_OBJECT(MAKE_CLASS(cl)));
/* allocate and copy common slots */
Memcpy(INTEGER(ALLOC_SLOT(ans, install("Q"), INTSXP, n)), S->q, n);
nz = INTEGER(ALLOC_SLOT(ans, install("nz"), INTSXP, 3));
nz[0] = S->m2; nz[1] = S->lnz; nz[2] = S->unz;
switch(ctype) {
case 0:
break;
case 1:
Memcpy(INTEGER(ALLOC_SLOT(ans, install("Pinv"), INTSXP, m)),
S->pinv, m);
Memcpy(INTEGER(ALLOC_SLOT(ans, install("parent"), INTSXP, n)),
S->parent, n);
Memcpy(INTEGER(ALLOC_SLOT(ans, install("cp"), INTSXP, n)),
S->cp, n);
break;
default:
error("Inappropriate class '%s' for Matrix_css_to_SEXP", cl);
}
if (dofree > 0) cs_sfree(S);
if (dofree < 0) Free(S);
UNPROTECT(1);
return ans;
}
void CSparseCholeskyInternal::init() {
// Call the init method of the base class
LinearSolverInternal::init();
AT_.nzmax = input().nnz(); // maximum number of entries
AT_.m = input().size1(); // number of cols
AT_.n = input().size2(); // number of rows
AT_.p = const_cast<int*>(input().colind()); // row pointers (size n+1)
// or row indices (size nzmax)
AT_.i = const_cast<int*>(input().row()); // col indices, size nzmax
AT_.x = &input().front(); // col indices, size nzmax
AT_.nz = -1; // of entries in triplet matrix, -1 for compressed-row
// Temporary
temp_.resize(AT_.n);
if (verbose()) {
userOut() << "CSparseCholeskyInternal::prepare: symbolic factorization" << endl;
}
// ordering and symbolic analysis
int order = 0; // ordering?
if (S_) cs_sfree(S_);
S_ = cs_schol(order, &AT_) ;
}
/**
* @brief Cleans up a sparse matrix factorization.
*
* @param[in] fact Factorization to clean up.
*/
void cs_fact_free( cs_fact_t *fact )
{
if (fact == NULL)
return;
switch (fact->type) {
case CS_FACT_NULL:
break;
case CS_FACT_CHOLESKY:
case CS_FACT_LU:
case CS_FACT_QR:
cs_free( fact->x );
cs_sfree( fact->S );
cs_nfree( fact->N );
break;
case CS_FACT_UMFPACK:
#ifdef USE_UMFPACK
cs_spfree( fact->A );
umfpack_di_free_numeric( &fact->numeric );
free( fact->x );
free( fact->wi );
free( fact->w );
#endif /* USE_UMFPACK */
break;
}
free( fact );
}
void SparseCholeskySolver<TMatrix,TVector>::invert(Matrix& M) {
int order = -1; //?????
if (S) cs_sfree(S);
if (N) cs_nfree(N);
//if (tmp) cs_free(tmp);
M.compress();
A.nzmax = M.getColsValue().size(); // maximum number of entries
A_p = (int *) &(M.getRowBegin()[0]);
A_i = (int *) &(M.getColsIndex()[0]);
A_x.resize(A.nzmax);
for (int i=0;i<A.nzmax;i++) A_x[i] = (double) M.getColsValue()[i];
//remplir A avec M
A.m = M.rowBSize(); // number of rows
A.n = M.colBSize(); // number of columns
A.p = A_p; // column pointers (size n+1) or col indices (size nzmax)
A.i = A_i; // row indices, size nzmax
A.x = (double*) &(A_x[0]); // numerical values, size nzmax
A.nz = -1; // # of entries in triplet matrix, -1 for compressed-col
cs_dropzeros( &A );
//M.check_matrix();
//CompressedRowSparseMatrix<double>::check_matrix(-1 /*A.nzmax*/,A.m,A.n,A.p,A.i,A.x);
//sout << "diag =";
//for (int i=0;i<A.n;++i) sout << " " << M.element(i,i);
//sout << sendl;
//sout << "SparseCholeskySolver: start factorization, n = " << A.n << " nnz = " << A.p[A.n] << sendl;
//tmp = (double *) cs_malloc (A.n, sizeof (double)) ;
tmp.resize(A.n);
S = cs_schol (&A, order) ; /* ordering and symbolic analysis */
N = cs_chol (&A, S) ; /* numeric Cholesky factorization */
//sout << "SparseCholeskySolver: factorization complete, nnz = " << N->L->p[N->L->n] << sendl;
}
/* Modified version of Tim Davis's cs_lu_mex.c file for MATLAB */
void install_lu(SEXP Ap, int order, double tol, Rboolean err_sing)
{
// (order, tol) == (1, 1) by default, when called from R.
SEXP ans;
css *S;
csn *N;
int n, *p, *dims;
CSP A = AS_CSP__(Ap), D;
R_CheckStack();
n = A->n;
if (A->m != n)
error(_("LU decomposition applies only to square matrices"));
if (order) { /* not using natural order */
order = (tol == 1) ? 2 /* amd(S'*S) w/dense rows or I */
: 1; /* amd (A+A'), or natural */
}
S = cs_sqr(order, A, /*qr = */ 0); /* symbolic ordering */
N = cs_lu(A, S, tol); /* numeric factorization */
if (!N) {
if(err_sing)
error(_("cs_lu(A) failed: near-singular A (or out of memory)"));
else {
/* No warning: The useR should be careful :
* Put NA into "LU" factor */
set_factors(Ap, ScalarLogical(NA_LOGICAL), "LU");
return;
}
}
cs_dropzeros(N->L); /* drop zeros from L and sort it */
D = cs_transpose(N->L, 1);
cs_spfree(N->L);
N->L = cs_transpose(D, 1);
cs_spfree(D);
cs_dropzeros(N->U); /* drop zeros from U and sort it */
D = cs_transpose(N->U, 1);
cs_spfree(N->U);
N->U = cs_transpose(D, 1);
cs_spfree(D);
p = cs_pinv(N->pinv, n); /* p=pinv' */
ans = PROTECT(NEW_OBJECT(MAKE_CLASS("sparseLU")));
dims = INTEGER(ALLOC_SLOT(ans, Matrix_DimSym, INTSXP, 2));
dims[0] = n; dims[1] = n;
SET_SLOT(ans, install("L"),
Matrix_cs_to_SEXP(N->L, "dtCMatrix", 0));
SET_SLOT(ans, install("U"),
Matrix_cs_to_SEXP(N->U, "dtCMatrix", 0));
Memcpy(INTEGER(ALLOC_SLOT(ans, Matrix_pSym, /* "p" */
INTSXP, n)), p, n);
if (order)
Memcpy(INTEGER(ALLOC_SLOT(ans, install("q"),
INTSXP, n)), S->q, n);
cs_nfree(N);
cs_sfree(S);
cs_free(p);
UNPROTECT(1);
set_factors(Ap, ans, "LU");
}
/* free workspace for demo3 */
static int done3 (int ok, css *S, csn *N, double *y, cs *W, cs *E, int *p)
{
cs_sfree (S) ;
cs_nfree (N) ;
cs_free (y) ;
cs_spfree (W) ;
cs_spfree (E) ;
cs_free (p) ;
return (ok) ;
}
/* x=A\b where A can be rectangular; b overwritten with solution */
int cs_qrsol (int order, const cs *A, double *b)
{
double *x ;
css *S ;
csn *N ;
cs *AT = NULL ;
int k, m, n, ok ;
if (!CS_CSC (A) || !b) return (0) ; /* check inputs */
n = A->n ;
m = A->m ;
if (m >= n)
{
S = cs_sqr (order, A, 1) ; /* ordering and symbolic analysis */
N = cs_qr (A, S) ; /* numeric QR factorization */
x = cs_calloc (S ? S->m2 : 1, sizeof (double)) ; /* get workspace */
ok = (S && N && x) ;
if (ok)
{
cs_ipvec (S->pinv, b, x, m) ; /* x(0:m-1) = b(p(0:m-1) */
for (k = 0 ; k < n ; k++) /* apply Householder refl. to x */
{
cs_happly (N->L, k, N->B [k], x) ;
}
cs_usolve (N->U, x) ; /* x = R\x */
cs_ipvec (S->q, x, b, n) ; /* b(q(0:n-1)) = x(0:n-1) */
}
}
else
{
AT = cs_transpose (A, 1) ; /* Ax=b is underdetermined */
S = cs_sqr (order, AT, 1) ; /* ordering and symbolic analysis */
N = cs_qr (AT, S) ; /* numeric QR factorization of A' */
x = cs_calloc (S ? S->m2 : 1, sizeof (double)) ; /* get workspace */
ok = (AT && S && N && x) ;
if (ok)
{
cs_pvec (S->q, b, x, m) ; /* x(q(0:m-1)) = b(0:m-1) */
cs_utsolve (N->U, x) ; /* x = R'\x */
for (k = m-1 ; k >= 0 ; k--) /* apply Householder refl. to x */
{
cs_happly (N->L, k, N->B [k], x) ;
}
cs_pvec (S->pinv, x, b, n) ; /* b(0:n-1) = x(p(0:n-1)) */
}
}
cs_free (x) ;
cs_sfree (S) ;
cs_nfree (N) ;
cs_spfree (AT) ;
return (ok) ;
}
/* cs_lu: sparse LU factorization, with optional fill-reducing ordering */
void mexFunction
(
int nargout,
mxArray *pargout [ ],
int nargin,
const mxArray *pargin [ ]
)
{
css *S ;
csn *N ;
cs Amatrix, *A, *D ;
csi n, order, *p ;
double tol ;
if (nargout > 4 || nargin > 3 || nargin < 1)
{
mexErrMsgTxt ("Usage: [L,U,p,q] = cs_lu (A,tol)") ;
}
A = cs_mex_get_sparse (&Amatrix, 1, 1, pargin [0]) ; /* get A */
n = A->n ;
if (nargin == 2) /* determine tol and ordering */
{
tol = mxGetScalar (pargin [1]) ;
order = (nargout == 4) ? 1 : 0 ; /* amd (A+A'), or natural */
}
else
{
tol = 1 ;
order = (nargout == 4) ? 2 : 0 ; /* amd(S'*S) w/dense rows or I */
}
S = cs_sqr (order, A, 0) ; /* symbolic ordering, no QR bound */
N = cs_lu (A, S, tol) ; /* numeric factorization */
if (!N) mexErrMsgTxt ("cs_lu failed (singular, or out of memory)") ;
cs_dropzeros (N->L) ; /* drop zeros from L and sort it */
D = cs_transpose (N->L, 1) ;
cs_spfree (N->L) ;
N->L = cs_transpose (D, 1) ;
cs_spfree (D) ;
cs_dropzeros (N->U) ; /* drop zeros from U and sort it */
D = cs_transpose (N->U, 1) ;
cs_spfree (N->U) ;
N->U = cs_transpose (D, 1) ;
cs_spfree (D) ;
p = cs_pinv (N->pinv, n) ; /* p=pinv' */
pargout [0] = cs_mex_put_sparse (&(N->L)) ; /* return L */
pargout [1] = cs_mex_put_sparse (&(N->U)) ; /* return U */
pargout [2] = cs_mex_put_int (p, n, 1, 1) ; /* return p */
/* return Q */
if (nargout == 4) pargout [3] = cs_mex_put_int (S->q, n, 1, 0) ;
cs_nfree (N) ;
cs_sfree (S) ;
}
// Modified version of Tim Davis's cs_qr_mex.c file for MATLAB (in CSparse)
// Usage: [V,beta,p,R,q] = cs_qr(A) ;
SEXP dgCMatrix_QR(SEXP Ap, SEXP order)
{
CSP A = AS_CSP__(Ap), D;
int io = INTEGER(order)[0];
Rboolean verbose = (io < 0);
int m = A->m, n = A->n, ord = asLogical(order) ? 3 : 0, *p;
R_CheckStack();
if (m < n) error(_("A must have #{rows} >= #{columns}")) ;
SEXP ans = PROTECT(NEW_OBJECT(MAKE_CLASS("sparseQR")));
int *dims = INTEGER(ALLOC_SLOT(ans, Matrix_DimSym, INTSXP, 2));
dims[0] = m; dims[1] = n;
css *S = cs_sqr(ord, A, 1); /* symbolic QR ordering & analysis*/
if (!S) error(_("cs_sqr failed"));
if(verbose && S->m2 > m) // in ./cs.h , m2 := # of rows for QR, after adding fictitious rows
Rprintf("Symbolic QR(): Matrix structurally rank deficient (m2-m = %d)\n",
S->m2 - m);
csn *N = cs_qr(A, S); /* numeric QR factorization */
if (!N) error(_("cs_qr failed")) ;
cs_dropzeros(N->L); /* drop zeros from V and sort */
D = cs_transpose(N->L, 1); cs_spfree(N->L);
N->L = cs_transpose(D, 1); cs_spfree(D);
cs_dropzeros(N->U); /* drop zeros from R and sort */
D = cs_transpose(N->U, 1); cs_spfree(N->U) ;
N->U = cs_transpose(D, 1); cs_spfree(D);
m = N->L->m; /* m may be larger now */
// MM: m := S->m2 also counting the ficticious rows (Tim Davis, p.72, 74f)
p = cs_pinv(S->pinv, m); /* p = pinv' */
SET_SLOT(ans, install("V"),
Matrix_cs_to_SEXP(N->L, "dgCMatrix", 0));
Memcpy(REAL(ALLOC_SLOT(ans, install("beta"),
REALSXP, n)), N->B, n);
Memcpy(INTEGER(ALLOC_SLOT(ans, Matrix_pSym,
INTSXP, m)), p, m);
SET_SLOT(ans, install("R"),
Matrix_cs_to_SEXP(N->U, "dgCMatrix", 0));
if (ord)
Memcpy(INTEGER(ALLOC_SLOT(ans, install("q"),
INTSXP, n)), S->q, n);
else
ALLOC_SLOT(ans, install("q"), INTSXP, 0);
cs_nfree(N);
cs_sfree(S);
cs_free(p);
UNPROTECT(1);
return ans;
}
/* cs_qr: sparse QR factorization */
void mexFunction
(
int nargout,
mxArray *pargout [ ],
int nargin,
const mxArray *pargin [ ]
)
{
css *S ;
csn *N ;
cs Amatrix, *A, *D ;
csi m, n, order, *p ;
if (nargout > 5 || nargin != 1)
{
mexErrMsgTxt ("Usage: [V,beta,p,R,q] = cs_qr(A)") ;
}
A = cs_mex_get_sparse (&Amatrix, 0, 1, pargin [0]) ; /* get A */
m = A->m ;
n = A->n ;
if (m < n) mexErrMsgTxt ("A must have # rows >= # columns") ;
order = (nargout == 5) ? 3 : 0 ; /* determine ordering */
S = cs_sqr (order, A, 1) ; /* symbolic QR ordering & analysis*/
N = cs_qr (A, S) ; /* numeric QR factorization */
if (!N) mexErrMsgTxt ("qr failed") ;
cs_dropzeros (N->L) ; /* drop zeros from V and sort */
D = cs_transpose (N->L, 1) ;
cs_spfree (N->L) ;
N->L = cs_transpose (D, 1) ;
cs_spfree (D) ;
cs_dropzeros (N->U) ; /* drop zeros from R and sort */
D = cs_transpose (N->U, 1) ;
cs_spfree (N->U) ;
N->U = cs_transpose (D, 1) ;
cs_spfree (D) ;
m = N->L->m ; /* m may be larger now */
p = cs_pinv (S->pinv, m) ; /* p = pinv' */
pargout [0] = cs_mex_put_sparse (&(N->L)) ; /* return V */
cs_mex_put_double (n, N->B, &(pargout [1])) ; /* return beta */
pargout [2] = cs_mex_put_int (p, m, 1, 1) ; /* return p */
pargout [3] = cs_mex_put_sparse (&(N->U)) ; /* return R */
pargout [4] = cs_mex_put_int (S->q, n, 1, 0) ; /* return q */
cs_nfree (N) ;
cs_sfree (S) ;
}
void NM_csparse_free(void* p)
{
assert(p);
NumericsSparseLinearSolverParams* ptr = (NumericsSparseLinearSolverParams*) p;
cs_lu_factors* cs_lu_A = NM_csparse_lu_factors(ptr);
if (cs_lu_A)
{
cs_lu_A->n = -1;
cs_sfree(cs_lu_A->S);
cs_lu_A->S = NULL;
cs_nfree(cs_lu_A->N);
cs_lu_A->N = NULL;
free(cs_lu_A);
}
ptr->solver_data = NULL;
}
/**
* @brief Performs Cholesky factorization on a matrix.
*
* @param[in,out] chold Cholesky factorization of the matrix.
* @param[in] A Matrix to factorize.
* @return 0 on success.
*/
static int cs_fact_init_cholesky( cs_fact_t *chold, const cs *A )
{
int order = 1; /* order 0:natural, 1:Chol, 2:LU, 3:QR */
chold->S = cs_schol( order, A );
if (chold->S == NULL)
goto err_S;
chold->N = cs_chol( A, chold->S );
if (chold->N == NULL)
goto err_N;
chold->x = cs_malloc( A->n, sizeof(double) );
if (chold->x == NULL)
goto err_x;
chold->type = CS_FACT_CHOLESKY;
return 0;
err_x:
cs_nfree( chold->N );
err_N:
cs_sfree( chold->S );
err_S:
return -1;
}
/**
* @brief Performs QR factorization on a matrix.
*
* @param[in,out] qrd QR factorization of the matrix.
* @param[in] A Matrix to factorize.
* @return 0 on success.
*/
static int cs_fact_init_qr( cs_fact_t *qrd, const cs *A )
{
int order = 3; /* order 0:natural, 1:Chol, 2:LU, 3:QR */
qrd->S = cs_sqr( order, A, 1 );
if (qrd->S == NULL)
goto err_S;
qrd->N = cs_qr( A, qrd->S );
if (qrd->N == NULL)
goto err_N;
qrd->x = cs_malloc( qrd->S->m2, sizeof(double) );
if (qrd->x == NULL)
goto err_x;
qrd->type = CS_FACT_QR;
return 0;
err_x:
cs_nfree( qrd->N );
err_N:
cs_sfree( qrd->S );
err_S:
return -1;
}
/* x=A\b where A is symmetric positive definite; b overwritten with solution */
CS_INT cs_cholsol (CS_INT order, const cs *A, CS_ENTRY *b)
{
CS_ENTRY *x ;
css *S ;
csn *N ;
CS_INT n, ok ;
if (!CS_CSC (A) || !b) return (0) ; /* check inputs */
n = A->n ;
S = cs_schol (order, A) ; /* ordering and symbolic analysis */
N = cs_chol (A, S) ; /* numeric Cholesky factorization */
x = cs_malloc (n, sizeof (CS_ENTRY)) ; /* get workspace */
ok = (S && N && x) ;
if (ok)
{
cs_ipvec (S->pinv, b, x, n) ; /* x = P*b */
cs_lsolve (N->L, x) ; /* x = L\x */
cs_ltsolve (N->L, x) ; /* x = L'\x */
cs_pvec (S->pinv, x, b, n) ; /* b = P'*x */
}
cs_free (x) ;
cs_sfree (S) ;
cs_nfree (N) ;
return (ok) ;
}
/**
* @brief Performs LU factorization on a matrix.
*
* @param[in,out] lud LU factorization of the matrix.
* @param[in] A Matrix to factorize.
* @return 0 on success.
*/
static int cs_fact_init_lu( cs_fact_t *lud, const cs *A )
{
int order = 2; /* order 0:natural, 1:Chol, 2:LU, 3:QR */
double tol = 1e-16;
lud->S = cs_sqr( order, A, 0 );
if (lud->S == NULL)
goto err_S;
lud->N = cs_lu( A, lud->S, tol );
if (lud->N == NULL)
goto err_N;
lud->x = cs_malloc( A->n, sizeof(double) );
if (lud->x == NULL)
goto err_x;
lud->type = CS_FACT_LU;
return 0;
err_x:
cs_nfree( lud->N );
err_N:
cs_sfree( lud->S );
err_S:
return -1;
}
/* x=A\b where A is unsymmetric; b overwritten with solution */
csi cs_lusol_modifier (csi order, const cs *A, double *b, double *a, double tol)
{
double *x ;
css *S ;
csn *N ;
csi n, ok ;
// if (!CS_CSC (A) || !b) return (0) ; /* check inputs */
n = A->n ;
S = cs_sqr (order, A, 0) ; /* ordering and symbolic analysis */
N = cs_lu (A, S, tol) ; /* numeric LU factorization */
x = cs_malloc (n, sizeof (double)) ; /* get workspace */
// ok = (S && N && x) ;
//if (ok)
//{
cs_ipvec (N->pinv, b, x, n) ; /* x = b(p) */
cs_lsolve (N->L, x) ; /* x = L\x */
cs_usolve (N->U, x) ; /* x = U\x */
cs_ipvec (S->q, x, a, n) ; /* b(q) = x */
// }
cs_free (x) ;
cs_sfree (S) ;
cs_nfree (N) ;
return (ok) ;
}
CsparseInterface::~CsparseInterface() {
if (S_) cs_sfree(S_);
if (N_) cs_nfree(N_);
}
SparseCholeskySolver<TMatrix,TVector>::~SparseCholeskySolver() {
if (S) cs_sfree (S);
if (N) cs_nfree (N);
}
CSparseInternal::~CSparseInternal(){
if(S_) cs_sfree(S_);
if(N_) cs_nfree(N_);
}
void CSparseInternal::prepare(){
if(!called_once_){
// ordering and symbolic analysis
int order = 3; // ordering?
int qr = 1; // LU
if(S_) cs_sfree(S_);
S_ = cs_sqr (order, &AT_, qr) ;
std::vector<int> pinv;
std::vector<int> q;
std::vector<int> parent;
std::vector<int> cp;
std::vector<int> leftmost;
int m2;
double lnz;
double unz;
input().sparsity()->prefactorize(order, qr, pinv, q, parent, cp, leftmost, m2, lnz, unz);
cout << "pinv" << endl;
cout << pinv << endl;
if(S_->pinv!=0)
cout << vector<int>(S_->pinv, S_->pinv + pinv.size()) << endl;
cout << endl;
cout << "q" << endl;
cout << q << endl;
if(S_->q!=0)
cout << vector<int>(S_->q, S_->q + q.size()) << endl;
cout << endl;
cout << "parent" << endl;
cout << parent << endl;
if(S_->parent!=0)
cout << vector<int>(S_->parent, S_->parent + parent.size()) << endl;
cout << endl;
cout << "cp" << endl;
cout << cp << endl;
if(S_->cp!=0)
cout << vector<int>(S_->cp, S_->cp + cp.size()) << endl;
cout << endl;
cout << "leftmost" << endl;
cout << leftmost << endl;
if(S_->leftmost!=0)
cout << vector<int>(S_->leftmost, S_->leftmost + leftmost.size()) << endl;
cout << endl;
}
prepared_ = false;
called_once_ = true;
double tol = 1e-8;
if(N_) cs_nfree(N_);
N_ = cs_lu(&AT_, S_, tol) ; // numeric LU factorization
if(N_==0){
throw CasadiException("factorization failed, Jacobian singular?");
}
casadi_assert(N_!=0);
prepared_ = true;
}
void solveSparse(double time){
int i;
double current_value;
double *B_sparse_temp;
//Adeiasma twn arxeiwn sta opoia tha apothikeutoun ta apotelesmata tis analysis gia tous komvous PLOT
if(TRAN==0)initPlotFiles("Sparse");
if(ITER==0)
{
//LU decomposition
S=cs_sqr(2,C_sparse,0);
N=cs_lu(C_sparse,S,1);
//cs_spfree(C_sparse);
}
B_sparse_temp = (double *)calloc(sizeB,sizeof(double)); //apothikeusi tou apotelesmatos tis LU solve gia to sweep kai to transient
if(dc_sweep==0){ //An den exoume sweep
for(i=0;i<sizeB;i++)B_sparse_temp[i]=B_sparse[i];
if (ITER == 0){ //LU solve
cs_ipvec(N->pinv, B_sparse, x_sparse, sizeB); //seg fault gia choleskyNetlist!LA8OS TO N!ARA ANADROMIKA LA8OS TO C_sparse.Omws C_sparce swsto vash ths CG.
cs_lsolve(N->L, x_sparse);
cs_usolve(N->U, x_sparse);
cs_ipvec(S->q, x_sparse, B_sparse, sizeB);
//printf("\n ----- SPARSE LU decomposition ----- \n");
for(i=0;i<sizeB;i++){x_sparse[i]=B_sparse[i];}
cs_nfree(N);
cs_sfree(S);
}else{
bi_conjugate_gradient_sparse(C_sparse,B_sparse, sizeB, x_sparse, itol_value);
//printf("\n");
//printf("---- BI-CG SPARSE ----\n");
}
/*
printf("X = \n");
for(i=0;i<sizeB;i++){
printf(" %.6lf \n",x_sparse[i]);
}
printf("----------------------\n");
printf("\n");
*/
if(TRAN==0){
plotFiles("Sparse", x_sparse, -1.0, "Analysis: DC");
}else{
plotFiles("Sparse", x_sparse, time, "Analysis: TRAN");
}
for(i=0;i<sizeB;i++)B_sparse[i]=B_sparse_temp[i]; //epanafora tou B_sparse gia xrisi sto transient
}
else //DC_SWEEP != 0
{
if(sweep_source!=-1){ //pigi tashs ginetai sweep
for(current_value=start_value; current_value<=end_value+EPS; current_value+=sweep_step){
B_sparse[sweep_source-1]=current_value;
if(ITER == 0){
cs_ipvec(N->pinv, B_sparse, x_sparse, sizeB);
cs_lsolve(N->L, x_sparse);
cs_usolve(N->U, x_sparse);
cs_ipvec(S->q, x_sparse, B_sparse_temp, sizeB);
}else{
bi_conjugate_gradient_sparse(C_sparse,B_sparse, sizeB, x_sparse, itol_value);
}
//Apothikeusi twn apotelesmatwn tis analysis gia tous komvous PLOT
plotFiles("Sparse", (ITER ? x_sparse:B_sparse_temp), current_value, "Sweep source voltage at");
}
}else{ //pigi reumatos ginetai sweep
//Anairesi twn praksewn + kai - apo tin arxiki timi tis pigis ston pinaka B
//kai praksi + kai - me to start_value
if(sweep_posNode!=0){
B_sparse[sweep_posNode-1]+=sweep_value_I-start_value;
}
if(sweep_negNode!=0){
B_sparse[sweep_negNode-1]-=sweep_value_I+start_value;
}
for(current_value=start_value;current_value<=end_value+EPS;current_value+=sweep_step){
if(ITER == 0){
cs_ipvec(N->pinv, B_sparse, x_sparse, sizeB);
cs_lsolve(N->L, x_sparse);
cs_usolve(N->U, x_sparse);
cs_ipvec(S->q, x_sparse, B_sparse_temp,sizeB);
}else{
bi_conjugate_gradient_sparse(C_sparse,B_sparse, sizeB, x_sparse, itol_value);
}
//Allagi twn timwn ston pinaka B gia to epomeno vima tou sweep
if(sweep_posNode!=0){
B_sparse[sweep_posNode-1]-=sweep_step;
}
if(sweep_negNode!=0){
B_sparse[sweep_negNode-1]+=sweep_step;
}
//Apothikeusi twn apotelesmatwn tis analysis gia tous komvous PLOT se arxeia
plotFiles("Sparse", (ITER ? x_sparse:B_sparse_temp), current_value, "Sweep source current at");
}
printf("\n");
}
}
free(B_sparse_temp);
}
CSparseCholeskyInternal::~CSparseCholeskyInternal(){
if(S_) cs_sfree(S_);
if(L_) cs_nfree(L_);
}
void CsparseInterface::prepare() {
double time_start=0;
if (CasadiOptions::profiling && CasadiOptions::profilingBinary) {
time_start = getRealTime(); // Start timer
profileWriteEntry(CasadiOptions::profilingLog, this);
}
if (!called_once_) {
if (verbose()) {
cout << "CsparseInterface::prepare: symbolic factorization" << endl;
}
// ordering and symbolic analysis
int order = 0; // ordering?
if (S_) cs_sfree(S_);
S_ = cs_sqr(order, &A_, 0) ;
}
prepared_ = false;
called_once_ = true;
// Get a referebce to the nonzeros of the linear system
const vector<double>& linsys_nz = input().data();
// Make sure that all entries of the linear system are valid
for (int k=0; k<linsys_nz.size(); ++k) {
casadi_assert_message(!isnan(linsys_nz[k]), "Nonzero " << k << " is not-a-number");
casadi_assert_message(!isinf(linsys_nz[k]), "Nonzero " << k << " is infinite");
}
if (verbose()) {
cout << "CsparseInterface::prepare: numeric factorization" << endl;
cout << "linear system to be factorized = " << endl;
input(0).printSparse();
}
double tol = 1e-8;
if (N_) cs_nfree(N_);
N_ = cs_lu(&A_, S_, tol) ; // numeric LU factorization
if (N_==0) {
DMatrix temp = input();
temp.makeSparse();
if (temp.sparsity().isSingular()) {
stringstream ss;
ss << "CsparseInterface::prepare: factorization failed due to matrix"
" being singular. Matrix contains numerical zeros which are "
"structurally non-zero. Promoting these zeros to be structural "
"zeros, the matrix was found to be structurally rank deficient."
" sprank: " << sprank(temp.sparsity()) << " <-> " << temp.size2() << endl;
if (verbose()) {
ss << "Sparsity of the linear system: " << endl;
input(LINSOL_A).sparsity().print(ss); // print detailed
}
throw CasadiException(ss.str());
} else {
stringstream ss;
ss << "CsparseInterface::prepare: factorization failed, check if Jacobian is singular"
<< endl;
if (verbose()) {
ss << "Sparsity of the linear system: " << endl;
input(LINSOL_A).sparsity().print(ss); // print detailed
}
throw CasadiException(ss.str());
}
}
casadi_assert(N_!=0);
prepared_ = true;
if (CasadiOptions::profiling && CasadiOptions::profilingBinary) {
double time_stop = getRealTime(); // Stop timer
profileWriteTime(CasadiOptions::profilingLog, this, 0,
time_stop-time_start,
time_stop-time_start);
profileWriteExit(CasadiOptions::profilingLog, this, time_stop-time_start);
}
}
CsparseCholMemory::~CsparseCholMemory() {
if (this->S) cs_sfree(this->S);
if (this->L) cs_nfree(this->L);
}
/* Modified version of Tim Davis's cs_lu_mex.c file for MATLAB */
void install_lu(SEXP Ap, int order, double tol, Rboolean err_sing, Rboolean keep_dimnms)
{
// (order, tol) == (1, 1) by default, when called from R.
SEXP ans;
css *S;
csn *N;
int n, *p, *dims;
CSP A = AS_CSP__(Ap), D;
R_CheckStack();
n = A->n;
if (A->m != n)
error(_("LU decomposition applies only to square matrices"));
if (order) { /* not using natural order */
order = (tol == 1) ? 2 /* amd(S'*S) w/dense rows or I */
: 1; /* amd (A+A'), or natural */
}
S = cs_sqr(order, A, /*qr = */ 0); /* symbolic ordering */
N = cs_lu(A, S, tol); /* numeric factorization */
if (!N) {
if(err_sing)
error(_("cs_lu(A) failed: near-singular A (or out of memory)"));
else {
/* No warning: The useR should be careful :
* Put NA into "LU" factor */
set_factors(Ap, ScalarLogical(NA_LOGICAL), "LU");
return;
}
}
cs_dropzeros(N->L); /* drop zeros from L and sort it */
D = cs_transpose(N->L, 1);
cs_spfree(N->L);
N->L = cs_transpose(D, 1);
cs_spfree(D);
cs_dropzeros(N->U); /* drop zeros from U and sort it */
D = cs_transpose(N->U, 1);
cs_spfree(N->U);
N->U = cs_transpose(D, 1);
cs_spfree(D);
p = cs_pinv(N->pinv, n); /* p=pinv' */
ans = PROTECT(NEW_OBJECT(MAKE_CLASS("sparseLU")));
dims = INTEGER(ALLOC_SLOT(ans, Matrix_DimSym, INTSXP, 2));
dims[0] = n; dims[1] = n;
SEXP dn; Rboolean do_dn = FALSE;
if(keep_dimnms) {
dn = GET_SLOT(Ap, Matrix_DimNamesSym);
do_dn = !isNull(VECTOR_ELT(dn, 0));
if(do_dn) {
dn = PROTECT(duplicate(dn));
// permute rownames by p : rn <- rn[ p ] :
SEXP rn = PROTECT(duplicate(VECTOR_ELT(dn, 0)));
for(int i=0; i < n; i++)
SET_STRING_ELT(VECTOR_ELT(dn, 0), i, STRING_ELT(rn, p[i]));
UNPROTECT(1); // rn
SET_VECTOR_ELT(dn, 1, R_NilValue); // colnames(.) := NULL
}
}
SET_SLOT(ans, install("L"),
Matrix_cs_to_SEXP(N->L, "dtCMatrix", 0, do_dn ? dn : R_NilValue));
if(keep_dimnms) {
if(do_dn) {
UNPROTECT(1); // dn
dn = GET_SLOT(Ap, Matrix_DimNamesSym);
}
do_dn = !isNull(VECTOR_ELT(dn, 1));
if(do_dn) {
dn = PROTECT(duplicate(dn));
if(order) { // permute colnames by S->q : cn <- cn[ S->q ] :
SEXP cn = PROTECT(duplicate(VECTOR_ELT(dn, 1)));
for(int j=0; j < n; j++)
SET_STRING_ELT(VECTOR_ELT(dn, 1), j, STRING_ELT(cn, S->q[j]));
UNPROTECT(1); // cn
}
SET_VECTOR_ELT(dn, 0, R_NilValue); // rownames(.) := NULL
}
}
SET_SLOT(ans, install("U"),
Matrix_cs_to_SEXP(N->U, "dtCMatrix", 0, do_dn ? dn : R_NilValue));
if(do_dn) UNPROTECT(1); // dn
Memcpy(INTEGER(ALLOC_SLOT(ans, Matrix_pSym, /* "p" */
INTSXP, n)), p, n);
if (order)
Memcpy(INTEGER(ALLOC_SLOT(ans, install("q"),
INTSXP, n)), S->q, n);
cs_nfree(N);
cs_sfree(S);
cs_free(p);
UNPROTECT(1);
set_factors(Ap, ans, "LU");
}
// Modified version of Tim Davis's cs_qr_mex.c file for MATLAB (in CSparse)
// Usage: [V,beta,p,R,q] = cs_qr(A) ;
SEXP dgCMatrix_QR(SEXP Ap, SEXP order, SEXP keep_dimnames)
{
CSP A = AS_CSP__(Ap), D;
int io = INTEGER(order)[0];
Rboolean verbose = (io < 0);// verbose=TRUE, encoded with negative 'order'
int m0 = A->m, m = m0, n = A->n, ord = asLogical(order) ? 3 : 0, *p;
R_CheckStack();
if (m < n) error(_("A must have #{rows} >= #{columns}")) ;
SEXP ans = PROTECT(NEW_OBJECT(MAKE_CLASS("sparseQR")));
int *dims = INTEGER(ALLOC_SLOT(ans, Matrix_DimSym, INTSXP, 2));
dims[0] = m; dims[1] = n;
css *S = cs_sqr(ord, A, 1); /* symbolic QR ordering & analysis*/
if (!S) error(_("cs_sqr failed"));
int keep_dimnms = asLogical(keep_dimnames);
if(keep_dimnms == NA_LOGICAL) { keep_dimnms = TRUE;
warning(_("dgcMatrix_QR(*, keep_dimnames = NA): NA taken as TRUE"));
}
if(verbose && S->m2 > m) // in ./cs.h , m2 := # of rows for QR, after adding fictitious rows
Rprintf("Symbolic QR(): Matrix structurally rank deficient (m2-m = %d)\n",
S->m2 - m);
csn *N = cs_qr(A, S); /* numeric QR factorization */
if (!N) error(_("cs_qr failed")) ;
cs_dropzeros(N->L); /* drop zeros from V and sort */
D = cs_transpose(N->L, 1); cs_spfree(N->L);
N->L = cs_transpose(D, 1); cs_spfree(D);
cs_dropzeros(N->U); /* drop zeros from R and sort */
D = cs_transpose(N->U, 1); cs_spfree(N->U) ;
N->U = cs_transpose(D, 1); cs_spfree(D);
m = N->L->m; /* m may be larger now */
// MM: m := S->m2 also counting the ficticious rows (Tim Davis, p.72, 74f)
p = cs_pinv(S->pinv, m); /* p = pinv' */
SEXP dn = R_NilValue; Rboolean do_dn = FALSE;
if(keep_dimnms) {
dn = GET_SLOT(Ap, Matrix_DimNamesSym);
do_dn = !isNull(VECTOR_ELT(dn, 0)) && m == m0;
// FIXME? also deal with case m > m0 ?
if(do_dn) { // keep rownames
dn = PROTECT(duplicate(dn));
SET_VECTOR_ELT(dn, 1, R_NilValue);
} else dn = R_NilValue;
}
SET_SLOT(ans, Matrix_VSym, Matrix_cs_to_SEXP(N->L, "dgCMatrix", 0, dn)); // "V"
Memcpy(REAL(ALLOC_SLOT(ans, Matrix_betaSym, REALSXP, n)), N->B, n);
Memcpy(INTEGER(ALLOC_SLOT(ans, Matrix_pSym, INTSXP, m)), p, m);
if(do_dn) {
UNPROTECT(1); // dn
dn = R_NilValue; do_dn = FALSE;
}
if (ord) {
Memcpy(INTEGER(ALLOC_SLOT(ans, install("q"), INTSXP, n)), S->q, n);
if(keep_dimnms) {
dn = GET_SLOT(Ap, Matrix_DimNamesSym);
do_dn = !isNull(VECTOR_ELT(dn, 1));
if(do_dn) {
dn = PROTECT(duplicate(dn));
// permute colnames by S->q : cn <- cn[ S->q ] :
SEXP cns = PROTECT(duplicate(VECTOR_ELT(dn, 1)));
for(int j=0; j < n; j++)
SET_STRING_ELT(VECTOR_ELT(dn, 1), j, STRING_ELT(cns, S->q[j]));
UNPROTECT(1);
SET_VECTOR_ELT(dn, 0, R_NilValue);
} else dn = R_NilValue;
}
} else
ALLOC_SLOT(ans, install("q"), INTSXP, 0);
SET_SLOT(ans, install("R"), Matrix_cs_to_SEXP(N->U, "dgCMatrix", 0, dn));
if(do_dn) UNPROTECT(1); // dn
cs_nfree(N);
cs_sfree(S);
cs_free(p);
UNPROTECT(1);
return ans;
}
