/* ************************************************************
PROCEDURE selfwsolve -- Solve ynew from L*y = yold, where
L is lower-triangular and y is SPARSE.
INPUT
L - sparse lower triangular matrix
xsuper - length nsuper+1, start of each (dense) supernode.
nsuper - number of super nodes
snode - length m array, mapping each node to the supernode containing it.
yir - length ynnz array, listing all possible nonzeros entries in y.
ynnz - number of nonzeros in y (from symbfwslv).
UPDATED
y - full vector, on input y = rhs, on output y = L\rhs.
only the yir(0:ynnz-1) entries are used and defined.
************************************************************ */
void selfwsolve(double *y, const int *Ljc, const int *Lir, const double *Lpr,
const int *xsuper, const int nsuper,
const int *snode, const int *yir, const int ynnz)
{
int jsup,j,inz,jnz;
double yj;
if(ynnz <= 0)
return;
/* ------------------------------------------------------------
Forward solve on each nonzero supernode snode[yir[jnz]] (=jsup-1).
------------------------------------------------------------ */
jnz = 0;
while(jnz < ynnz){
j = yir[jnz];
jsup = snode[j] + 1;
jnz += xsuper[jsup] - j; /* point to next nonzero supernode */
while(j < xsuper[jsup]){
/* ------------------------------------------------------------
Do dense computations on supernode.
The first equation, 1*y=b(j), yields y(j) = b(j).
------------------------------------------------------------ */
inz = Ljc[j];
yj = y[j++];
++inz; /* jump over diagonal entry */
/* ------------------------------------------------------------
Forward solution: y(j+1:m) -= yj * L(j+1:m,j)
------------------------------------------------------------ */
subscalarmul(y+j, yj, Lpr+inz, xsuper[jsup] - j);
for(inz += xsuper[jsup] - j; inz < Ljc[j]; inz++)
y[Lir[inz]] -= yj * Lpr[inz];
}
}
}
/* ************************************************************
PROCEDURE fwsolve -- Solve ynew from L*y = yold, where
L is lower-triangular.
INPUT
L - sparse lower triangular matrix
xsuper - starting column in L for each (dense) supernode.
nsuper - number of super nodes
UPDATED
y - full vector, on input y = rhs, on output y = L\rhs.
WORK
fwork - length max(collen[i] - superlen[i]) <= m-1, where
collen[i] := L.jc[xsuper[i]+1]-L.jc[xsuper[i]] and
superlen[i] := xsuper[i+1]-xsuper[i].
************************************************************ */
void fwsolve(double *y, const int *Ljc, const int *Lir, const double *Lpr,
const int *xsuper, const int nsuper, double *fwork)
{
int jsup,i,j,inz,jnnz;
double yi,yj;
/* ------------------------------------------------------------
For each supernode jsup:
------------------------------------------------------------ */
j = xsuper[0]; /* 1st col of current snode (j=0)*/
inz = Ljc[0]; /* 1st nonzero in L (inz = 0) */
for(jsup = 1; jsup <= nsuper; jsup++){
/* ------------------------------------------------------------
The first equation, 1*y=b(j), yields y(j) = b(j).
------------------------------------------------------------ */
mxAssert(inz == Ljc[j],"");
yj = y[j++];
++inz; /* jump over diagonal entry */
if(j >= xsuper[jsup])
/* ------------------------------------------------------------
If supernode is singleton, then simply set y(j+1:m)-=yj*L(j+1:m,j)
------------------------------------------------------------ */
for(; inz < Ljc[j]; inz++)
y[Lir[inz]] -= yj * Lpr[inz];
else{
/* ------------------------------------------------------------
Supernode contains multiple subnodes:
Remember (i,yi) = 1st subnode, then
perform dense forward solve within current supernode.
------------------------------------------------------------ */
i = j;
yi = yj;
do{
subscalarmul(y+j, yj, Lpr+inz, xsuper[jsup] - j);
inz = Ljc[j];
yj = y[j++];
++inz; /* jump over diagonal entry */
} while(j < xsuper[jsup]);
jnnz = Ljc[j] - inz;
/* ------------------------------------------------------------
jnnz = number of later entries that are influenced by this supernode.
Compute the update in the array fwork(jnnz)
------------------------------------------------------------ */
if(jnnz > 0){
scalarmul(fwork, yj, Lpr+inz,jnnz);
while(i < j){
addscalarmul(fwork,yi,Lpr+Ljc[i]-jnnz,jnnz);
yi = y[i++];
}
/* ------------------------------------------------------------
Update y with fwork at the specified sparse locations
------------------------------------------------------------ */
for(i = 0; i < jnnz; i++)
y[Lir[inz++]] -= fwork[i];
}
}
}
}
/* ************************************************************
suboutprod -- Computes update from a single previous column "xk" on
a supernode "xj", using dense computations.
INPUT
mj, nj - supernode "xj" is mj x nj. More precisely, the column
lengths are {mj, mj-1, ..., mj-(nj-1)}.
xkk - scalar, the 1st nj entries in xk are divided by this number.
mk - length of xk. WE ASSUME mk <= mj. Only 1st mk rows in xj
are updated.
UPDATED
xj - On return, xj -= xk*xk(0:nj-1)'/xkk
xk - On return, xk(0:nj-1) /= xkk
************************************************************ */
void suboutprod(double *xj, mwIndex mj, const mwIndex nj, double *xk,
const double xkk, mwIndex mk)
{
mwIndex j;
double xjk;
for(j = 0; j < nj; j++){
xjk = xk[0] / xkk;
subscalarmul(xj, xjk, xk, mk); /* xj -= xjk * xk */
xk[0] = xjk; /* FINAL entry ljk */
xj += mj; /* point to next column which is 1 shorter */
--mj; --mk; ++xk;
}
}
/*************************************************************
PROCEDURE ubsolve -- Solves xnew from U * xnew = x,
UPDATED
x - length n vector
On input, contains the right-hand-side.
On output, xnew = U\x
**************************************************************/
void bwsolve(double *x,const double *u,const int n)
{
int j;
/*---------------------------------------------
xnew[j] = x[j] / u[j,j]
Then, we update the right-hand side:
xnew(0:j-1) = x(0:j-1) - xnew[j] * u(0:j-1)
---------------------------------------------*/
j = n;
u += SQR(n);
while(j > 0){
--j;
u -= n;
x[j] /= u[j];
subscalarmul(x,x[j],u,j);
}
}
/*************************************************************
PROCEDURE ubsolve -- Solves xnew from U * xnew = x,
where U is upper-triangular.
INPUT
u,n - n x n full matrix with only upper-triangular entries
UPDATED
x - length n vector
On input, contains the right-hand-side.
On output, xnew = U\xold
**************************************************************/
void ubsolve(double *x,const double *u,const int n)
{
int j;
/*------------------------------------------------------------
At each step j= n-1,...0, we have a (j+1) x (j+1) upper triangular
system "U*xnew = x". The last equation gives:
xnew[j] = x[j] / u[j,j]
Then, we update the right-hand side:
xnew(0:j-1) = x(0:j-1) - xnew[j] * u(0:j-1)
--------------------------------------------------------------*/
j = n;
u += SQR(n);
while(j > 0){
--j;
u -= n;
x[j] /= u[j];
subscalarmul(x,x[j],u,j);
}
}
/* ************************************************************
PROCEDURE cholonBlk - CHOLESKY on a dense diagonal block.
Also updates nonzeros below this diagonal block -
they need merely be divided by the scalar diagonals
"lkk" afterwards.
INPUT
m - number of rows (length of the first column).
ncols - number of columns in the supernode.(n <= m)
lb - Length ncols. Skip k-th pivot if drops below lb[k].
ub - max(diag(x)) / maxu^2. No stability check for pivots > ub.
maxu - Max. acceptable |lik|/lkk when lkk suffers cancelation.
first - global column number of column 0. This is used only to insert
the global column numbers into skipIr.
UPDATED
x - On input, contains the columns of the supernode to
be factored. On output, contains the factored columns of
the supernode.
skipIr - Lists skipped pivots with their global column number
in 0:neqns-1. Active range is first:first+ncols-1.
Skipped if d(k) suffers cancelation and max(abs(L(:,k)) > maxu.
*pnskip - nnz in skip; *pnskip <= order N of sparse matrix.
OUTPUT
d - Length ncols. Diagonal in L*diag(d)*L' with diag(L)=all-1.
************************************************************ */
void cholonBlk(double *x, double *d, mwIndex m, const mwIndex ncols, const mwIndex first,
const double ub, const double maxu, double *lb,
mwIndex *skipIr, mwIndex *pnskip)
{
mwIndex inz,i,k,n,coltail, nskip;
double xkk, xik, ubk;
double *xi;
/* ------------------------------------------------------------
Initialize:
------------------------------------------------------------ */
n = ncols;
nskip = *pnskip;
inz = 0;
coltail = m - ncols;
for(k = 0; k < ncols; k++, --m, --n){
/* -------------------------------------------------------
Let xkk = L(k,k), ubk = max(|xik|) / maxu.
------------------------------------------------------- */
xkk = x[inz];
if(xkk > lb[k]){ /* now xkk > 0 */
if(xkk < ub){
ubk = maxabs(x+inz+1,m-1) / maxu;
if(xkk < ubk){
/* ------------------------------------------------------------
If we need to add on diagonal, store this in (skipIr, lb(k)).
------------------------------------------------------------ */
skipIr[nskip++] = first + k;
lb[k] = ubk - xkk; /* amount added on diagonal */
xkk = ubk;
}
}
/* --------------------------------------------------------------
Set dk = xkk, lkk = 1 (for LDL').
-------------------------------------------------------------- */
d[k] = xkk; /* now d[k] > 0 MEANS NO-SKIPPING */
x[inz] = 1.0;
xi = x + inz + m; /* point to next column */
++inz;
/* --------------------------------------------------------------
REGULAR JOB: correct remaining n-k cols with col k.
x(k+1:m,k+1:n) -= x(k+1:m,k) * x(k+1:n,k)' / xkk
x(k+1:n,k) /= xkk,
-------------------------------------------------------------- */
for(i = 1; i < n; i++){
xik = x[inz] / xkk;
subscalarmul(xi, xik, x+inz, m-i);
x[inz++] = xik;
xi += m-i;
}
inz += coltail; /* Let inz point to next column */
}
/* ------------------------------------------------------------
If skipping is enabled and this pivot is too small:
1) don't touch L(k:end,k): allows pivot delaying if desired.
2) List first+k in skipIr. Set dk = 0 (MEANS SKIPPING).
-------------------------------------------------------------- */
else{
skipIr[nskip++] = first + k;
d[k] = 0.0; /* tag "0": means column skipped in LDL'.*/
inz += m; /* Don't touch nor use L(k:end,k) */
}
} /* k=0:ncols-1 */
/* ------------------------------------------------------------
Return updated number of added or skipped pivots.
------------------------------------------------------------ */
*pnskip = nskip;
}
