/**
* Apply Householder transformations and the row permutation P to y
*
* @param a sparse matrix containing the vectors defining the
* Householder transformations
* @param beta scaling factors for the Householder transformations
* @param y contents of a V->m by nrhs dense matrix
* @param p 0-based permutation vector of length V->m
* @param nrhs number of right hand sides (i.e. ncol(y))
* @param trans logical value - if TRUE create Q'y[p] otherwise Qy[p]
*/
static
void sparseQR_Qmult(cs *V, double *beta, int *p, int trans,
double *y, int *ydims)
{
int j, k, m = V->m, n = V->n;
double *x = Alloca(m, double); /* workspace */
R_CheckStack();
if (ydims[0] != m)
error(_("Dimensions of system are inconsistent"));
for (j = 0; j < ydims[1]; j++) {
double *yj = y + j * m;
if (trans) {
cs_pvec(p, yj, x, m); /* x(0:m-1) = y(p(0:m-1, j)) */
Memcpy(yj, x, m); /* replace it */
for (k = 0 ; k < n ; k++) /* apply H[1]...H[n] */
cs_happly(V, k, beta[k], yj);
} else {
for (k = n - 1 ; k >= 0 ; k--) /* apply H[n]...H[1] */
cs_happly(V, k, beta[k], yj);
cs_ipvec(p, yj, x, m); /* inverse permutation */
Memcpy(yj, x, m);
}
}
}
/* 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) ;
}
/**
* @brief Solves a sparse matrix factorization.
*
* This solves Ax = b.
*
* @param[in,out] b Input right side vector that gets set to the output solution.
* @param[in] fact Factorization of the sparse matrix.
*/
void cs_fact_solve( double *b, cs_fact_t *fact )
{
#ifdef USE_UMFPACK
int ret;
double info[ UMFPACK_INFO ];
int fnan, finf;
#endif /* USE_UMFPACK */
int k;
switch (fact->type) {
case CS_FACT_CHOLESKY:
cs_ipvec( fact->S->pinv, b, fact->x, fact->n );
cs_lsolve( fact->N->L, fact->x );
cs_ltsolve( fact->N->L, fact->x );
cs_pvec( fact->S->pinv, fact->x, b, fact->n );
break;
case CS_FACT_LU:
cs_ipvec( fact->N->pinv, b, fact->x, fact->n );
cs_lsolve( fact->N->L, fact->x );
cs_usolve( fact->N->U, fact->x );
cs_ipvec( fact->S->q, fact->x, b, fact->n );
break;
case CS_FACT_QR:
cs_ipvec( fact->S->pinv, b, fact->x, fact->n );
for (k=0; k<fact->n; k++)
cs_happly( fact->N->L, k, fact->N->B[k], fact->x );
cs_usolve( fact->N->U, fact->x );
cs_ipvec( fact->S->q, fact->x, b, fact->n );
break;
case CS_FACT_UMFPACK:
#ifdef USE_UMFPACK
ret = umfpack_di_wsolve( UMFPACK_A, /* Solving Ax=b problem. */
fact->A->p, fact->A->i, fact->A->x,
fact->x, b, fact->numeric, NULL, info, fact->wi, fact->w );
if (ret == UMFPACK_WARNING_singular_matrix) {
fprintf( stderr, "UMFPACK: wsolver Matrix singular!\n" );
fnan = 0;
finf = 0;
for (k=0; k<fact->n; k++) {
if (isnan(fact->x[k])) {
fact->x[k] = 0.;
fnan = 1;
}
else if (isinf(fact->x[k])) {
fact->x[k] = 0.;
finf = 1;
}
}
if (fnan)
fprintf( stderr, "UMFPACK: NaN values detected!\n" );
if (finf)
fprintf( stderr, "UMFPACK: Infinity values detected!\n" );
}
memcpy( b, fact->x, fact->n*sizeof(double) );
#endif /* USE_UMFPACK */
default:
break;
}
}
/* sparse QR factorization [V,beta,pinv,R] = qr (A) */
csn *cs_qr (const cs *A, const css *S)
{
CS_ENTRY *Rx, *Vx, *Ax, *x ;
double *Beta ;
CS_INT i, k, p, m, n, vnz, p1, top, m2, len, col, rnz, *s, *leftmost, *Ap, *Ai,
*parent, *Rp, *Ri, *Vp, *Vi, *w, *pinv, *q ;
cs *R, *V ;
csn *N ;
if (!CS_CSC (A) || !S) return (NULL) ;
m = A->m ; n = A->n ; Ap = A->p ; Ai = A->i ; Ax = A->x ;
q = S->q ; parent = S->parent ; pinv = S->pinv ; m2 = S->m2 ;
vnz = S->lnz ; rnz = S->unz ; leftmost = S->leftmost ;
w = cs_malloc (m2+n, sizeof (CS_INT)) ; /* get CS_INT workspace */
x = cs_malloc (m2, sizeof (CS_ENTRY)) ; /* get CS_ENTRY workspace */
N = cs_calloc (1, sizeof (csn)) ; /* allocate result */
if (!w || !x || !N) return (cs_ndone (N, NULL, w, x, 0)) ;
s = w + m2 ; /* s is size n */
for (k = 0 ; k < m2 ; k++) x [k] = 0 ; /* clear workspace x */
N->L = V = cs_spalloc (m2, n, vnz, 1, 0) ; /* allocate result V */
N->U = R = cs_spalloc (m2, n, rnz, 1, 0) ; /* allocate result R */
N->B = Beta = cs_malloc (n, sizeof (double)) ; /* allocate result Beta */
if (!R || !V || !Beta) return (cs_ndone (N, NULL, w, x, 0)) ;
Rp = R->p ; Ri = R->i ; Rx = R->x ;
Vp = V->p ; Vi = V->i ; Vx = V->x ;
for (i = 0 ; i < m2 ; i++) w [i] = -1 ; /* clear w, to mark nodes */
rnz = 0 ; vnz = 0 ;
for (k = 0 ; k < n ; k++) /* compute V and R */
{
Rp [k] = rnz ; /* R(:,k) starts here */
Vp [k] = p1 = vnz ; /* V(:,k) starts here */
w [k] = k ; /* add V(k,k) to pattern of V */
Vi [vnz++] = k ;
top = n ;
col = q ? q [k] : k ;
for (p = Ap [col] ; p < Ap [col+1] ; p++) /* find R(:,k) pattern */
{
i = leftmost [Ai [p]] ; /* i = min(find(A(i,q))) */
for (len = 0 ; w [i] != k ; i = parent [i]) /* traverse up to k */
{
s [len++] = i ;
w [i] = k ;
}
while (len > 0) s [--top] = s [--len] ; /* push path on stack */
i = pinv [Ai [p]] ; /* i = permuted row of A(:,col) */
x [i] = Ax [p] ; /* x (i) = A(:,col) */
if (i > k && w [i] < k) /* pattern of V(:,k) = x (k+1:m) */
{
Vi [vnz++] = i ; /* add i to pattern of V(:,k) */
w [i] = k ;
}
}
for (p = top ; p < n ; p++) /* for each i in pattern of R(:,k) */
{
i = s [p] ; /* R(i,k) is nonzero */
cs_happly (V, i, Beta [i], x) ; /* apply (V(i),Beta(i)) to x */
Ri [rnz] = i ; /* R(i,k) = x(i) */
Rx [rnz++] = x [i] ;
x [i] = 0 ;
if (parent [i] == k) vnz = cs_scatter (V, i, 0, w, NULL, k, V, vnz);
}
for (p = p1 ; p < vnz ; p++) /* gather V(:,k) = x */
{
Vx [p] = x [Vi [p]] ;
x [Vi [p]] = 0 ;
}
Ri [rnz] = k ; /* R(k,k) = norm (x) */
Rx [rnz++] = cs_house (Vx+p1, Beta+k, vnz-p1) ; /* [v,beta]=house(x) */
}
Rp [n] = rnz ; /* finalize R */
Vp [n] = vnz ; /* finalize V */
return (cs_ndone (N, NULL, w, x, 1)) ; /* success */
}
