Exemple #1
0
/* ************************************************************
   PROCEDURE sptotril - For sparse x=vec(X), lets
     z = vec( tril(X) + triu(X,1)' ). If skew = 1 then
     z = vec( tril(X) - triu(X)' ).
   INPUT
     xir, xpr, pxjc0, xjc1 - sparse input vector, *pxjc0 points to
       first nonzero of vectorized matrix X.
     first - subscript of X(1,1) in long vector x.
     n - order of n x n matrix X.
     skew - if 1, then set SUBTRACT triu(X,1)' and set diag(z)=all-0.
     iwsize - n + xnnz + 1+nnz(triu(X,1)) + log_2(1+nnz(triu(X,1))).
        Observe that nnz(triu(X,1)) <= MIN(n*(n-1)/2, xnnz), and
        xnnz <= MIN(n^2, xjc1-*pxjc0). Thus
        iwsize <= n*(2*n+1)+log_2(1+n*(n-1)/2).
   OUTPUT
     zir - length znnz int array, subscripts of z := vec(tril(x)+triu(x,1)').
     zpr - length znnz vector, nonzeros of z.
   WORK
     cwork - length nnz(triu(X,1)) <= n*(n-1)/2 char array.
     iwork - length iwsize integer working array
     ypr - length xnnz vector; xnnz <= n^2.
   RETURNS znnz
   ************************************************************ */
int sptotril(int *zir, double *zpr, const int *xir, const double *xpr,
             int *pxjc0, const int xjc1, const int first, const int n,
             const bool skew, int iwsize, char *cwork, int *iwork,
             double *ypr)
{
  int xjc0, xnnz, trilnnz, triujc0;
  int *triujc, *yir;
/* ------------------------------------------------------------
   Let iwork[0:n-2] point to row-starts for storing triu(X,1)
   row-wise. Let xnnz be nnz(X). Update *pxjc0 to point beyond this
   block
   ------------------------------------------------------------ */
  xjc0 = *pxjc0;
  xnnz = sptriujcT(iwork, xir, xjc0, xjc1, first, n);
  *pxjc0 = xjc0 + xnnz;
/* ------------------------------------------------------------
   Partition integer working array
   ------------------------------------------------------------ */
  triujc = iwork;
  yir = iwork + (n-1);
  iwork = yir + xnnz;
  iwsize -= n-1 + xnnz;
/* ------------------------------------------------------------
   ------------------------------------------------------------ */
  if(n > 1)
    triujc0 = triujc[0];
  else
    triujc0 = xnnz;            /* 1 x 1 matrix --> triu(X)=[] */
  trilnnz = sptrilandtriu(yir, ypr, triujc, xir,xpr,xjc0,xjc1, first,n, skew);
  if(!skew)
    return spadd(zir,zpr, yir,ypr, trilnnz, yir+triujc0,ypr+triujc0,
                 xnnz-triujc0, iwsize, cwork, iwork);
  else
    return spsub(zir,zpr, yir,ypr, trilnnz, yir+triujc0,ypr+triujc0,
                 xnnz-triujc0, iwsize, cwork, iwork);
}
/* ************************************************************      
   PROCEDURE precorrect  -  Apply corrections from affecting supernode
      (skipping subnodes with non-positive diagonal) on supernodal
      diagonal block in L-factor.
   INPUT
     ljc   - start of columns in lpr.
     d     - Length neqns vector. The diagonal in L*diag(d)*L'. Only
       d[firstk:nextk-1] will be used.
     irInv - For row-indices Jir of affected supernode, Jir[m-irInv[i]]  == i.
     nextj - Last subnode of affected supernode is nextj-1.
     firstk, nextk - subnodes of affecting supernode are firstk:nextk-1.
     Kir   - unfinished row indices of affecting supernode
     mk    - number of unfinished nonzeros in affecting supernode
     fwsiz - Allocated length of fwork.
   UPDATED
     lpr  - For each column k=firstk:nextk-1, and the affected columns j
       in node, DO  L(:,j) -= (ljk / lkk) * L(:,k),
       and store the definitive j-th row of L, viz. ljk /= lkk.
   WORKING ARRAYS
     relind - length mk integer array
     fwork  - length fwsiz vector, for storing -Xk * inv(LABK) * Xk'.
   RETURNS  ncolup, number of columns updated by snode k.
    if -1, then fwsiz is too small.
   ************************************************************ */
