SEXP dtCMatrix_sparse_solve(SEXP a, SEXP b)
{
SEXP ans = PROTECT(NEW_OBJECT(MAKE_CLASS("dgCMatrix")));
CSP A = AS_CSP(a), B = AS_CSP(b);
int *xp = INTEGER(ALLOC_SLOT(ans, Matrix_pSym, INTSXP, (B->n) + 1)),
xnz = 10 * B->p[B->n]; /* initial estimate of nnz in x */
int *ti = Calloc(xnz, int), k, lo = uplo_P(a)[0] == 'L', pos = 0;
double *tx = Calloc(xnz, double);
double *wrk = Alloca(A->n, double);
int *xi = Alloca(2*A->n, int); /* for cs_reach */
R_CheckStack();
if (A->m != A->n || B->n < 1 || A->n < 1 || A->n != B->m)
error(_("Dimensions of system to be solved are inconsistent"));
slot_dup(ans, b, Matrix_DimSym);
SET_DimNames(ans, b);
xp[0] = 0;
for (k = 0; k < B->n; k++) {
int top = cs_spsolve (A, B, k, xi, wrk, (int *)NULL, lo);
int nz = A->n - top, p;
xp[k + 1] = nz + xp[k];
if (xp[k + 1] > xnz) {
while (xp[k + 1] > xnz) xnz *= 2;
ti = Realloc(ti, xnz, int);
tx = Realloc(tx, xnz, double);
}
if (lo) /* increasing row order */
for(p = top; p < A->n; p++, pos++) {
ti[pos] = xi[p];
tx[pos] = wrk[xi[p]];
}
else /* decreasing order, reverse copy */
for(p = A->n - 1; p >= top; p--, pos++) {
ti[pos] = xi[p];
tx[pos] = wrk[xi[p]];
}
}
xnz = xp[B->n];
Memcpy(INTEGER(ALLOC_SLOT(ans, Matrix_iSym, INTSXP, xnz)), ti, xnz);
Memcpy( REAL(ALLOC_SLOT(ans, Matrix_xSym, REALSXP, xnz)), tx, xnz);
Free(ti); Free(tx);
UNPROTECT(1);
return ans;
}
void mexFunction
(
int nargout,
mxArray *pargout [ ],
int nargin,
const mxArray *pargin [ ]
)
{
cs Umatrix, Bmatrix, *U, *B, *X ;
double *x, *b ;
int top, nz, p, *xi ;
if (nargout > 1 || nargin != 2)
{
mexErrMsgTxt ("Usage: x = cs_usolve(U,b)") ;
}
U = cs_mex_get_sparse (&Umatrix, 1, 1, pargin [0]) ; /* get U */
if (mxIsSparse (pargin [1]))
{
B = cs_mex_get_sparse (&Bmatrix, 0, 1, pargin [1]) ;/* get sparse b */
cs_mex_check (0, U->n, 1, 0, 1, 1, pargin [1]) ;
xi = cs_malloc (2*U->n, sizeof (int)) ; /* get workspace */
x = cs_malloc (U->n, sizeof (double)) ;
top = cs_spsolve (U, B, 0, xi, x, NULL, 0) ; /* x = U\b */
X = cs_spalloc (U->n, 1, U->n-top, 1, 0) ; /* create sparse x*/
X->p [0] = 0 ;
nz = 0 ;
for (p = top ; p < U->n ; p++)
{
X->i [nz] = xi [p] ;
X->x [nz++] = x [xi [p]] ;
}
X->p [1] = nz ;
pargout [0] = cs_mex_put_sparse (&X) ;
cs_free (x) ;
cs_free (xi) ;
}
else
{
b = cs_mex_get_double (U->n, pargin [1]) ; /* get full b */
x = cs_mex_put_double (U->n, b, &(pargout [0])) ; /* x = b */
cs_usolve (U, x) ; /* x = U\x */
}
}
/* [L,U,pinv]=lu(A, [q lnz unz]). lnz and unz can be guess */
csn *cs_lu (const cs *A, const css *S, double tol)
{
cs *L, *U ;
csn *N ;
double pivot, *Lx, *Ux, *x, a, t ;
int *Lp, *Li, *Up, *Ui, *pinv, *xi, *q, n, ipiv, k, top, p, i, col, lnz,unz;
if (!CS_CSC (A) || !S) return (NULL) ; /* check inputs */
n = A->n ;
q = S->q ; lnz = S->lnz ; unz = S->unz ;
x = cs_malloc (n, sizeof (double)) ; /* get double workspace */
xi = cs_malloc (2*n, sizeof (int)) ; /* get int workspace */
N = cs_calloc (1, sizeof (csn)) ; /* allocate result */
if (!x || !xi || !N) return (cs_ndone (N, NULL, xi, x, 0)) ;
N->L = L = cs_spalloc (n, n, lnz, 1, 0) ; /* allocate result L */
N->U = U = cs_spalloc (n, n, unz, 1, 0) ; /* allocate result U */
N->pinv = pinv = cs_malloc (n, sizeof (int)) ; /* allocate result pinv */
if (!L || !U || !pinv) return (cs_ndone (N, NULL, xi, x, 0)) ;
Lp = L->p ; Up = U->p ;
for (i = 0 ; i < n ; i++) x [i] = 0 ; /* clear workspace */
for (i = 0 ; i < n ; i++) pinv [i] = -1 ; /* no rows pivotal yet */
for (k = 0 ; k <= n ; k++) Lp [k] = 0 ; /* no cols of L yet */
lnz = unz = 0 ;
for (k = 0 ; k < n ; k++) /* compute L(:,k) and U(:,k) */
{
/* --- Triangular solve --------------------------------------------- */
Lp [k] = lnz ; /* L(:,k) starts here */
Up [k] = unz ; /* U(:,k) starts here */
if ((lnz + n > L->nzmax && !cs_sprealloc (L, 2*L->nzmax + n)) ||
(unz + n > U->nzmax && !cs_sprealloc (U, 2*U->nzmax + n)))
{
return (cs_ndone (N, NULL, xi, x, 0)) ;
}
Li = L->i ; Lx = L->x ; Ui = U->i ; Ux = U->x ;
col = q ? (q [k]) : k ;
top = cs_spsolve (L, A, col, xi, x, pinv, 1) ; /* x = L\A(:,col) */
/* --- Find pivot --------------------------------------------------- */
ipiv = -1 ;
a = -1 ;
for (p = top ; p < n ; p++)
{
i = xi [p] ; /* x(i) is nonzero */
if (pinv [i] < 0) /* row i is not yet pivotal */
{
if ((t = fabs (x [i])) > a)
{
a = t ; /* largest pivot candidate so far */
ipiv = i ;
}
}
else /* x(i) is the entry U(pinv[i],k) */
{
Ui [unz] = pinv [i] ;
Ux [unz++] = x [i] ;
}
}
if (ipiv == -1 || a <= 0)
return (cs_ndone (N, NULL, xi, x, 0)) ;
if (pinv [col] < 0 && fabs (x [col]) >= a*tol) ipiv = col ;
/* --- Divide by pivot ---------------------------------------------- */
pivot = x [ipiv] ; /* the chosen pivot */
Ui [unz] = k ; /* last entry in U(:,k) is U(k,k) */
Ux [unz++] = pivot ;
pinv [ipiv] = k ; /* ipiv is the kth pivot row */
Li [lnz] = ipiv ; /* first entry in L(:,k) is L(k,k) = 1 */
Lx [lnz++] = 1 ;
for (p = top ; p < n ; p++) /* L(k+1:n,k) = x / pivot */
{
i = xi [p] ;
if (pinv [i] < 0) /* x(i) is an entry in L(:,k) */
{
Li [lnz] = i ; /* save unpermuted row in L */
Lx [lnz++] = x [i] / pivot ; /* scale pivot column */
}
x [i] = 0 ; /* x [0..n-1] = 0 for next k */
}
}
/* --- Finalize L and U ------------------------------------------------- */
Lp [n] = lnz ;
Up [n] = unz ;
Li = L->i ; /* fix row indices of L for final pinv */
for (p = 0 ; p < lnz ; p++) Li [p] = pinv [Li [p]] ;
cs_sprealloc (L, 0) ; /* remove extra space from L and U */
cs_sprealloc (U, 0) ;
return (cs_ndone (N, NULL, xi, x, 1)) ; /* success */
}