/* return a complex sparse matrix to MATLAB */
mxArray *cs_cl_mex_put_sparse (cs_cl **Ahandle)
{
cs_cl *A ;
double *x, *z ;
mxArray *Amatlab ;
CS_INT k ;
A = *Ahandle ;
if (!A) mexErrMsgTxt ("failed") ;
Amatlab = mxCreateSparse (0, 0, 0, mxCOMPLEX) ;
mxSetM (Amatlab, A->m) ;
mxSetN (Amatlab, A->n) ;
mxSetNzmax (Amatlab, A->nzmax) ;
cs_cl_free (mxGetJc (Amatlab)) ;
cs_cl_free (mxGetIr (Amatlab)) ;
cs_cl_free (mxGetPr (Amatlab)) ;
cs_cl_free (mxGetPi (Amatlab)) ;
mxSetJc (Amatlab, (void *) (A->p)) ; /* assign A->p pointer to MATLAB A */
mxSetIr (Amatlab, (void *) (A->i)) ;
x = cs_dl_malloc (A->nzmax, sizeof (double)) ;
z = cs_dl_malloc (A->nzmax, sizeof (double)) ;
for (k = 0 ; k < A->nzmax ; k++)
{
x [k] = creal (A->x [k]) ; /* copy and split numerical values */
z [k] = cimag (A->x [k]) ;
}
cs_cl_free (A->x) ; /* free copy of complex values */
mxSetPr (Amatlab, x) ;
mxSetPi (Amatlab, z) ;
cs_cl_free (A) ; /* frees A struct only, not A->p, etc */
*Ahandle = NULL ;
return (Amatlab) ;
}
mxArray *spqr_mx_put_sparse
(
cholmod_sparse **Ahandle, // CHOLMOD version of the matrix
cholmod_common *cc
)
{
mxArray *Amatlab ;
cholmod_sparse *A ;
Long nz, is_complex ;
A = *Ahandle ;
is_complex = (A->xtype != CHOLMOD_REAL) ;
Amatlab = mxCreateSparse (0, 0, 0, is_complex ? mxCOMPLEX: mxREAL) ;
mxSetM (Amatlab, A->nrow) ;
mxSetN (Amatlab, A->ncol) ;
mxSetNzmax (Amatlab, A->nzmax) ;
mxFree (mxGetJc (Amatlab)) ;
mxFree (mxGetIr (Amatlab)) ;
mxFree (mxGetPr (Amatlab)) ;
mxSetJc (Amatlab, (mwIndex *) A->p) ;
mxSetIr (Amatlab, (mwIndex *) A->i) ;
nz = cholmod_l_nnz (A, cc) ;
put_values (nz, Amatlab, (double *) A->x, is_complex, cc) ;
A->p = NULL ;
A->i = NULL ;
A->x = NULL ;
A->z = NULL ;
cholmod_l_free_sparse (Ahandle, cc) ;
return (Amatlab) ;
}
int mfiles_cs2mx(const cs *in, mxArray *out) {
if (!out) {
return EXIT_FAILURE;
}
mxSetM(out, in->m);
mxSetN(out, in->n);
mxSetNzmax(out, in->nzmax);
mxSetJc(out, (mwIndex *) in->p);
mxSetIr(out, (mwIndex *) in->i);
mxSetPr(out, in->x);
return EXIT_SUCCESS;
}
/* return a real sparse matrix to MATLAB */
mxArray *cs_dl_mex_put_sparse (cs_dl **Ahandle)
{
cs_dl *A ;
mxArray *Amatlab ;
A = *Ahandle ;
if (!A) mexErrMsgTxt ("failed") ;
Amatlab = mxCreateSparse (0, 0, 0, mxREAL) ;
mxSetM (Amatlab, A->m) ;
mxSetN (Amatlab, A->n) ;
mxSetNzmax (Amatlab, A->nzmax) ;
cs_free (mxGetJc (Amatlab)) ;
cs_free (mxGetIr (Amatlab)) ;
cs_free (mxGetPr (Amatlab)) ;
mxSetJc (Amatlab, (void *) (A->p)) ; /* assign A->p pointer to MATLAB A */
mxSetIr (Amatlab, (void *) (A->i)) ;
mxSetPr (Amatlab, A->x) ;
cs_free (A) ; /* frees A struct only, not A->p, etc */
*Ahandle = NULL ;
return (Amatlab) ;
}
/* return a sparse matrix to MATLAB */
mxArray *cs_mex_put_sparse (cs **Ahandle)
{
cs *A ;
mxArray *Amatlab ;
A = *Ahandle ;
Amatlab = mxCreateSparse (0, 0, 0, mxREAL) ;
mxSetM (Amatlab, A->m) ;
mxSetN (Amatlab, A->n) ;
mxSetNzmax (Amatlab, A->nzmax) ;
cs_free (mxGetJc (Amatlab)) ;
cs_free (mxGetIr (Amatlab)) ;
cs_free (mxGetPr (Amatlab)) ;
mxSetJc (Amatlab, A->p) ; /* assign A->p pointer to MATLAB A */
mxSetIr (Amatlab, A->i) ;
mxSetPr (Amatlab, A->x) ;
mexMakeMemoryPersistent (A->p) ; /* ensure MATLAB does not free A->p */
mexMakeMemoryPersistent (A->i) ;
mexMakeMemoryPersistent (A->x) ;
cs_free (A) ; /* frees A struct only, not A->p, etc */
*Ahandle = NULL ;
return (Amatlab) ;
}
mxArray *ssmult_transpose // returns C = A' or A.'
(
const mxArray *A,
int conj // compute A' if true, compute A.' if false
)
{
Int *Cp, *Ci, *Ap, *Ai, *W ;
double *Cx, *Cz, *Ax, *Az ; // (TO DO): do single too
mxArray *C ;
Int p, pend, q, i, j, n, m, anz, cnz ;
int C_is_complex ;
//--------------------------------------------------------------------------
// get inputs
//--------------------------------------------------------------------------
m = mxGetM (A) ;
n = mxGetN (A) ;
Ap = mxGetJc (A) ;
Ai = mxGetIr (A) ;
Ax = mxGetPr (A) ;
Az = mxGetPi (A) ;
anz = Ap [n] ;
C_is_complex = mxIsComplex (A) ;
//--------------------------------------------------------------------------
// allocate C but do not initialize it
//--------------------------------------------------------------------------
cnz = MAX (anz, 1) ;
C = mxCreateSparse (0, 0, 0, C_is_complex ? mxCOMPLEX : mxREAL) ;
MXFREE (mxGetJc (C)) ;
MXFREE (mxGetIr (C)) ;
MXFREE (mxGetPr (C)) ;
MXFREE (mxGetPi (C)) ;
Cp = mxMalloc ((m+1) * sizeof (Int)) ;
Ci = mxMalloc (MAX (cnz,1) * sizeof (Int)) ;
Cx = mxMalloc (MAX (cnz,1) * sizeof (double)) ;
Cz = C_is_complex ? mxMalloc (MAX (cnz,1) * sizeof (double)) : NULL ;
mxSetJc (C, Cp) ;
mxSetIr (C, Ci) ;
mxSetPr (C, Cx) ;
mxSetPi (C, Cz) ;
mxSetNzmax (C, cnz) ;
mxSetM (C, n) ;
mxSetN (C, m) ;
//--------------------------------------------------------------------------
// allocate workspace
//--------------------------------------------------------------------------
W = mxCalloc (MAX (m,1), sizeof (Int)) ;
//--------------------------------------------------------------------------
// compute row counts
//--------------------------------------------------------------------------
for (p = 0 ; p < anz ; p++)
{
W [Ai [p]]++ ;
}
//--------------------------------------------------------------------------
// compute column pointers of C and copy back into W
//--------------------------------------------------------------------------
for (p = 0, i = 0 ; i < m ; i++)
{
Cp [i] = p ;
p += W [i] ;
W [i] = Cp [i] ;
}
Cp [m] = p ;
//--------------------------------------------------------------------------
// C = A'
//--------------------------------------------------------------------------
p = 0 ;
if (!C_is_complex)
{
// C = A' (real case)
for (j = 0 ; j < n ; j++)
{
pend = Ap [j+1] ;
for ( ; p < pend ; p++)
{
q = W [Ai [p]]++ ; // find position for C(j,i)
Ci [q] = j ; // place A(i,j) as entry C(j,i)
Cx [q] = Ax [p] ;
}
}
}
else if (conj)
{
// C = A' (complex conjugate)
for (j = 0 ; j < n ; j++)
{
pend = Ap [j+1] ;
for ( ; p < pend ; p++)
{
q = W [Ai [p]]++ ; // find position for C(j,i)
Ci [q] = j ; // place A(i,j) as entry C(j,i)
Cx [q] = Ax [p] ;
Cz [q] = -Az [p] ;
}
}
}
else
{
// C = A.' (complex case)
for (j = 0 ; j < n ; j++)
{
pend = Ap [j+1] ;
for ( ; p < pend ; p++)
{
q = W [Ai [p]]++ ; // find position for C(j,i)
Ci [q] = j ; // place A(i,j) as entry C(j,i)
Cx [q] = Ax [p] ;
Cz [q] = Az [p] ;
}
}
}
//--------------------------------------------------------------------------
// free workspace and return result
//--------------------------------------------------------------------------
MXFREE (W) ;
return (C) ;
}
/* ************************************************************
PROCEDURE mexFunction - Entry for Matlab
************************************************************ */
void mexFunction(int nlhs, mxArray *plhs[],
int nrhs, const mxArray *prhs[])
{
const mxArray *L_FIELD;
mwIndex maxnnz, i,j, nsuper,m,n;
const mwIndex *ljc,*lir,*bjc,*bir;
mwIndex *xjc,*xir, *snode,*xlindx,*lindx, *iwork,*xsuper, *invperm;
bool *cwork;
double *xpr;
const double *permPr, *xsuperPr;
/* ------------------------------------------------------------
Check for proper number of arguments
------------------------------------------------------------ */
mxAssert(nrhs >= NPARIN, "symbfwblk requires more input arguments");
mxAssert(nlhs <= NPAROUT, "symbfwblk produces 1 output argument");
/* ------------------------------------------------------------
Get rhs-input B
------------------------------------------------------------ */
mxAssert(mxIsSparse(B_IN), "B must be sparse");
m = mxGetM(B_IN);
n = mxGetN(B_IN);
bjc = mxGetJc(B_IN);
bir = mxGetIr(B_IN);
/* ------------------------------------------------------------
Disassemble block Cholesky structure L
------------------------------------------------------------ */
mxAssert(mxIsStruct(L_IN), "Parameter `L' should be a structure.");
L_FIELD = mxGetField(L_IN,(mwIndex)0,"perm");
mxAssert( L_FIELD != NULL, "Missing field L.perm."); /* L.perm */
mxAssert(m == mxGetM(L_FIELD) * mxGetN(L_FIELD), "L.perm size mismatches B");
permPr = mxGetPr(L_FIELD);
L_FIELD = mxGetField(L_IN,(mwIndex)0,"L");
mxAssert( L_FIELD!= NULL, "Missing field L.L."); /* L.L */
mxAssert( m == mxGetM(L_FIELD) && m == mxGetN(L_FIELD), "Size L.L mismatch.");
mxAssert(mxIsSparse(L_FIELD), "L.L should be sparse.");
ljc = mxGetJc(L_FIELD);
lir = mxGetIr(L_FIELD);
L_FIELD = mxGetField(L_IN,(mwIndex)0,"xsuper");
mxAssert( L_FIELD!= NULL, "Missing field L.xsuper."); /* L.xsuper */
nsuper = mxGetM(L_FIELD) * mxGetN(L_FIELD) - 1;
mxAssert( nsuper <= m , "Size L.xsuper mismatch.");
xsuperPr = mxGetPr(L_FIELD);
/* ------------------------------------------------------------
Allocate mwIndex-part of sparse output matrix X(m x n)
Heuristically set nnz to nnz(B) + 4*m.
------------------------------------------------------------ */
maxnnz = bjc[n] + 4 * m;
xjc = (mwIndex *) mxCalloc(n + 1, sizeof(mwIndex));
xir = (mwIndex *) mxCalloc(maxnnz, sizeof(mwIndex));
/* ------------------------------------------------------------
Allocate working arrays:
mwIndex invperm(m), snode(m), xsuper(nsuper+1), xlindx(nsuper+1), lindx(nnz(L)),
iwork(nsuper).
char cwork(nsuper).
------------------------------------------------------------ */
invperm = (mwIndex *) mxCalloc(m,sizeof(mwIndex));
snode = (mwIndex *) mxCalloc(m,sizeof(mwIndex));
xsuper = (mwIndex *) mxCalloc(nsuper+1,sizeof(mwIndex));
xlindx = (mwIndex *) mxCalloc(nsuper+1,sizeof(mwIndex));
lindx = (mwIndex *) mxCalloc(ljc[m], sizeof(mwIndex));
iwork = (mwIndex *) mxCalloc(nsuper, sizeof(mwIndex));
cwork = (bool *) mxCalloc(nsuper, sizeof(bool));
/* ------------------------------------------------------------
Convert PERM, XSUPER to integer and C-Style
------------------------------------------------------------ */
for(i = 0; i < m; i++){
j = (mwIndex) permPr[i];
mxAssert(j>0,"");
invperm[--j] = i; /* so that invperm[perm[i]] = i */
}
for(i = 0; i <= nsuper; i++){
j = (mwIndex) xsuperPr[i];
mxAssert(j>0,"");
xsuper[i] = --j;
}
/* ------------------------------------------------------------
Create "snode" from xsuper, and get compact subscript (xlindx,lindx)
from (ljc,lir,xsuper), i.e. nz-pattern per supernode.
------------------------------------------------------------ */
snodeCompress(xlindx,lindx,snode, ljc,lir,xsuper,nsuper);
/* ------------------------------------------------------------
Compute nz structure after forward solve
------------------------------------------------------------ */
symbfwmat(xjc, &xir, &maxnnz, bjc, bir, invperm, snode, xsuper,
xlindx, lindx,
nsuper, m, n, iwork, cwork);
/* ------------------------------------------------------------
Create output matrix x
------------------------------------------------------------ */
X_OUT = mxCreateSparse(m,n, (mwSize)1,mxREAL);
mxFree(mxGetJc(X_OUT)); /* jc */
mxFree(mxGetIr(X_OUT)); /* ir */
mxFree(mxGetPr(X_OUT)); /* pr */
xpr = (double *) mxCalloc(maxnnz,sizeof(double));
mxSetJc(X_OUT, xjc);
mxSetIr(X_OUT, xir);
mxSetPr(X_OUT, xpr);
mxSetNzmax(X_OUT, maxnnz);
for(i = 0; i < maxnnz; i++)
xpr[i] = 1.0;
/* ------------------------------------------------------------
Release working arrays.
------------------------------------------------------------ */
mxFree(cwork);
mxFree(iwork);
mxFree(lindx);
mxFree(xlindx);
mxFree(xsuper);
mxFree(snode);
mxFree(invperm);
}
static void
finv(mxArray *S, const mxArray *L, double *cirS, double *cjcS)
{
double *prL, *prS;
mwIndex *irL, *jcL;
mwIndex *irS, *jcS;
mwIndex *diagL;
mwSize n, nzL, nzS, k, row, col, i, idxS, idxL, ngtcol, rmin;
double *rowL;
/* number of rows and columns in L */
n = mxGetN(L);
/* Get the starting positions of all data arrays in L */
prL = mxGetPr(L);
irL = mxGetIr(L);
jcL = mxGetJc(L);
/* get the number of non-zeros in L and S */
nzL = jcL[n];
nzS = mxGetNzmax(S);
/* initialize the covariance matrix */
mxSetPr(S, mxCalloc(nzS, sizeof(double)));
prS = mxGetPr(S);
irS = mxCalloc(nzS, sizeof(mwIndex));
for (k=0;k<nzS;k++) {
irS[k] = (mwIndex)cirS[k];
}
mxSetIr(S, irS);
jcS = mxCalloc(n+1, sizeof(mwIndex));
for (k=0;k<=n;k++) {
jcS[k] = (mwIndex)(cjcS[k]);
}
mxSetJc(S, jcS);
/* find indices belonging to diagonal elements */
diagL = mxCalloc(n, sizeof(mwIndex));
for (col=0; col<n; col++) {
for (k=jcL[col]; k<jcL[col+1]; k++) {
if (irL[k]==col) {
diagL[col] = k;
break;
}
}
}
/* iterate over all elements using sparse column and row loops */
/* create space for the L and S rows */
rowL = mxCalloc(n, sizeof(double));
/* iterate over columns */
for (col=n-1; col>=0; col--) {
/* iterate over non-zero rows in this column */
for (k=jcL[col+1]-1; k>=jcL[col]; k--) {
/* k is the linear index into the nonzero elements wrt L*/
/* zero-based row */
row = irL[k];
/* find corresponding index of S; try deterministically */
for (idxS=jcS[col]; idxS<jcS[col+1]; idxS++) {
if (irS[idxS]==row) {
break;
}
}
/* fill the rows */
rmin = n;
for (i=jcL[col+1]-1; i>=jcL[col]; i--) {
if (irL[i]<=col)
break; /* jump out */
if (irL[i]<rmin)
rmin = irL[i]; /* minimum row in L */
rowL[irL[i]] = prL[i];
}
if (rmin<n) {
for (i=jcS[row+1]-1; i>=jcS[row]-1; i--) {
if (irS[i]<=col || irS[i]<rmin)
break; /* jump out */
prS[idxS] -= rowL[irS[i]] * prS[i];
}
}
/* set rows to zero */
for (i=jcL[col+1]-1; i>=jcL[col]; i--) {
if (irL[i]<=col)
break; /* jump out */
rowL[irL[i]] = 0.0;
}
/* divide by L(c,c) */
prS[idxS] /= prL[diagL[col]];
if (row==col) {
prS[idxS] += 1.0/(prL[diagL[col]]*prL[diagL[col]]);
}
else if (prS[idxS] != 0) {
/* find corresponding index of S symmetric; try deterministically */
for (i=jcS[row]; i<jcS[row+1]; i++) {
if (irS[i]==col) {
prS[i] = prS[idxS];
break;
}
}
}
}
}
/* clean up the mess */
mxFree(diagL);
mxFree(rowL);
}
void
mexFunction(int nlhs,mxArray *plhs[],int nrhs,const mxArray *prhs[])
{
int number_new_dims, number_input_elements, number_new_elements, i;
int *new_dims;
/* Check for proper number of input and output arguments */
if (nrhs < 3) {
mexErrMsgTxt("At least 3 input arguments required.");
}
if(nlhs > 1){
mexErrMsgTxt("Too many output arguments.");
}
number_new_dims = nrhs-1;
if (mxIsSparse(prhs[0]) && number_new_dims != 2){
mexErrMsgTxt("Multidimensional sparse arrays are not supported.\n");
}
number_input_elements = mxGetNumberOfElements(prhs[0]);
/* Allocate memory for the new_dims array on the fly */
new_dims = mxMalloc(number_new_dims * sizeof(*new_dims));
/* Create the dimensions array and check to make sure total number of
elements for the input array is the same for the reshaped array. */
number_new_elements=1;
for (i=0; i< number_new_dims;i++){
const mxArray *pa;
pa = prhs[i+1];
if(mxGetNumberOfElements(pa) != 1) {
/* Free allocated memory */
mxFree(new_dims);
mexErrMsgTxt("Size arguments must be integer scalars.");
}
new_dims[i] = (int)mxGetScalar(pa);
number_new_elements = new_dims[i]*number_new_elements;
}
if (number_new_elements != number_input_elements){
/* Free allocated memory */
mxFree(new_dims);
mexErrMsgTxt("Total number of elements in the new array, must equal number of elements in input array.\n");
}
/* Duplicate the array */
plhs[0] = mxDuplicateArray(prhs[0]);
/* If array is sparse, use the sparse routine to reshape,
otherwise, use mxSetDimensions. */
if (mxIsSparse(plhs[0])){
int mold; /* old number of rows */
int nold; /* old number of columns */
int *jcold; /*old jc array */
int *ir; /* ir array that is modified in place */
int mnew; /* new number of rows */
int nnew; /* new number of columns */
int *jcnew; /* new jc array */
int j, offset, offset1;
/* Allocate space for new jc. */
jcnew = ((int*)mxCalloc(new_dims[1]+1, sizeof(int)));
mnew = new_dims[0];
nnew = new_dims[1];
/* Get M, N, Ir and Jc of input array. */
mold = mxGetM(plhs[0]);
nold = mxGetN(plhs[0]);
jcold = mxGetJc(plhs[0]);
ir = mxGetIr(plhs[0]);
/* First change ir so it acts like one long column vector */
for (i=1, offset=mold; i < nold; i++, offset+=mold){
for (j=jcold[i]; j < jcold[i+1]; j++){
ir[j] += offset;
}
}
/* Then fix ir and jcnew for new m and n */
for (i=0, j=0, offset=mnew-1, offset1=0; i < jcold[nold]; ) {
if (ir[i] > offset) {
jcnew[++j] = i;
offset += mnew;
offset1 += mnew;
} else {
ir[i++] -= offset1;
}
}
for (j++; j <= nnew; j++){
jcnew[j]=jcold[nold];
}
/* Free the old Jc, set the new Jc, M, and N. */
mxFree(mxGetJc(plhs[0]));
mxSetJc(plhs[0],jcnew);
mxSetM(plhs[0],mnew);
mxSetN(plhs[0],nnew);
}
else{
/* Set the new dimensions. */
mxSetDimensions(plhs[0],new_dims, number_new_dims);
}
/* Free allocated memory*/
mxFree(new_dims);
}
void mexFunction
(
int nargout,
mxArray *pargout[ ],
int nargin,
const mxArray *pargin[ ]
)
{
Long i, n, *Pattern, *Flag, *Li, *Lp, *Ap, *Ai, *Lnz, *Parent,
lnz, do_num_only, *P, *Pinv, nn, k, j, permute, *Dp = NULL, *Di,
d, psrc, pdst ;
double *Y, *D, *Lx, *Ax, *p, *lp ;
/* ---------------------------------------------------------------------- */
/* get inputs and allocate workspace */
/* ---------------------------------------------------------------------- */
do_num_only = ((nargin == 5) || (nargin == 7)) && (nargout <= 2) ;
if (!do_num_only)
{
mexErrMsgTxt ("Usage:\n"
" [L, D] = ldlsparse (A, Lp, Lnz, Parent, Flag) ;\n"
" [L, D] = ldlsparse (A, Lp, Lnz, Parent, Flag, P, PInv)") ;
}
n = mxGetM (pargin [0]) ;
if (!mxIsSparse (pargin [0]) || n != mxGetN (pargin [0])
|| mxIsComplex (pargin [0]))
{
mexErrMsgTxt ("ldl: A must be sparse, square, and real") ;
}
nn = (n == 0) ? 1 : n ;
/* get sparse matrix A */
Ap = (Long *) mxGetJc (pargin [0]) ;
Ai = (Long *) mxGetIr (pargin [0]) ;
Ax = mxGetPr (pargin [0]) ;
/* get Lp */
if (mxGetM (pargin [1]) * mxGetN (pargin [1]) != (n+1) ||
mxIsSparse (pargin [1]))
{
mexErrMsgTxt ("ldl: invalid input Lp\n") ;
}
Lp = (Long *) mxMalloc ((n+1) * sizeof (Long)) ;
lp = mxGetPr (pargin [1]) ;
for (k = 0 ; k < (n+1) ; k++)
{
Lp [k] = lp [k];
}
/* get Lnz */
/* if (mxGetM (pargin [2]) * mxGetN (pargin [2]) != n ||
mxIsSparse (pargin [2]))
{
mexErrMsgTxt ("ldl: invalid input Lnz\n") ;
}*/
Lnz = (Long *) mxMalloc (nn * sizeof (Long)) ;
/*p = mxGetPr (pargin [2]) ;
for (k = 0 ; k < n ; k++)
{
Lnz [k] = p [k];
}*/
/* get Parent */
if (mxGetM (pargin [3]) * mxGetN (pargin [3]) != n ||
mxIsSparse (pargin [3]))
{
mexErrMsgTxt ("ldl: invalid input Parent\n") ;
}
Parent = (Long *) mxMalloc (nn * sizeof (Long)) ;
p = mxGetPr (pargin [3]) ;
for (k = 0 ; k < n ; k++)
{
Parent [k] = p [k];
}
/* get Flag */
/*if (mxGetM (pargin [4]) * mxGetN (pargin [4]) != n ||
mxIsSparse (pargin [4]))
{
mexErrMsgTxt ("ldl: invalid input Flag\n") ;
}*/
Flag = (Long *) mxMalloc (nn * sizeof (Long)) ;
/*p = mxGetPr (pargin [4]) ;
for (k = 0 ; k < n ; k++)
{
Flag [k] = p [k];
}*/
/* get fill-reducing ordering, if present */
permute = ((nargin == 7) && !mxIsEmpty (pargin [5])) ;
if (permute)
{
if (mxGetM (pargin [5]) * mxGetN (pargin [5]) != n ||
mxIsSparse (pargin [5]))
{
mexErrMsgTxt ("ldl: invalid input permutation\n") ;
}
P = (Long *) mxMalloc (nn * sizeof (Long)) ;
p = mxGetPr (pargin [5]) ;
for (k = 0 ; k < n ; k++)
{
P [k] = p [k]; /*p[k]-1 convert to 0-based */
}
if (mxGetM (pargin [6]) * mxGetN (pargin [6]) != n ||
mxIsSparse (pargin [6]))
{
mexErrMsgTxt ("ldl: invalid input permutation inverse\n") ;
}
Pinv = (Long *) mxMalloc (nn * sizeof (Long)) ;
p = mxGetPr (pargin [6]) ;
for (k = 0 ; k < n ; k++)
{
Pinv [k] = p [k]; /*p[k]-1 convert to 0-based */
}
}
else
{
P = (Long *) NULL ;
Pinv = (Long *) NULL ;
}
/* get workspace */
Y = (double *) mxMalloc (nn * sizeof (double)) ;
Pattern = (Long *) mxMalloc (nn * sizeof (Long)) ;
/* make sure the input P is valid */
if (permute && !ldl_l_valid_perm (n, P, Flag))
{
mexErrMsgTxt ("ldl: invalid input permutation\n") ;
}
/* note that we assume that the input matrix is valid */
/* ---------------------------------------------------------------------- */
/* symbolic factorization to get Lp, Parent, Lnz, and optionally Pinv */
/* ---------------------------------------------------------------------- */
/*ldl_l_symbolic (n, Ap, Ai, Lp, Parent, Lnz, Flag, P, Pinv) ;*/
lnz = Lp [n] ;
printf ("lnz: %d\n", lnz) ;
/* ---------------------------------------------------------------------- */
/* create outputs */
/* ---------------------------------------------------------------------- */
/* create the output matrix L, using the Lp array from ldl_l_symbolic */
pargout [0] = mxCreateSparse (n, n, lnz+1, mxREAL) ;
mxFree (mxGetJc (pargout [0])) ;
mxSetJc (pargout [0], (void *) Lp) ; /* Lp is not mxFree'd */
Li = (Long *) mxGetIr (pargout [0]) ;
Lx = mxGetPr (pargout [0]) ;
/* create sparse diagonal matrix D */
if (nargout > 1)
{
pargout [1] = mxCreateSparse (n, n, nn, mxREAL) ;
Dp = (Long *) mxGetJc (pargout [1]) ;
Di = (Long *) mxGetIr (pargout [1]) ;
for (j = 0 ; j < n ; j++)
{
Dp [j] = j ;
Di [j] = j ;
}
Dp [n] = n ;
D = mxGetPr (pargout [1]) ;
}
else
{
D = (double *) mxMalloc (nn * sizeof (double)) ;
}
/* ---------------------------------------------------------------------- */
/* numeric factorization to get Li, Lx, and D */
/* ---------------------------------------------------------------------- */
/*d=n;
printf ("n: %d\n", n) ;
printf ("Y: ") ;
for (k = 0 ; k < n ; k++)
{
Y[k]=k;
printf ("%f", Y[k]) ;
}
printf ("Pattern: ") ;
for (k = 0 ; k < n ; k++)
{
Pattern[k]=k;
printf ("%d", Pattern[k]) ;
}
printf ("Lnz: ") ;
for (k = 0 ; k < n ; k++)
{
Lnz[k]=k;
printf ("%d", Lnz[k]) ;
}*/
d = ldl_l_numeric (n, Ap, Ai, Ax, Lp, Parent, Lnz, Li, Lx, D, Y, Flag,
Pattern, P, Pinv) ;
printf ("d: %d\n", d) ;
/* ---------------------------------------------------------------------- */
/* singular case : truncate the factorization */
/* ---------------------------------------------------------------------- */
if (d != n)
{
/* D [d] is zero: report error, or clean up */
mexErrMsgTxt ("ldl: zero pivot encountered\n") ;
}
/* ---------------------------------------------------------------------- */
/* free workspace */
/* ---------------------------------------------------------------------- */
if (nargout < 2)
{
mxFree (D) ;
}
if (permute)
{
mxFree (P) ;
mxFree (Pinv) ;
}
mxFree (Parent) ;
mxFree (Y) ;
mxFree (Flag) ;
mxFree (Pattern) ;
mxFree (Lnz) ;
}
/* ************************************************************
PROCEDURE mexFunction - Entry for Matlab
************************************************************ */
void mexFunction(const int nlhs, mxArray *plhs[],
const int nrhs, const mxArray *prhs[])
{
const mxArray *L_FIELD;
int maxnnz, i,j, nsuper,m,n;
const int *ljc,*lir,*bjc,*bir;
int *xjc,*xir, *snode,*snodebelow, *iwork,*xsuper;
char *cwork;
double *xpr;
const double *xsuperPr;
/* ------------------------------------------------------------
Check for proper number of arguments
------------------------------------------------------------ */
mxAssert(nrhs >= NPARIN, "symbfwblk requires more input arguments");
mxAssert(nlhs <= NPAROUT, "symbfwblk produces 1 output argument");
/* ------------------------------------------------------------
Get rhs-input B
------------------------------------------------------------ */
mxAssert(mxIsSparse(B_IN), "B must be sparse");
m = mxGetM(B_IN);
n = mxGetN(B_IN);
bjc = mxGetJc(B_IN);
bir = mxGetIr(B_IN);
/* ------------------------------------------------------------
Disassemble block Cholesky structure L
------------------------------------------------------------ */
mxAssert(mxIsStruct(L_IN), "Parameter `L' should be a structure.");
L_FIELD = mxGetField(L_IN,0,"L");
mxAssert( L_FIELD != NULL, "Missing field L.L."); /* L.L */
mxAssert( m == mxGetM(L_FIELD) && m == mxGetN(L_FIELD), "Size L.L mismatch.");
mxAssert(mxIsSparse(L_FIELD), "L.L should be sparse.");
ljc = mxGetJc(L_FIELD);
lir = mxGetIr(L_FIELD);
L_FIELD = mxGetField(L_IN,0,"xsuper");
mxAssert( L_FIELD != NULL, "Missing field L.xsuper."); /* L.xsuper */
nsuper = mxGetM(L_FIELD) * mxGetN(L_FIELD) - 1;
mxAssert( nsuper <= m, "Size L.xsuper mismatch.");
xsuperPr = mxGetPr(L_FIELD);
/* ------------------------------------------------------------
Allocate int-part of sparse output matrix X(m x n)
Heuristically set nnz to nnz(B) + 4*m.
------------------------------------------------------------ */
maxnnz = bjc[n] + 4 * m;
xjc = (int *) mxCalloc(n + 1, sizeof(int));
xir = (int *) mxCalloc(maxnnz, sizeof(int));
/* ------------------------------------------------------------
Allocate working arrays:
int snode(m), xsuper(nsuper+1), snodebelow(nsuper),
iwork(nsuper).
char cwork(nsuper+1).
------------------------------------------------------------ */
snode = (int *) mxCalloc(m,sizeof(int));
xsuper = (int *) mxCalloc(nsuper+1,sizeof(int));
snodebelow = (int *) mxCalloc(nsuper,sizeof(int));
iwork = (int *) mxCalloc(nsuper, sizeof(int));
cwork = (char *) mxCalloc(nsuper+1, sizeof(char));
/* ------------------------------------------------------------
Convert XSUPER to integer and C-Style
------------------------------------------------------------ */
for(i = 0; i <= nsuper; i++){
j = xsuperPr[i];
xsuper[i] = --j;
}
/* ------------------------------------------------------------
Create "snode" from xsuper, and get "first-below-diag"
supernodal subscript snodebelow (snodebelow[j]==nsuper means none).
This is enough to determine the nz-pattern of the backward-solve.
------------------------------------------------------------ */
getSnodeBelow(snodebelow,snode, ljc,lir,xsuper,nsuper);
/* ------------------------------------------------------------
Compute nz structure after backward solve
------------------------------------------------------------ */
symbbwmat(xjc, &xir, &maxnnz, bjc, bir, snode, xsuper,
snodebelow, nsuper, m, n, iwork, cwork);
/* ------------------------------------------------------------
Create output matrix x
------------------------------------------------------------ */
X_OUT = mxCreateSparse(m,n, 1,mxREAL);
mxFree(mxGetJc(X_OUT)); /* jc */
mxFree(mxGetIr(X_OUT)); /* ir */
mxFree(mxGetPr(X_OUT)); /* pr */
xpr = (double *) mxCalloc(maxnnz,sizeof(double));
mxSetJc(X_OUT, xjc);
mxSetIr(X_OUT, xir);
mxSetPr(X_OUT, xpr);
mxSetNzmax(X_OUT, maxnnz);
for(i = 0; i < maxnnz; i++)
xpr[i] = 1.0;
/* ------------------------------------------------------------
Release working arrays.
------------------------------------------------------------ */
mxFree(cwork);
mxFree(iwork);
mxFree(snodebelow);
mxFree(xsuper);
mxFree(snode);
}
void mexFunction
(
int nargout,
mxArray *pargout [ ],
int nargin,
const mxArray *pargin [ ]
)
{
Long *Ap, *Ai, *Zp, *Zi ;
double *Ax, *Az, *Zx ;
Long p, j, build_upper, zero_handling, nrow, ncol, mkind, skind, asize, znz,
status ;
char filename [LEN+1], title [73], key [9], mtype [4] ;
/* ---------------------------------------------------------------------- */
/* check inputs */
/* ---------------------------------------------------------------------- */
if (nargin != 1 || nargout > 5 || !mxIsChar (pargin [0]))
{
mexErrMsgTxt ("Usage: [A Z title key mtype] = RBread (filename)") ;
}
/* ---------------------------------------------------------------------- */
/* get filename */
/* ---------------------------------------------------------------------- */
if (mxGetString (pargin [0], filename, LEN) != 0)
{
mexErrMsgTxt ("filename too long") ;
}
/* ---------------------------------------------------------------------- */
/* read the matrix */
/* ---------------------------------------------------------------------- */
build_upper = TRUE ; /* always build upper tri. part */
zero_handling = (nargout > 1) ? 2 : 1 ; /* prune or extract zeros */
status = RBread (filename, build_upper, zero_handling, title, key, mtype,
&nrow, &ncol, &mkind, &skind, &asize, &znz,
&Ap, &Ai, &Ax, &Az, &Zp, &Zi) ;
if (status != RBIO_OK)
{
RBerror (status) ;
mexErrMsgTxt ("error reading file") ;
}
/* ---------------------------------------------------------------------- */
/* return A to MATLAB */
/* ---------------------------------------------------------------------- */
pargout [0] = mxCreateSparse (0, 0, 0, (mkind == 2) ? mxCOMPLEX : mxREAL) ;
mxFree (mxGetJc (pargout [0])) ;
mxFree (mxGetIr (pargout [0])) ;
mxFree (mxGetPr (pargout [0])) ;
if (mkind == 2) mxFree (mxGetPi (pargout [0])) ;
mxSetM (pargout [0], nrow) ;
mxSetN (pargout [0], ncol) ;
mxSetNzmax (pargout [0], asize) ;
mxSetJc (pargout [0], (mwIndex *) Ap) ;
mxSetIr (pargout [0], (mwIndex *) Ai) ;
mxSetPr (pargout [0], Ax) ;
if (mkind == 2) mxSetPi (pargout [0], Az) ;
/* ---------------------------------------------------------------------- */
/* return Z to MATLAB */
/* ---------------------------------------------------------------------- */
if (nargout > 1)
{
Zx = (double *) SuiteSparse_malloc (znz, sizeof (double)) ;
for (p = 0 ; p < znz ; p++)
{
Zx [p] = 1 ;
}
pargout [1] = mxCreateSparse (0, 0, 0, mxREAL) ;
mxFree (mxGetJc (pargout [1])) ;
mxFree (mxGetIr (pargout [1])) ;
mxFree (mxGetPr (pargout [1])) ;
mxSetM (pargout [1], nrow) ;
mxSetN (pargout [1], ncol) ;
mxSetNzmax (pargout [1], MAX (znz,1)) ;
mxSetJc (pargout [1], (mwIndex *) Zp) ;
mxSetIr (pargout [1], (mwIndex *) Zi) ;
mxSetPr (pargout [1], Zx) ;
}
/* ---------------------------------------------------------------------- */
/* return title */
/* ---------------------------------------------------------------------- */
if (nargout > 2)
{
pargout [2] = mxCreateString (title) ;
}
/* ---------------------------------------------------------------------- */
/* return key */
/* ---------------------------------------------------------------------- */
if (nargout > 3)
{
pargout [3] = mxCreateString (key) ;
}
/* ---------------------------------------------------------------------- */
/* return mtype */
/* ---------------------------------------------------------------------- */
if (nargout > 4)
{
pargout [4] = mxCreateString (mtype) ;
}
}
mxArray *ssmult_dot /* returns C = A'*B */
(
const mxArray *A,
const mxArray *B,
int ac, /* if true: conj(A) if false: A. ignored if A real */
int bc, /* if true: conj(B) if false: B. ignored if B real */
int cc /* if true: conj(C) if false: C. ignored if C real */
)
{
double cx, cz, ax, az, bx, bz ;
mxArray *C ;
double *Ax, *Az, *Bx, *Bz, *Cx, *Cz ;
Int *Ap, *Ai, *Bp, *Bi, *Cp, *Ci ;
Int m, n, k, cnzmax, i, j, p, paend, pbend, ai, bi, cnz, pa, pb, zallzero,
A_is_complex, B_is_complex, C_is_complex ;
/* ---------------------------------------------------------------------- */
/* get inputs */
/* ---------------------------------------------------------------------- */
m = mxGetM (A) ;
n = mxGetN (A) ;
k = mxGetN (B) ;
if (m != mxGetM (B)) ssmult_invalid (ERROR_DIMENSIONS) ;
Ap = mxGetJc (A) ;
Ai = mxGetIr (A) ;
Ax = mxGetPr (A) ;
Az = mxGetPi (A) ;
A_is_complex = mxIsComplex (A) ;
Bp = mxGetJc (B) ;
Bi = mxGetIr (B) ;
Bx = mxGetPr (B) ;
Bz = mxGetPi (B) ;
B_is_complex = mxIsComplex (B) ;
/* ---------------------------------------------------------------------- */
/* allocate C as an n-by-k full matrix but do not initialize it */
/* ---------------------------------------------------------------------- */
/* NOTE: integer overflow cannot occur here, because this function is not
called unless O(n*k) is less than O(m+nnz(A)). The test is done
in the caller, not here.
*/
cnzmax = n*k ;
cnzmax = MAX (cnzmax, 1) ;
Cx = mxMalloc (cnzmax * sizeof (double)) ;
C_is_complex = A_is_complex || B_is_complex ;
Cz = C_is_complex ? mxMalloc (cnzmax * sizeof (double)) : NULL ;
/* ---------------------------------------------------------------------- */
/* C = A'*B using sparse dot products */
/* ---------------------------------------------------------------------- */
/*
NOTE: this method REQUIRES the columns of A and B to be sorted on input.
That is, the row indices in each column must appear in ascending order.
This is the standard in all versions of MATLAB to date, and likely will
be for some time. However, if MATLAB were to use unsorted sparse
matrices in the future (a lazy sort) then a test should be included in
ssmult to not use ssmult_dot if A or B are unsorted, or they should be
sorted on input.
*/
cnz = 0 ;
for (j = 0 ; j < k ; j++)
{
for (i = 0 ; i < n ; i++)
{
/* compute C (i,j) = A (:,i)' * B (:,j) */
pa = Ap [i] ;
paend = Ap [i+1] ;
pb = Bp [j] ;
pbend = Bp [j+1] ;
if (pa == paend /* nnz (A (:,i)) == 0 */
|| pb == pbend /* nnz (B (:,j)) == 0 */
|| Ai [paend-1] < Bi [pb] /* max(find(A(:,i)))<min(find(B(:,j))) */
|| Ai [pa] > Bi [pbend-1]) /* min(find(A(:,i)))>max(find(B(:,j))) */
{
Cx [i+j*n] = 0 ; /* no work to do */
if (C_is_complex)
{
Cz [i+j*n] = 0 ;
}
continue ;
}
cx = 0 ;
cz = 0 ;
while (pa < paend && pb < pbend)
{
/* The dot product looks like the merge in mergesort, except */
/* no "clean-up" phase is need when one list is exhausted. */
ai = Ai [pa] ;
bi = Bi [pb] ;
if (ai == bi)
{
/* c += A (ai,i) * B (ai,j), and "consume" both entries */
if (!C_is_complex)
{
cx += Ax [pa] * Bx [pb] ;
}
else
{
/* complex case */
ax = Ax [pa] ;
bx = Bx [pb] ;
az = Az ? (ac ? (-Az [pa]) : Az [pa]) : 0.0 ;
bz = Bz ? (bc ? (-Bz [pb]) : Bz [pb]) : 0.0 ;
cx += ax * bx - az * bz ;
cz += az * bx + ax * bz ;
}
pa++ ;
pb++ ;
}
else if (ai < bi)
{
/* consume A(ai,i) and discard it, since B(ai,j) is zero */
pa++ ;
}
else
{
/* consume B(bi,j) and discard it, since A(ai,i) is zero */
pb++ ;
}
}
Cx [i+j*n] = cx ;
if (C_is_complex)
{
Cz [i+j*n] = cz ;
}
}
/* count the number of nonzeros in C(:,j) */
for (i = 0 ; i < n ; i++)
{
/* This could be done above, except for the gcc compiler bug when
cx is an 80-bit nonzero in register above, but becomes zero here
when stored into memory. We need the latter, to correctly handle
the case when cx underflows to zero in 64-bit floating-point.
Do not attempt to "optimize" this code by doing this test above,
unless the gcc compiler bug is fixed (as of gcc version 4.1.0).
*/
if (Cx [i+j*n] != 0 || (C_is_complex && Cz [i+j*n] != 0))
{
cnz++ ;
}
}
}
/* ---------------------------------------------------------------------- */
/* convert C to real if the imaginary part is all zero */
/* ---------------------------------------------------------------------- */
if (C_is_complex)
{
zallzero = 1 ;
for (p = 0 ; zallzero && p < cnzmax ; p++)
{
if (Cz [p] != 0)
{
zallzero = 0 ;
}
}
if (zallzero)
{
/* the imaginary part of C is all zero */
C_is_complex = 0 ;
mxFree (Cz) ;
Cz = NULL ;
}
}
/* ---------------------------------------------------------------------- */
/* allocate integer part of C but do not initialize it */
/* ---------------------------------------------------------------------- */
cnz = MAX (cnz, 1) ;
C = mxCreateSparse (0, 0, 0, C_is_complex ? mxCOMPLEX : mxREAL) ;
mxFree (mxGetJc (C)) ;
mxFree (mxGetIr (C)) ;
mxFree (mxGetPr (C)) ;
mxFree (mxGetPi (C)) ;
Cp = mxMalloc ((k + 1) * sizeof (Int)) ;
Ci = mxMalloc (cnz * sizeof (Int)) ;
mxSetJc (C, Cp) ;
mxSetIr (C, Ci) ;
mxSetM (C, n) ;
mxSetN (C, k) ;
/* ---------------------------------------------------------------------- */
/* C = sparse (C). Note that this is done in-place. */
/* ---------------------------------------------------------------------- */
p = 0 ;
for (j = 0 ; j < k ; j++)
{
Cp [j] = p ;
for (i = 0 ; i < n ; i++)
{
cx = Cx [i+j*n] ;
cz = (C_is_complex ? Cz [i+j*n] : 0) ;
if (cx != 0 || cz != 0)
{
Ci [p] = i ;
Cx [p] = cx ;
if (C_is_complex) Cz [p] = (cc ? (-cz) : cz) ;
p++ ;
}
}
}
Cp [k] = p ;
/* ---------------------------------------------------------------------- */
/* reduce the size of Cx and Cz and return result */
/* ---------------------------------------------------------------------- */
if (cnz < cnzmax)
{
Cx = mxRealloc (Cx, cnz * sizeof (double)) ;
if (C_is_complex)
{
Cz = mxRealloc (Cz, cnz * sizeof (double)) ;
}
}
mxSetNzmax (C, cnz) ;
mxSetPr (C, Cx) ;
if (C_is_complex)
{
mxSetPi (C, Cz) ;
}
return (C) ;
}
void mexFunction
(
int nargout,
mxArray *pargout[ ],
int nargin,
const mxArray *pargin[ ]
)
{
UF_long i, n, *Pattern, *Flag, *Li, *Lp, *Ap, *Ai, *Lnz, *Parent, do_chol,
nrhs = 0, lnz, do_solve, *P, *Pinv, nn, k, j, permute, *Dp = NULL, *Di,
d, do_flops, psrc, pdst ;
double *Y, *D, *Lx, *Ax, flops, *X = NULL, *B = NULL, *p ;
/* ---------------------------------------------------------------------- */
/* get inputs and allocate workspace */
/* ---------------------------------------------------------------------- */
do_chol = (nargin > 0) && (nargin <= 2) && (nargout <= 4) ;
do_solve = (nargin == 3) && (nargout <= 2) ;
if (!(do_chol || do_solve))
{
mexErrMsgTxt ("Usage:\n"
" [L, D, etree, flopcount] = ldl (A) ;\n"
" [L, D, etree, flopcount] = ldl (A, P) ;\n"
" [x, flopcount] = ldl (A, [ ], b) ;\n"
" [x, flopcount] = ldl (A, P, b) ;\n"
"The etree and flopcount arguments are optional.") ;
}
n = mxGetM (pargin [0]) ;
if (!mxIsSparse (pargin [0]) || n != mxGetN (pargin [0])
|| mxIsComplex (pargin [0]))
{
mexErrMsgTxt ("ldl: A must be sparse, square, and real") ;
}
if (do_solve)
{
if (mxIsSparse (pargin [2]) || n != mxGetM (pargin [2])
|| !mxIsDouble (pargin [2]) || mxIsComplex (pargin [2]))
{
mexErrMsgTxt (
"ldl: b must be dense, real, and with proper dimension") ;
}
}
nn = (n == 0) ? 1 : n ;
/* get sparse matrix A */
Ap = (UF_long *) mxGetJc (pargin [0]) ;
Ai = (UF_long *) mxGetIr (pargin [0]) ;
Ax = mxGetPr (pargin [0]) ;
/* get fill-reducing ordering, if present */
permute = ((nargin > 1) && !mxIsEmpty (pargin [1])) ;
if (permute)
{
if (mxGetM (pargin [1]) * mxGetN (pargin [1]) != n ||
mxIsSparse (pargin [1]))
{
mexErrMsgTxt ("ldl: invalid input permutation\n") ;
}
P = (UF_long *) mxMalloc (nn * sizeof (UF_long)) ;
Pinv = (UF_long *) mxMalloc (nn * sizeof (UF_long)) ;
p = mxGetPr (pargin [1]) ;
for (k = 0 ; k < n ; k++)
{
P [k] = p [k] - 1 ; /* convert to 0-based */
}
}
else
{
P = (UF_long *) NULL ;
Pinv = (UF_long *) NULL ;
}
/* allocate first part of L */
Lp = (UF_long *) mxMalloc ((n+1) * sizeof (UF_long)) ;
Parent = (UF_long *) mxMalloc (nn * sizeof (UF_long)) ;
/* get workspace */
Y = (double *) mxMalloc (nn * sizeof (double)) ;
Flag = (UF_long *) mxMalloc (nn * sizeof (UF_long)) ;
Pattern = (UF_long *) mxMalloc (nn * sizeof (UF_long)) ;
Lnz = (UF_long *) mxMalloc (nn * sizeof (UF_long)) ;
/* make sure the input P is valid */
if (permute && !ldl_l_valid_perm (n, P, Flag))
{
mexErrMsgTxt ("ldl: invalid input permutation\n") ;
}
/* note that we assume that the input matrix is valid */
/* ---------------------------------------------------------------------- */
/* symbolic factorization to get Lp, Parent, Lnz, and optionally Pinv */
/* ---------------------------------------------------------------------- */
ldl_l_symbolic (n, Ap, Ai, Lp, Parent, Lnz, Flag, P, Pinv) ;
lnz = Lp [n] ;
/* ---------------------------------------------------------------------- */
/* create outputs */
/* ---------------------------------------------------------------------- */
if (do_chol)
{
/* create the output matrix L, using the Lp array from ldl_l_symbolic */
pargout [0] = mxCreateSparse (n, n, lnz+1, mxREAL) ;
mxFree (mxGetJc (pargout [0])) ;
mxSetJc (pargout [0], (void *) Lp) ; /* Lp is not mxFree'd */
Li = (UF_long *) mxGetIr (pargout [0]) ;
Lx = mxGetPr (pargout [0]) ;
/* create sparse diagonal matrix D */
if (nargout > 1)
{
pargout [1] = mxCreateSparse (n, n, nn, mxREAL) ;
Dp = (UF_long *) mxGetJc (pargout [1]) ;
Di = (UF_long *) mxGetIr (pargout [1]) ;
for (j = 0 ; j < n ; j++)
{
Dp [j] = j ;
Di [j] = j ;
}
Dp [n] = n ;
D = mxGetPr (pargout [1]) ;
}
else
{
D = (double *) mxMalloc (nn * sizeof (double)) ;
}
/* return elimination tree (add 1 to change from 0-based to 1-based) */
if (nargout > 2)
{
pargout [2] = mxCreateDoubleMatrix (1, n, mxREAL) ;
p = mxGetPr (pargout [2]) ;
for (i = 0 ; i < n ; i++)
{
p [i] = Parent [i] + 1 ;
}
}
do_flops = (nargout == 4) ? (3) : (-1) ;
}
else
{
/* create L and D as temporary matrices */
Li = (UF_long *) mxMalloc ((lnz+1) * sizeof (UF_long)) ;
Lx = (double *) mxMalloc ((lnz+1) * sizeof (double)) ;
D = (double *) mxMalloc (nn * sizeof (double)) ;
/* create solution x */
nrhs = mxGetN (pargin [2]) ;
pargout [0] = mxCreateDoubleMatrix (n, nrhs, mxREAL) ;
X = mxGetPr (pargout [0]) ;
B = mxGetPr (pargin [2]) ;
do_flops = (nargout == 2) ? (1) : (-1) ;
}
if (do_flops >= 0)
{
/* find flop count for ldl_l_numeric */
flops = 0 ;
for (k = 0 ; k < n ; k++)
{
flops += ((double) Lnz [k]) * (Lnz [k] + 2) ;
}
if (do_solve)
{
/* add flop count for solve */
for (k = 0 ; k < n ; k++)
{
flops += 4 * ((double) Lnz [k]) + 1 ;
}
}
pargout [do_flops] = mxCreateDoubleMatrix (1, 1, mxREAL) ;
p = mxGetPr (pargout [do_flops]) ;
p [0] = flops ;
}
/* ---------------------------------------------------------------------- */
/* numeric factorization to get Li, Lx, and D */
/* ---------------------------------------------------------------------- */
d = ldl_l_numeric (n, Ap, Ai, Ax, Lp, Parent, Lnz, Li, Lx, D, Y, Flag,
Pattern, P, Pinv) ;
/* ---------------------------------------------------------------------- */
/* singular case : truncate the factorization */
/* ---------------------------------------------------------------------- */
if (d != n)
{
/* D [d] is zero: report error, or clean up */
if (do_chol && do_flops < 0)
{
mexErrMsgTxt ("ldl: zero pivot encountered\n") ;
}
else
{
/* L and D are incomplete, compact them */
if (do_chol)
{
for (k = d ; k < n ; k++)
{
Dp [k] = d ;
}
Dp [n] = d ;
}
for (k = d ; k < n ; k++)
{
D [k] = 0 ;
}
pdst = 0 ;
for (k = 0 ; k < d ; k++)
{
for (psrc = Lp [k] ; psrc < Lp [k] + Lnz [k] ; psrc++)
{
Li [pdst] = Li [psrc] ;
Lx [pdst] = Lx [psrc] ;
pdst++ ;
}
}
for (k = 0 ; k < d ; k++)
{
Lp [k+1] = Lp [k] + Lnz [k] ;
}
for (k = d ; k <= n ; k++)
{
Lp [k] = pdst ;
}
if (do_flops >= 0)
{
/* return -d instead of the flop count (convert to 1-based) */
p = mxGetPr (pargout [do_flops]) ;
p [0] = -(1+d) ;
}
}
}
/* ---------------------------------------------------------------------- */
/* solve Ax=b, if requested */
/* ---------------------------------------------------------------------- */
if (do_solve)
{
if (permute)
{
for (j = 0 ; j < nrhs ; j++)
{
ldl_l_perm (n, Y, B, P) ; /* y = Pb */
ldl_l_lsolve (n, Y, Lp, Li, Lx) ; /* y = L\y */
ldl_l_dsolve (n, Y, D) ; /* y = D\y */
ldl_l_ltsolve (n, Y, Lp, Li, Lx) ; /* y = L'\y */
ldl_l_permt (n, X, Y, P) ; /* x = P'y */
X += n ;
B += n ;
}
}
else
{
for (j = 0 ; j < nrhs ; j++)
{
for (k = 0 ; k < n ; k++) /* x = b */
{
X [k] = B [k] ;
}
ldl_l_lsolve (n, X, Lp, Li, Lx) ; /* x = L\x */
ldl_l_dsolve (n, X, D) ; /* x = D\x */
ldl_l_ltsolve (n, X, Lp, Li, Lx) ; /* x = L'\x */
X += n ;
B += n ;
}
}
/* free the matrix L */
mxFree (Lp) ;
mxFree (Li) ;
mxFree (Lx) ;
mxFree (D) ;
}
/* ---------------------------------------------------------------------- */
/* free workspace */
/* ---------------------------------------------------------------------- */
if (do_chol && nargout < 2)
{
mxFree (D) ;
}
if (permute)
{
mxFree (P) ;
mxFree (Pinv) ;
}
mxFree (Parent) ;
mxFree (Y) ;
mxFree (Flag) ;
mxFree (Pattern) ;
mxFree (Lnz) ;
}
/* ************************************************************
PROCEDURE mexFunction - Entry for Matlab
************************************************************ */
void mexFunction(int nlhs, mxArray *plhs[],
int nrhs, const mxArray *prhs[])
{
mxArray *LDEN_FIELD;
mwIndex i,inz, j,m,n,nperm, firstQ, lastQ, nnzdz;
const mwIndex *LADjc, *LADir, *dzJc, *dzIr;
mwIndex *invdz,*firstpiv,*perm, *dznewJc;
double *permPr, *firstPr;
const char *LdenFieldnames[] = {"LAD","perm","dz","first"};
/* ------------------------------------------------------------
Check for proper number of arguments
------------------------------------------------------------ */
mxAssert(nrhs >= NPARIN, "finsymbden requires more input arguments");
mxAssert(nlhs <= NPAROUT, "finsymbden produces less output arguments");
/* ------------------------------------------------------------
Get inputs LAD,perm,dz,firstq
n = total number of dense columns/blocks, i.e. #cols in LAD
m = number of constraints
nperm = n - number of removed lorentz trace columns.
------------------------------------------------------------ */
mxAssert(mxIsSparse(LAD_IN), "LAD must be sparse"); /* LAD */
m = mxGetM(LAD_IN);
n = mxGetN(LAD_IN);
LADjc = mxGetJc(LAD_IN);
LADir = mxGetIr(LAD_IN);
permPr = mxGetPr(PERM_IN); /* perm */
nperm = mxGetM(PERM_IN) * mxGetN(PERM_IN);
dzJc = mxGetJc(DZ_IN); /* dz */
dzIr = mxGetIr(DZ_IN);
mxAssert(mxGetM(DZ_IN) == m && mxGetN(DZ_IN) == nperm, "dz size mismatch");
/* ------------------------------------------------------------
INPUT firstQ == dense.l+1, points to 1st entry in dense.cols
dealing with Lorentz-trace entries. Let lastQ point just beyond
Lorentz trace/block entries, i.e. add n-nperm.
------------------------------------------------------------ */
firstQ = (mwIndex) mxGetScalar(FIRSTQ_IN); /*firstq, F-double to C-mwIndex.*/
mxAssert(firstQ>0,"");
--firstQ;
lastQ = firstQ + n - nperm;
/* ------------------------------------------------------------
Allocate integer working arrays:
invdz(m), firstpiv(n), perm(n)
------------------------------------------------------------ */
invdz = (mwIndex *) mxCalloc(MAX(1,m), sizeof(mwIndex));
firstpiv = (mwIndex *) mxCalloc(MAX(1,n), sizeof(mwIndex));
perm = (mwIndex *) mxCalloc(MAX(1,n), sizeof(mwIndex));
/* ------------------------------------------------------------
Allocate OUTPUT mwIndex array dznewJc(n+1)
------------------------------------------------------------ */
dznewJc = (mwIndex *) mxCalloc(n+1, sizeof(mwIndex));
/* ------------------------------------------------------------
Let invdz(dzIr) = 1:nnz(dz). Note that nnz(dz)<m is the number
subscripts that are actually in use.
------------------------------------------------------------ */
nnzdz = dzJc[nperm];
for(i = dzJc[0]; i < nnzdz; i++)
invdz[dzIr[i]] = i; /* dz is m x nperm */
/* ------------------------------------------------------------
Create new perm and dz-column pointers, to include lorentz trace cols.
These cols are attached to Lorentz-blocks cols, whose subscripts
range in firstQ:lastQ-1.
------------------------------------------------------------ */
inz = 0;
for(i = 0; i < nperm; i++){
j = (mwIndex) permPr[i];
perm[inz] = --j;
dznewJc[inz++] = dzJc[i];
if(j >= firstQ && j < lastQ){
/* ------------------------------------------------------------
Attach Lorentz trace col. These cols are at nperm:n-1.
------------------------------------------------------------ */
perm[inz] = nperm + j - firstQ; /* insert associated trace column */
mxAssert(perm[inz] < n,"");
dznewJc[inz++] = dzJc[i+1]; /* no extra subscripts->start at end */
}
}
mxAssert(inz == n,"");
dznewJc[n] = dzJc[nperm];
/* ------------------------------------------------------------
Compute firstpiv
------------------------------------------------------------ */
getfirstpiv(firstpiv, invdz, dznewJc, LADjc,LADir, n);
/* ------------------------------------------------------------
Outputs Lden.(LAD, perm, dz, first)
------------------------------------------------------------ */
LDEN_OUT = mxCreateStructMatrix((mwSize)1,(mwSize)1, NLDEN_FIELDS, LdenFieldnames);
LDEN_FIELD = mxDuplicateArray(LAD_IN); /* LAD */
mxSetField(LDEN_OUT,(mwIndex)0,"LAD",LDEN_FIELD);
LDEN_FIELD = mxCreateDoubleMatrix(n, (mwSize)1, mxREAL); /* perm */
mxSetField(LDEN_OUT,(mwIndex)0,"perm",LDEN_FIELD);
permPr = mxGetPr(LDEN_FIELD);
for(i = 0; i < n; i++)
permPr[i] = perm[i] + 1.0; /* C-mwIndex to F-double */
LDEN_FIELD = mxDuplicateArray(DZ_IN); /* dz */
/* NOTE: here we replace jc by dznewJc */
mxFree(mxGetJc(LDEN_FIELD));
mxSetJc(LDEN_FIELD, dznewJc);
mxSetN(LDEN_FIELD, n);
mxSetField(LDEN_OUT,(mwIndex)0,"dz",LDEN_FIELD);
LDEN_FIELD = mxCreateDoubleMatrix(n, (mwSize)1, mxREAL); /* first */
mxSetField(LDEN_OUT,(mwIndex)0,"first",LDEN_FIELD);
firstPr = mxGetPr(LDEN_FIELD);
for(i = 0; i < n; i++)
firstPr[i] = firstpiv[i] + 1.0; /* C-mwIndex to F-double */
/* ------------------------------------------------------------
Release working arrays
------------------------------------------------------------ */
mxFree(perm);
mxFree(firstpiv);
mxFree(invdz);
}