mwIndex precorrect(double *lpr, const mwIndex *ljc,const double *d, const mwIndex *irInv,
               const mwIndex nextj, const mwIndex *Kir, const mwIndex mk,
               const mwIndex firstk, const mwIndex nextk,
               mwIndex *relind, const mwIndex fwsiz, double *fwork)
{
  mwIndex i,j,k,ncolup,mj;
  double *xj;
/* ------------------------------------------------------------
   j = first subscript in k (== 1st affected column)
   i = last subscript in k
   ncolup = number of nz-rows in k corresponding to columns in node.
   mj = number of nonzeros in l(:,j), the 1st affected column
   ------------------------------------------------------------ */
  j = Kir[0];
  i = Kir[mk-1];
  if(i < nextj)
    ncolup = mk;
  else
    for(ncolup = 1; Kir[ncolup] < nextj; ncolup++);
  mj = ljc[j+1] - ljc[j];
/* ------------------------------------------------------------
   If nz-structure of k is a single block in structure of node,
   (i.e. irInv[Kir[0]] - irInv[Kir[mk-1]] == mk-1). The subnodes
   of "node" must then be consecutive and at the start.
   Thus, we use dense computations :
   ------------------------------------------------------------ */
  if(irInv[j] - irInv[i] < mk){
    xj = lpr + ljc[j];
    for(k = firstk; k < nextk; k++)
      if(d[k] > 0.0)                        /* Skip pivot when d[k] <= 0 */
        suboutprod(xj, mj, ncolup, lpr + ljc[k+1] - mk, d[k], mk);
  }
  else{
/* ------------------------------------------------------------
   Otherwise, the nz-indices of k are scattered within the structure of node.
   Let relind be the position of these nz's in node, COUNTED FROM THE BOTTOM.
   ------------------------------------------------------------*/
    for(i = 0; i < mk; i++)
      relind[i] = irInv[Kir[i]];
/* ------------------------------------------------------------
   If k is a single column, then perform update directly in lpr:
   ------------------------------------------------------------ */
    if(nextk - firstk == 1){
      if(d[firstk] > 0.0)                   /* Skip pivot when d[k] <= 0 */
        spsuboutprod(ljc+j,lpr,mj, ncolup, lpr + ljc[nextk]-mk,
                     d[firstk],mk, relind);
    }
    else{
/* ------------------------------------------------------------
   Multiple columns in affecting snode:
   1. compute the complete modification, and store it in fwork:
   fwork = -Xk * inv(LABK) * Xk'
   ------------------------------------------------------------ */
      if(fwsiz + ncolup*(ncolup-1)/2 < mk * ncolup )
        return (mwIndex)-1;
      for(k = firstk; k < nextk; k++)      /* find 1st positive diag */
        if(d[k] > 0.0)
          break;
      if(k < nextk){                       /* if any positive diag: */
        isminoutprod(fwork, ncolup, lpr + ljc[k+1] - mk, d[k], mk);
        for(++k; k < nextk; k++)           /* remaining cols */
          if(d[k] > 0.0)                   /* Skip pivot when d[k] <= 0 */
            suboutprod(fwork, mk, ncolup, lpr + ljc[k+1] - mk, d[k], mk);
/* ------------------------------------------------------------
   2. subtract fwork from the sparse columns of node, using relind.
   ------------------------------------------------------------ */
        spadd(ljc+j,lpr,mj, ncolup, fwork,mk, relind);
      } /* end exists positive diag */
    } /* end multiple affecting cols */
  } /* end of scattered case */
/* ------------------------------------------------------------
   RETURN number of columns updated, i.e. #subnodes in k that we finished.
   ------------------------------------------------------------ */
  return ncolup;
}