コード例 #1
0
ファイル: klu_diagnostics.c プロジェクト: MaveriQ/AMICI
Int KLU_condest         /* return TRUE if successful, FALSE otherwise */
(
    Int Ap [ ],
    double Ax [ ],
    KLU_symbolic *Symbolic,
    KLU_numeric *Numeric,
    KLU_common *Common
)
{
    double xj, Xmax, csum, anorm, ainv_norm, est_old, est_new, abs_value ;
    Entry *Udiag, *Aentry, *X, *S ;
    Int i, j, jmax, jnew, pend, n ;
#ifndef COMPLEX
    Int unchanged ;
#endif

    /* ---------------------------------------------------------------------- */
    /* check inputs */
    /* ---------------------------------------------------------------------- */

    if (Common == NULL)
    {
        return (FALSE) ;
    }
    if (Symbolic == NULL || Ap == NULL || Ax == NULL)
    {
        Common->status = KLU_INVALID ;
        return (FALSE) ;
    }
    abs_value = 0 ;
    if (Numeric == NULL)
    {
        /* treat this as a singular matrix */
        Common->condest = 1 / abs_value ;
        Common->status = KLU_SINGULAR ;
        return (TRUE) ;
    }
    Common->status = KLU_OK ;

    /* ---------------------------------------------------------------------- */
    /* get inputs */
    /* ---------------------------------------------------------------------- */

    n = Symbolic->n ;
    Udiag = Numeric->Udiag ;

    /* ---------------------------------------------------------------------- */
    /* check if diagonal of U has a zero on it */
    /* ---------------------------------------------------------------------- */

    for (i = 0 ; i < n ; i++)
    {
        ABS (abs_value, Udiag [i]) ;
        if (SCALAR_IS_ZERO (abs_value))
        {
            Common->condest = 1 / abs_value ;
            Common->status = KLU_SINGULAR ;
            return (TRUE) ;
        }
    }

    /* ---------------------------------------------------------------------- */
    /* compute 1-norm (maximum column sum) of the matrix */
    /* ---------------------------------------------------------------------- */

    anorm =  0.0 ;
    Aentry = (Entry *) Ax ;
    for (i = 0 ; i < n ; i++)
    {
        pend = Ap [i + 1] ;
        csum = 0.0 ;
        for (j = Ap [i] ; j < pend ; j++)
        {
            ABS (abs_value, Aentry [j]) ;
            csum += abs_value ;
        }
        if (csum > anorm)
        {
            anorm = csum ;
        }
    }

    /* ---------------------------------------------------------------------- */
    /* compute estimate of 1-norm of inv (A) */
    /* ---------------------------------------------------------------------- */

    /* get workspace (size 2*n Entry's) */
    X = Numeric->Xwork ;            /* size n space used in KLU_solve, tsolve */
    X += n ;                        /* X is size n */
    S = X + n ;                     /* S is size n */

    for (i = 0 ; i < n ; i++)
    {
        CLEAR (S [i]) ;
        CLEAR (X [i]) ;
        REAL (X [i]) = 1.0 / ((double) n) ;
    }
    jmax = 0 ;

    ainv_norm = 0.0 ;
    for (i = 0 ; i < 5 ; i++)
    {
        if (i > 0)
        {
            /* X [jmax] is the largest entry in X */
            for (j = 0 ; j < n ; j++)
            {
                /* X [j] = 0 ;*/
                CLEAR (X [j]) ;
            }
            REAL (X [jmax]) = 1 ;
        }

        KLU_solve (Symbolic, Numeric, n, 1, (double *) X, Common) ;
        est_old = ainv_norm ;
        ainv_norm = 0.0 ;

        for (j = 0 ; j < n ; j++)
        {
            /* ainv_norm += ABS (X [j]) ;*/
            ABS (abs_value, X [j]) ;
            ainv_norm += abs_value ;
        }

#ifndef COMPLEX
        unchanged = TRUE ;

        for (j = 0 ; j < n ; j++)
        {
            double s = (X [j] >= 0) ? 1 : -1 ;
            if (s != (Int) REAL (S [j]))
            {
                S [j] = s ;
                unchanged = FALSE ;
            }
        }

        if (i > 0 && (ainv_norm <= est_old || unchanged))
        {
            break ;
        }
#else
        for (j = 0 ; j < n ; j++)
        {
            if (IS_NONZERO (X [j]))
            {
                ABS (abs_value, X [j]) ;
                SCALE_DIV_ASSIGN (S [j], X [j], abs_value) ;
            }
            else
            {
                CLEAR (S [j]) ;
                REAL (S [j]) = 1 ;
            }
        }

        if (i > 0 && ainv_norm <= est_old)
        {
            break ;
        }
#endif

        for (j = 0 ; j < n ; j++)
        {
            X [j] = S [j] ;
        }

#ifndef COMPLEX
        /* do a transpose solve */
        KLU_tsolve (Symbolic, Numeric, n, 1, X, Common) ;
#else
        /* do a conjugate transpose solve */
        KLU_tsolve (Symbolic, Numeric, n, 1, (double *) X, 1, Common) ;
#endif

        /* jnew = the position of the largest entry in X */
        jnew = 0 ;
        Xmax = 0 ;
        for (j = 0 ; j < n ; j++)
        {
            /* xj = ABS (X [j]) ;*/
            ABS (xj, X [j]) ;
            if (xj > Xmax)
            {
                Xmax = xj ;
                jnew = j ;
            }
        }
        if (i > 0 && jnew == jmax)
        {
            /* the position of the largest entry did not change
             * from the previous iteration */
            break ;
        }
        jmax = jnew ;
    }

    /* ---------------------------------------------------------------------- */
    /* compute another estimate of norm(inv(A),1), and take the largest one */
    /* ---------------------------------------------------------------------- */

    for (j = 0 ; j < n ; j++)
    {
        CLEAR (X [j]) ;
        if (j % 2)
        {
            REAL (X [j]) = 1 + ((double) j) / ((double) (n-1)) ;
        }
        else
        {
            REAL (X [j]) = -1 - ((double) j) / ((double) (n-1)) ;
        }
    }

    KLU_solve (Symbolic, Numeric, n, 1, (double *) X, Common) ;

    est_new = 0.0 ;
    for (j = 0 ; j < n ; j++)
    {
        /* est_new += ABS (X [j]) ;*/
        ABS (abs_value, X [j]) ;
        est_new += abs_value ;
    }
    est_new = 2 * est_new / (3 * n) ;
    ainv_norm = MAX (est_new, ainv_norm) ;

    /* ---------------------------------------------------------------------- */
    /* compute estimate of condition number */
    /* ---------------------------------------------------------------------- */

    Common->condest = ainv_norm * anorm ;
    return (TRUE) ;
}
コード例 #2
0
ファイル: cholmod_updown.c プロジェクト: rforge/matrix
int CHOLMOD(updown_mark)
(
    /* ---- input ---- */
    int update,		/* TRUE for update, FALSE for downdate */
    cholmod_sparse *C,	/* the incoming sparse update */
    Int *colmark,	/* Int array of size n.  See cholmod_updown.c */
    /* ---- in/out --- */
    cholmod_factor *L,	/* factor to modify */
    cholmod_dense *X,	/* solution to Lx=b (size n-by-1) */
    cholmod_dense *DeltaB,  /* change in b, zero on output */
    Int *rowmark,	/* Int array of size n.  See cholmod_updown.c */
    /* --------------- */
    cholmod_common *Common
)
{
    double xj, fl ;
    double *Lx, *W, *Xx, *Nx ;
    Int *Li, *Lp, *Lnz, *Cp, *Ci, *Cnz, *Head, *Flag, *Stack, *Lnext, *Iwork,
	*Set_ps1 [32], *Set_ps2 [32], *ps1, *ps2 ;
    size_t maxrank ;
    Path_type OrderedPath [32], Path [32] ;
    Int n, wdim, k1, k2, npaths, i, j, row, packed, ccol, p, cncol, do_solve,
	mark, jj, j2, kk, nextj, p1, p2, c, use_rowmark, use_colmark, newlnz,
	k, newpath, path_order, w_order, scattered, path, newparent, pp1, pp2,
	smax, maxrow, row1, nsets, s, p3, newlnz1, Set [32], top, len, lnz, m,
	botrow ;
    DEBUG (Int oldparent) ;

    /* ---------------------------------------------------------------------- */
    /* check inputs */
    /* ---------------------------------------------------------------------- */

    RETURN_IF_NULL_COMMON (FALSE) ;
    RETURN_IF_NULL (C, FALSE) ;
    RETURN_IF_NULL (L, FALSE) ;
    RETURN_IF_XTYPE_INVALID (L, CHOLMOD_PATTERN, CHOLMOD_REAL, FALSE) ;
    RETURN_IF_XTYPE_INVALID (C, CHOLMOD_REAL, CHOLMOD_REAL, FALSE) ;
    n = L->n ;
    cncol = C->ncol ;
    Common->modfl = 0 ;
    if (!(C->sorted))
    {
	ERROR (CHOLMOD_INVALID, "C must have sorted columns") ;
	return (FALSE) ;
    }
    if (n != (Int) (C->nrow))
    {
	ERROR (CHOLMOD_INVALID, "C and L dimensions do not match") ;
	return (FALSE) ;
    }
    do_solve = (X != NULL) && (DeltaB != NULL) ;
    if (do_solve)
    {
	RETURN_IF_XTYPE_INVALID (X, CHOLMOD_REAL, CHOLMOD_REAL, FALSE) ;
	RETURN_IF_XTYPE_INVALID (DeltaB, CHOLMOD_REAL, CHOLMOD_REAL, FALSE) ;
	Xx = X->x ;
	Nx = DeltaB->x ;
	if (X->nrow != L->n || X->ncol != 1 || DeltaB->nrow != L->n ||
		DeltaB->ncol != 1 || Xx == NULL || Nx == NULL)
	{
	    ERROR (CHOLMOD_INVALID, "X and/or DeltaB invalid") ;
	    return (FALSE) ;
	}
    }
    else
    {
	Xx = NULL ;
	Nx = NULL ;
    }
    Common->status = CHOLMOD_OK ;

    fl = 0 ;
    use_rowmark = (rowmark != NULL) ;
    use_colmark = (colmark != NULL) ;

    /* ---------------------------------------------------------------------- */
    /* allocate workspace */
    /* ---------------------------------------------------------------------- */

    /* Note: cholmod_rowadd and cholmod_rowdel use the second n doubles in
     * Common->Xwork for Cx, and then perform a rank-1 update here, which uses
     * the first n doubles in Common->Xwork.   Both the rowadd and rowdel
     * routines allocate enough workspace so that Common->Xwork isn't destroyed
     * below.  Also, both cholmod_rowadd and cholmod_rowdel use the second n
     * ints in Common->Iwork for Ci.
     */

    /* make sure maxrank is in the proper range */
    maxrank = CHOLMOD(maxrank) (n, Common) ;
    k = MIN (cncol, (Int) maxrank) ;	/* maximum k is wdim */
    wdim = Power2 [k] ;		/* number of columns needed in W */
    ASSERT (wdim <= (Int) maxrank) ;
    PRINT1 (("updown wdim final "ID" k "ID"\n", wdim, k)) ;
    CHOLMOD(allocate_work) (n, n, wdim * n, Common) ;
    if (Common->status < CHOLMOD_OK || maxrank == 0)
    {
	/* out of memory, L is returned unchanged */
	return (FALSE) ;
    }

    /* ---------------------------------------------------------------------- */
    /* convert to simplicial numeric LDL' factor, if not already */
    /* ---------------------------------------------------------------------- */

    if (L->xtype == CHOLMOD_PATTERN || L->is_super || L->is_ll) 
    {
	/* can only update/downdate a simplicial LDL' factorization */
	CHOLMOD(change_factor) (CHOLMOD_REAL, FALSE, FALSE, FALSE, FALSE, L,
		Common) ;
	if (Common->status < CHOLMOD_OK)
	{
	    /* out of memory, L is returned unchanged */
	    return (FALSE) ;
	}
    }

    /* ---------------------------------------------------------------------- */
    /* get inputs */
    /* ---------------------------------------------------------------------- */

    mark = CHOLMOD(clear_flag) (Common) ;

    PRINT1 (("updown, rank %ld update %d\n", (long) C->ncol, update)) ;
    DEBUG (CHOLMOD(dump_factor) (L, "input L for updown", Common)) ;
    ASSERT (CHOLMOD(dump_sparse) (C, "input C for updown", Common) >= 0) ;

    Ci = C->i ;
    Cp = C->p ;
    Cnz = C->nz ;
    packed = C->packed ;
    ASSERT (IMPLIES (!packed, Cnz != NULL)) ;

    /* ---------------------------------------------------------------------- */
    /* quick return */
    /* ---------------------------------------------------------------------- */

    if (cncol <= 0 || n == 0)
    {
	/* nothing to do */
	return (TRUE) ;
    }

    /* ---------------------------------------------------------------------- */
    /* get L */
    /* ---------------------------------------------------------------------- */

    Li = L->i ;
    Lx = L->x ;
    Lp = L->p ;
    Lnz = L->nz ;
    Lnext = L->next ;
    ASSERT (Lnz != NULL) ;

    /* ---------------------------------------------------------------------- */
    /* get workspace */
    /* ---------------------------------------------------------------------- */

    Flag = Common->Flag ;	/* size n, Flag [i] <= mark must hold */
    Head = Common->Head ;	/* size n, Head [i] == EMPTY must hold */
    W = Common->Xwork ;		/* size n-by-wdim, zero on input and output*/

    /* note that Iwork [n .. 2*n-1] (i/i/l) may be in use in rowadd/rowdel: */
    Iwork = Common->Iwork ;
    Stack = Iwork ;		/* size n, uninitialized (i/i/l) */

    /* ---------------------------------------------------------------------- */
    /* entire rank-cncol update, done as a sequence of rank-k updates */
    /* ---------------------------------------------------------------------- */

    ps1 = NULL ;
    ps2 = NULL ;

    for (k1 = 0 ; k1 < cncol ; k1 += k)
    {

	/* ------------------------------------------------------------------ */
	/* get the next k columns of C for the update/downdate */
	/* ------------------------------------------------------------------ */

	/* the last update/downdate might be less than rank-k */
	if (k > cncol - k1)
	{
	    k = cncol - k1 ;
	    wdim = Power2 [k] ;
	}
	k2 = k1 + k - 1 ;

	/* workspaces are in the following state, on input and output */
	ASSERT (CHOLMOD(dump_work) (TRUE, TRUE, wdim, Common)) ;

	/* ------------------------------------------------------------------ */
	/* create a zero-length path for each column of W */
	/* ------------------------------------------------------------------ */

	nextj = n ;
	path = 0 ;
	for (ccol = k1 ; ccol <= k2 ; ccol++)
	{
	    PRINT1 (("Column ["ID"]: "ID"\n", path, ccol)) ;
	    ASSERT (ccol >= 0 && ccol <= cncol) ;
	    pp1 = Cp [ccol] ;
	    pp2 = (packed) ? (Cp [ccol+1]) : (pp1 + Cnz [ccol]) ;
	    /* get the row index j of the first entry in C (:,ccol) */
	    if (pp2 > pp1)
	    {
		/* Column ccol of C has at least one entry. */
		j = Ci [pp1] ;
	    }
	    else
	    {
		/* Column ccol of C is empty.  Pretend it has one entry in
		 * the last column with numerical value of zero. */
		j = n-1 ;
	    }
	    ASSERT (j >= 0 && j < n) ;

	    /* find first column to work on */
	    nextj = MIN (nextj, j) ;

	    Path [path].ccol = ccol ;	/* which column of C this path is for */
	    Path [path].start = EMPTY ;	/* paths for C have zero length */
	    Path [path].end = EMPTY ;
	    Path [path].parent = EMPTY ;    /* no parent yet */
	    Path [path].rank = 1 ;	    /* one column of W */
	    Path [path].c = EMPTY ;	    /* no child of this path (case A) */
	    Path [path].next = Head [j] ;   /* this path is pending at col j */
	    Path [path].pending = j ;	    /* this path is pending at col j */
	    Head [j] = path ;		    /* this path is pending at col j */
	    PRINT1(("Path "ID" starts: start "ID" end "ID" parent "ID" c "ID""
		    "j "ID" ccol "ID"\n", path, Path [path].start,
		    Path [path].end, Path [path].parent,
		    Path [path].c, j, ccol)) ;
	    path++ ;
	}

	/* we start with paths 0 to k-1.  Next one (now unused) is npaths */
	npaths = k ;

	j = nextj ;
	ASSERT (j < n) ;
	scattered = FALSE ;

	/* ------------------------------------------------------------------ */
	/* symbolic update of columns of L */
	/* ------------------------------------------------------------------ */

	while (j < n)
	{
	    ASSERT (j >= 0 && j < n && Lnz [j] > 0) ;

	    /* the old column, Li [p1..p2-1].  D (j,j) is stored in Lx [p1] */
	    p1 = Lp [j] ;
	    newlnz = Lnz [j] ;
	    p2 = p1 + newlnz  ;

#ifndef NDEBUG
	    PRINT1 (("\n=========Column j="ID" p1 "ID" p2 "ID" lnz "ID" \n",
			j, p1, p2, newlnz)) ;
	    dump_col ("Old", j, p1, p2, Li, Lx, n, Common) ;
	    oldparent = (Lnz [j] > 1) ? (Li [p1 + 1]) : EMPTY ;
	    ASSERT (CHOLMOD(dump_work) (TRUE, FALSE, 0, Common)) ;
	    ASSERT (!scattered) ;
	    PRINT1 (("Col "ID": Checking paths, npaths: "ID"\n", j, npaths)) ;
	    for (kk = 0 ; kk < npaths ; kk++)
	    {
		Int kk2, found, j3 = Path [kk].pending ;
		PRINT2 (("Path "ID" pending at "ID".\n", kk, j3)) ;
		if (j3 != EMPTY)
		{
		    /* Path kk must be somewhere in link list for column j3 */
		    ASSERT (Head [j3] != EMPTY) ;
		    PRINT3 (("    List at "ID": ", j3)) ;
		    found = FALSE ;
		    for (kk2 = Head [j3] ; kk2 != EMPTY ; kk2 = Path [kk2].next)
		    {
			PRINT3 ((""ID" ", kk2)) ;
			ASSERT (Path [kk2].pending == j3) ;
			found = found || (kk2 == kk) ;
		    }
		    PRINT3 (("\n")) ;
		    ASSERT (found) ;
		}
	    }
	    PRINT1 (("\nCol "ID": Paths at this column, head "ID"\n",
			j, Head [j]));
	    ASSERT (Head [j] != EMPTY) ;
	    for (kk = Head [j] ; kk != EMPTY ; kk = Path [kk].next)
	    {
		PRINT1 (("path "ID": (c="ID" j="ID") npaths "ID"\n",
			    kk, Path[kk].c, j, npaths)) ;
		ASSERT (kk >= 0 && kk < npaths) ;
		ASSERT (Path [kk].pending == j) ;
	    }
#endif

	    /* -------------------------------------------------------------- */
	    /* update/downdate of forward solve, Lx=b */
	    /* -------------------------------------------------------------- */

	    if (do_solve)
	    {
		xj = Xx [j] ;
		if (IS_NONZERO (xj))
		{
		    xj = Xx [j] ;
		    /* This is first time column j has been seen for entire */
		    /* rank-k update/downdate. */

		    /* DeltaB += Lold (j:botrow-1,j) * X (j) */
		    Nx [j] += xj ;			/* diagonal of L */
		    botrow = (use_rowmark) ? (rowmark [j]) : n ;
		    for (p = p1 + 1 ; p < p2 ; p++)
		    {
			i = Li [p] ;
			if (i >= botrow)
			{
			    break ;
			}
			Nx [i] += Lx [p] * xj ;
		    }

		    /* clear X[j] to flag col j of Lold as having been seen.  If
		     * X (j) was initially zero, then the above code is never
		     * executed for column j.  This is safe, since if xj=0 the
		     * code above does not do anything anyway.  */
		    Xx [j] = 0.0 ;
		}
	    }

	    /* -------------------------------------------------------------- */
	    /* start a new path at this column if two or more paths merge */
	    /* -------------------------------------------------------------- */

	    /* get the first old path at column j */
	    path = Head [j] ;

	    newpath =
		/* start a new path if paths have merged */
		(Path [path].next != EMPTY)
		/* or if j is the first node on a path (case A). */
		|| (Path [path].c == EMPTY) ;

	    if (newpath)
	    {
		path = npaths++ ;
		ASSERT (npaths <= 3*k) ;
		Path [path].ccol = EMPTY ; /* no single col of C for this path*/
		Path [path].start = j ;	   /* path starts at this column j */
		Path [path].end = EMPTY ;  /* don't know yet where it ends */
		Path [path].parent = EMPTY ;/* don't know parent path yet */
		Path [path].rank = 0 ;	/* rank is sum of child path ranks */
		PRINT1 (("Path "ID" starts: start "ID" end "ID" parent "ID"\n",
		path, Path [path].start, Path [path].end, Path [path].parent)) ;
	    }

	    /* -------------------------------------------------------------- */
	    /* for each path kk pending at column j */
	    /* -------------------------------------------------------------- */

	    /* make a list of the sets that need to be merged into column j */
	    nsets = 0 ;

	    for (kk = Head [j] ; kk != EMPTY ; kk = Path [kk].next)
	    {

		/* ---------------------------------------------------------- */
		/* path kk is at (c,j) */
		/* ---------------------------------------------------------- */

		c = Path [kk].c ;
		ASSERT (c < j) ;
		PRINT1 (("TUPLE on path "ID" (c="ID" j="ID")\n", kk, c, j)) ;
		ASSERT (Path [kk].pending == j) ;

		if (newpath)
		{
		    /* finalize path kk and find rank of this path */
		    Path [kk].end = c ;	/* end of old path is previous node c */
		    Path [kk].parent = path ;	/* parent is this path */
		    Path [path].rank += Path [kk].rank ;    /* sum up ranks */
		    Path [kk].pending = EMPTY ;
		    PRINT1 (("Path "ID" done:start "ID" end "ID" parent "ID"\n",
		    kk, Path [kk].start, Path [kk].end, Path [kk].parent)) ;
		}

		if (c == EMPTY)
		{

		    /* ------------------------------------------------------ */
		    /* CASE A: first node in path */
		    /* ------------------------------------------------------ */

		    /* update:  add pattern of incoming column */

		    /* Column ccol of C is in Ci [pp1 ... pp2-1] */
		    ccol = Path [kk].ccol ;
		    pp1 = Cp [ccol] ;
		    pp2 = (packed) ? (Cp [ccol+1]) : (pp1 + Cnz [ccol]) ;
		    PRINT1 (("Case A, ccol = "ID" len "ID"\n", ccol, pp2-pp1)) ;
		    ASSERT (IMPLIES (pp2 > pp1, Ci [pp1] == j)) ;

		    if (!scattered)
		    {
			/* scatter the original pattern of column j of L */
			for (p = p1 ; p < p2 ; p++)
			{
			    Flag [Li [p]] = mark ;
			}
			scattered = TRUE ;
		    }

		    /* scatter column ccol of C (skip first entry, j) */
		    newlnz1 = newlnz ;
		    for (p = pp1 + 1 ; p < pp2 ; p++)
		    {
			row = Ci [p] ;
			if (Flag [row] < mark)
			{
			    /* this is a new entry in Lj' */
			    Flag [row] = mark ;
			    newlnz++ ;
			}
		    }
		    if (newlnz1 != newlnz)
		    {
			/* column ccol of C adds something to column j of L */
			Set [nsets++] = FLIP (ccol) ;
		    }

		}
		else if (Head [c] == 1)
		{

		    /* ------------------------------------------------------ */
		    /* CASE B: c is old, but changed, child of j */
		    /* CASE C: new child of j */
		    /* ------------------------------------------------------ */

		    /* Head [c] is 1 if col c of L has new entries,
		     * EMPTY otherwise */
		    Flag [c] = 0 ;
		    Head [c] = EMPTY ;

		    /* update: add Lc' */

		    /* column c of L is in Li [pp1 .. pp2-1] */
		    pp1 = Lp [c] ;
		    pp2 = pp1 + Lnz [c] ;
		    PRINT1 (("Case B/C: c = "ID"\n", c)) ;
		    DEBUG (dump_col ("Child", c, pp1, pp2, Li, Lx, n, Common)) ;
		    ASSERT (j == Li [pp1 + 1]) ; /* j is new parent of c */

		    if (!scattered)
		    {
			/* scatter the original pattern of column j of L */
			for (p = p1 ; p < p2 ; p++)
			{
			    Flag [Li [p]] = mark ;
			}
			scattered = TRUE ;
		    }

		    /* scatter column c of L (skip first two entries, c and j)*/
		    newlnz1 = newlnz ;
		    for (p = pp1 + 2 ; p < pp2 ; p++)
		    {
			row = Li [p] ;
			if (Flag [row] < mark)
			{
			    /* this is a new entry in Lj' */
			    Flag [row] = mark ;
			    newlnz++ ;
			}
		    }
		    PRINT2 (("\n")) ;

		    if (newlnz1 != newlnz)
		    {
			/* column c of L adds something to column j of L */
			Set [nsets++] = c ;
		    }
		}
	    }

	    /* -------------------------------------------------------------- */
	    /* update the pattern of column j of L */
	    /* -------------------------------------------------------------- */

	    /* Column j of L will be in Li/Lx [p1 .. p3-1] */
	    p3 = p1 + newlnz ;
	    ASSERT (IMPLIES (nsets == 0, newlnz == Lnz [j])) ;
	    PRINT1 (("p1 "ID" p2 "ID" p3 "ID" nsets "ID"\n", p1, p2, p3,nsets));

	    /* -------------------------------------------------------------- */
	    /* ensure we have enough space for the longer column */
	    /* -------------------------------------------------------------- */

	    if (nsets > 0 && p3 > Lp [Lnext [j]])
	    {
		PRINT1 (("Col realloc: j "ID" newlnz "ID"\n", j, newlnz)) ;
		if (!CHOLMOD(reallocate_column) (j, newlnz, L, Common))
		{
		    /* out of memory, L is now simplicial symbolic */
		    CHOLMOD(clear_flag) (Common) ;
		    for (j = 0 ; j <= n ; j++)
		    {
			Head [j] = EMPTY ;
		    }
		    ASSERT (CHOLMOD(dump_work) (TRUE, TRUE, wdim, Common)) ;
		    return (FALSE) ;
		}
		/* L->i and L->x may have moved.  Column j has moved too */
		Li = L->i ;
		Lx = L->x ;
		p1 = Lp [j] ;
		p2 = p1 + Lnz [j] ;
		p3 = p1 + newlnz ;
	    }

	    /* -------------------------------------------------------------- */
	    /* create set pointers */
	    /* -------------------------------------------------------------- */

	    for (s = 0 ; s < nsets ; s++)
	    {
		/* Pattern of Set s is *(Set_ps1 [s] ... Set_ps2 [s]-1) */
		c = Set [s] ;
		if (c < EMPTY)
		{
		    /* column ccol of C, skip first entry (j) */
		    ccol = FLIP (c) ;
		    pp1 = Cp [ccol] ;
		    pp2 = (packed) ? (Cp [ccol+1]) : (pp1 + Cnz [ccol]) ;
		    ASSERT (pp2 - pp1 > 1) ;
		    Set_ps1 [s] = &(Ci [pp1 + 1]) ;
		    Set_ps2 [s] = &(Ci [pp2]) ;
		    PRINT1 (("set "ID" is ccol "ID"\n", s, ccol)) ;
		}
		else
		{
		    /* column c of L, skip first two entries (c and j)  */
		    pp1 = Lp [c] ;
		    pp2 = pp1 + Lnz [c]  ;
		    ASSERT (Lnz [c] > 2) ;
		    Set_ps1 [s] = &(Li [pp1 + 2]) ;
		    Set_ps2 [s] = &(Li [pp2]) ;
		    PRINT1 (("set "ID" is L "ID"\n", s, c)) ;
		}
		DEBUG (dump_set (s, Set_ps1, Set_ps2, j, n, Common)) ;
	    }

	    /* -------------------------------------------------------------- */
	    /* multiset merge */
	    /* -------------------------------------------------------------- */

	    /* Merge the sets into a single sorted set, Lj'.  Before the merge
	     * starts, column j is located in Li/Lx [p1 ... p2-1] and the
	     * space Li/Lx [p2 ... p3-1] is empty.  p1 is Lp [j], p2 is
	     * Lp [j] + Lnz [j] (the old length of the column), and p3 is
	     * Lp [j] + newlnz (the new and longer length of the column).
	     *
	     * The sets 0 to nsets-1 are defined by the Set_ps1 and Set_ps2
	     * pointers.  Set s is located in *(Set_ps1 [s] ... Set_ps2 [s]-1).
	     * It may be a column of C, or a column of L.  All row indices i in
	     * the sets are in the range i > j and i < n.  All sets are sorted.
	     *
	     * The merge into column j of L is done in place.
	     *
	     * During the merge, p2 and p3 are updated.  Li/Lx [p1..p2-1]
	     * reflects the indices of the old column j of L that are yet to
	     * be merged into the new column.  Entries in their proper place in
	     * the new column j of L are located in Li/Lx [p3 ... p1+newlnz-1].
	     * The merge finishes when p2 == p3.
	     *
	     * During the merge, set s consumed as it is merged into column j of
	     * L.  Its unconsumed contents are *(Set_ps1 [s] ... Set_ps2 [s]-1).
	     * When a set is completely consumed, it is removed from the set of
	     * sets, and nsets is decremented.
	     *
	     * The multiset merge and 2-set merge finishes when p2 == p3.
	     */

	    PRINT1 (("Multiset merge p3 "ID" p2 "ID" nsets "ID"\n",
			p3, p2, nsets)) ;

	    while (p3 > p2 && nsets > 1)
	    {

#ifndef NDEBUG
		PRINT2 (("\nMultiset merge.  nsets = "ID"\n", nsets)) ;
		PRINT2 (("Source col p1 = "ID", p2 = "ID", p3= "ID"\n",
			    p1, p2, p3)) ;
		for (p = p1 + 1 ; p < p2 ; p++)
		{
		    PRINT2 (("    p: "ID" source row "ID" %g\n",
				p, Li[p], Lx[p])) ;
		    ASSERT (Li [p] > j && Li [p] < n) ;
		}
		PRINT2 (("---\n")) ;
		for (p = p3 ; p < p1 + newlnz ; p++)
		{
		    PRINT2 (("    p: "ID" target row "ID" %g\n",
				p, Li[p], Lx[p])) ;
		    ASSERT (Li [p] > j && Li [p] <  n) ;
		}
		for (s = 0 ; s < nsets ; s++)
		{
		    dump_set (s, Set_ps1, Set_ps2, j, n, Common) ;
		}
#endif

		/* get the entry at the tail end of source column Lj */
		row1 = Li [p2 - 1] ;
		ASSERT (row1 >= j && p2 >= p1) ;

		/* find the largest row in all the sets */
		maxrow = row1 ;
		smax = EMPTY ;
		for (s = nsets-1 ; s >= 0 ; s--)
		{
		    ASSERT (Set_ps1 [s] < Set_ps2 [s]) ;
		    row = *(Set_ps2 [s] - 1) ;
		    if (row == maxrow)
		    {
			/* skip past this entry in set s (it is a duplicate) */
			Set_ps2 [s]-- ;
			if (Set_ps1 [s] == Set_ps2 [s])
			{
			    /* nothing more in this set */
			    nsets-- ;
			    Set_ps1 [s] = Set_ps1 [nsets] ;
			    Set_ps2 [s] = Set_ps2 [nsets] ;
			    if (smax == nsets)
			    {
				/* Set smax redefined; it is now this set */
				smax = s ;
			    }
			}
		    }
		    else if (row > maxrow)
		    {
			maxrow = row ;
			smax = s ;
		    }
		}
		ASSERT (maxrow > j) ;

		/* move the row onto the stack of the target column */
		if (maxrow == row1)
		{
		    /* next entry is in Lj, move to the bottom of Lj' */
		    ASSERT (smax == EMPTY) ;
		    p2-- ;
		    p3-- ;
		    Li [p3] = maxrow ;
		    Lx [p3] = Lx [p2] ;
		}
		else
		{
		    /* new entry in Lj' */
		    ASSERT (smax >= 0 && smax < nsets) ;
		    Set_ps2 [smax]-- ;
		    p3-- ;
		    Li [p3] = maxrow ;
		    Lx [p3] = 0.0 ;
		    if (Set_ps1 [smax] == Set_ps2 [smax])
		    {
			/* nothing more in this set */
			nsets-- ;
			Set_ps1 [smax] = Set_ps1 [nsets] ;
			Set_ps2 [smax] = Set_ps2 [nsets] ;
			PRINT1 (("Set "ID" now empty\n", smax)) ;
		    }
		}
	    }

	    /* -------------------------------------------------------------- */
	    /* 2-set merge: */
	    /* -------------------------------------------------------------- */

	    /* This the same as the multi-set merge, except there is only one
	     * set s = 0 left.  The source column j and the set 0 are being
	     * merged into the target column j. */

	    if (nsets > 0)
	    {
		ps1 = Set_ps1 [0] ;
		ps2 = Set_ps2 [0] ;
	    }

	    while (p3 > p2)
	    {

#ifndef NDEBUG
		PRINT2 (("\n2-set merge.\n")) ;
		ASSERT (nsets == 1) ;
		PRINT2 (("Source col p1 = "ID", p2 = "ID", p3= "ID"\n",
			    p1, p2, p3)) ;
		for (p = p1 + 1 ; p < p2 ; p++)
		{
		    PRINT2 (("    p: "ID" source row "ID" %g\n",
				p, Li[p], Lx[p])) ;
		    ASSERT (Li [p] > j && Li [p] < n) ;
		}
		PRINT2 (("---\n")) ;
		for (p = p3 ; p < p1 + newlnz ; p++)
		{
		    PRINT2 (("    p: "ID" target row "ID" %g\n",
				p, Li[p], Lx[p])) ;
		    ASSERT (Li [p] > j && Li [p] <  n) ;
		}
		dump_set (0, Set_ps1, Set_ps2, j, n, Common) ;
#endif

		if (p2 == p1 + 1)
		{
		    /* the top of Lj is empty; copy the set and quit */
		    while (p3 > p2)
		    {
			/* new entry in Lj' */
			row = *(--ps2) ;
			p3-- ;
			Li [p3] = row ;
			Lx [p3] = 0.0 ;
		    }
		}
		else
		{
		    /* get the entry at the tail end of Lj */
		    row1 = Li [p2 - 1] ;
		    ASSERT (row1 > j && row1 < n) ;
		    /* get the entry at the tail end of the incoming set */
		    ASSERT (ps1 < ps2) ;
		    row = *(ps2-1) ;
		    ASSERT (row > j && row1 < n) ;
		    /* move the larger of the two entries to the target set */
		    if (row1 >= row)
		    {
			/* next entry is in Lj, move to the bottom */
			if (row1 == row)
			{
			    /* skip past this entry in the set */
			    ps2-- ;
			}
			p2-- ;
			p3-- ;
			Li [p3] = row1 ;
			Lx [p3] = Lx [p2] ;
		    }
		    else
		    {
			/* new entry in Lj' */
			ps2-- ;
			p3-- ;
			Li [p3] = row ;
			Lx [p3] = 0.0 ;
		    }
		}
	    }

	    /* -------------------------------------------------------------- */
	    /* The new column j of L is now in Li/Lx [p1 ... p2-1] */
	    /* -------------------------------------------------------------- */

	    p2 = p1 + newlnz ;
	    DEBUG (dump_col ("After merge: ", j, p1, p2, Li, Lx, n, Common)) ;

	    fl += Path [path].rank * (6 + 4 * (double) newlnz) ;

	    /* -------------------------------------------------------------- */
	    /* clear Flag; original pattern of column j L no longer marked */
	    /* -------------------------------------------------------------- */

	    mark = CHOLMOD(clear_flag) (Common) ;
	    scattered = FALSE ;

	    /* -------------------------------------------------------------- */
	    /* find the new parent */
	    /* -------------------------------------------------------------- */

	    newparent = (newlnz > 1) ? (Li [p1 + 1]) : EMPTY ;
	    PRINT1 (("\nNew parent, Lnz: "ID": "ID" "ID"\n",
			j, newparent,newlnz));
	    ASSERT (oldparent == EMPTY || newparent <= oldparent) ;

	    /* -------------------------------------------------------------- */
	    /* go to the next node in the path */
	    /* -------------------------------------------------------------- */

	    /* path moves to (j,nextj) unless j is a root */
	    nextj = (newparent == EMPTY) ? n : newparent ;

	    /* place path at head of list for nextj, or terminate the path */
	    PRINT1 (("\n j = "ID" nextj = "ID"\n\n", j, nextj)) ;
	    Path [path].c = j ;
	    if (nextj < n)
	    {
		/* put path on link list of pending paths at column nextj */
		Path [path].next = Head [nextj] ;
		Path [path].pending = nextj ;
		Head [nextj] = path ;
		PRINT1 (("Path "ID" continues to ("ID","ID").  Rank "ID"\n",
		    path, Path [path].c, nextj, Path [path].rank)) ;
	    }
	    else
	    {
		/* path has ended here, at a root */
		Path [path].next = EMPTY ;
		Path [path].pending = EMPTY ;
		Path [path].end = j ;
		PRINT1 (("Path "ID" ends at root ("ID").  Rank "ID"\n",
		    path, Path [path].end, Path [path].rank)) ;
	    }

	    /* The link list Head [j] can now be emptied.  Set Head [j] to 1
	     * if column j has changed (it is no longer used as a link list). */
	    PRINT1 (("column "ID", oldlnz = "ID"\n", j, Lnz [j])) ;
	    Head [j] = (Lnz [j] != newlnz) ? 1 : EMPTY ;
	    Lnz [j] = newlnz ;
	    PRINT1 (("column "ID", newlnz = "ID"\n", j, newlnz)) ;
	    DEBUG (dump_col ("New", j, p1, p2, Li, Lx, n, Common)) ;

	    /* move to the next column */
	    if (k == Path [path].rank)
	    {
		/* only one path left */
		j = nextj ;
	    }
	    else
	    {
		/* The current path is moving from column j to column nextj
		 * (nextj is n if the path has ended).  However, there may be
		 * other paths pending in columns j+1 to nextj-1.  There are
		 * two methods for looking for the next column with a pending
		 * update.  The first one looks at all columns j+1 to nextj-1
		 * for a non-empty link list.  This can be costly if j and
		 * nextj differ by a large amount (it can be O(n), but this
		 * entire routine may take Omega(1) time).  The second method
		 * looks at all paths and finds the smallest column at which any
		 * path is pending.  It takes O(# of paths), which is bounded
		 * by 23: one for each column of C (up to 8), and then 15 for a
		 * balanced binary tree with 8 leaves.  However, if j and
		 * nextj differ by a tiny amount (nextj is often j+1 near
		 * the end of the matrix), looking at columns j+1 to nextj
		 * would be faster.  Both methods give the same answer. */

		if (nextj - j < npaths)
		{
		    /* there are fewer columns to search than paths */
		    PRINT1 (("check j="ID" to nextj="ID"\n", j, nextj)) ;
		    for (j2 = j + 1 ; j2 < nextj ; j2++)
		    {
			PRINT1 (("check j="ID" "ID"\n", j2, Head [j2])) ;
			if (Head [j2] != EMPTY)
			{
			    PRINT1 (("found, j="ID"\n", j2)) ;
			    ASSERT (Path [Head [j2]].pending == j2) ;
			    break ;
			}
		    }
		}
		else
		{
		    /* there are fewer paths than columns to search */
		    j2 = nextj ;
		    for (kk = 0 ; kk < npaths ; kk++)
		    {
			jj = Path [kk].pending ;
			PRINT2 (("Path "ID" pending at "ID"\n", kk, jj)) ;
			if (jj != EMPTY) j2 = MIN (j2, jj) ;
		    }
		}
		j = j2 ;
	    }
	}

	/* ensure workspaces are back to the values required on input */
	ASSERT (CHOLMOD(dump_work) (TRUE, TRUE, TRUE, Common)) ;

	/* ------------------------------------------------------------------ */
	/* depth-first-search of tree to order the paths */
	/* ------------------------------------------------------------------ */

	/* create lists of child paths */
	PRINT1 (("\n\nDFS search:\n\n")) ;
	for (path = 0 ; path < npaths ; path++)
	{
	    Path [path].c = EMPTY ;	    /* first child of path */
	    Path [path].next = EMPTY ;	    /* next sibling of path */
	    Path [path].order = EMPTY ;	    /* path is not ordered yet */
	    Path [path].wfirst = EMPTY ;    /* 1st column of W not found yet */

#ifndef NDEBUG
	    j = Path [path].start ;
	    PRINT1 (("Path "ID" : start "ID" end "ID" parent "ID" ccol "ID"\n", 
	    path, j, Path [path].end, Path [path].parent, Path [path].ccol)) ;
	    for ( ; ; )
	    {
		PRINT1 (("	column "ID"\n", j)) ;
		ASSERT (j == EMPTY || (j >= 0 && j < n)) ;
		if (j == Path [path].end)
		{
		    break ;
		}
		ASSERT (j >= 0 && j < n) ;
		j = (Lnz [j] > 1) ? (Li [Lp [j] + 1]) : EMPTY ;
	    }
#endif
	}

	for (path = 0 ; path < npaths ; path++)
	{
	    p = Path [path].parent ;	/* add path to child list of parent */
	    if (p != EMPTY)
	    {
		ASSERT (p < npaths) ;
		Path [path].next = Path [p].c ;
		Path [p].c = path ;
	    }
	}

	path_order = k ;
	w_order = 0 ;
	for (path = npaths-1 ; path >= 0 ; path--)
	{
	    if (Path [path].order == EMPTY)
	    {
		/* this path is the root of a subtree of Tbar */
		PRINT1 (("Root path "ID"\n", path)) ;
		ASSERT (path >= k) ;
		dfs (Path, k, path, &path_order, &w_order, 0, npaths) ;
	    }
	}
	ASSERT (path_order == npaths) ;
	ASSERT (w_order == k) ;

	/* reorder the paths */
	for (path = 0 ; path < npaths ; path++)
	{
	    /* old order is path, new order is Path [path].order */
	    OrderedPath [Path [path].order] = Path [path] ;
	}

#ifndef NDEBUG
	for (path = 0 ; path < npaths ; path++)
	{
	    PRINT1 (("Ordered Path "ID": start "ID" end "ID" wfirst "ID" rank "
		    ""ID" ccol "ID"\n", path, OrderedPath [path].start,
		    OrderedPath [path].end, OrderedPath [path].wfirst,
		    OrderedPath [path].rank, OrderedPath [path].ccol)) ;
	    if (path < k)
	    {
		ASSERT (OrderedPath [path].ccol >= 0) ;
	    }
	    else
	    {
		ASSERT (OrderedPath [path].ccol == EMPTY) ;
	    }
	}
#endif

	/* ------------------------------------------------------------------ */
	/* numeric update/downdate for all paths */
	/* ------------------------------------------------------------------ */

	ASSERT (CHOLMOD(dump_work) (TRUE, TRUE, wdim, Common)) ;

	switch (wdim)
	{
	    case 1:
		updown_1_r (update, C, k, L, W, OrderedPath, npaths, Common) ;
		break ;
	    case 2:
		updown_2_r (update, C, k, L, W, OrderedPath, npaths, Common) ;
		break ;
	    case 4:
		updown_4_r (update, C, k, L, W, OrderedPath, npaths, Common) ;
		break ;
	    case 8:
		updown_8_r (update, C, k, L, W, OrderedPath, npaths, Common) ;
		break ;
	}

	ASSERT (CHOLMOD(dump_work) (TRUE, TRUE, wdim, Common)) ;
    }

    /* ---------------------------------------------------------------------- */
    /* update/downdate the forward solve */
    /* ---------------------------------------------------------------------- */

    if (do_solve)
    {

	/* We now have DeltaB += Lold (:,j) * X (j) for all columns j in union
	 * of all paths seen during the entire rank-cncol update/downdate. For
	 * each j in path, do DeltaB -= Lnew (:,j)*DeltaB(j) 
	 * in topological order. */

#ifndef NDEBUG
	PRINT1 (("\ndo_solve, DeltaB + Lold(:,Path)*X(Path):\n")) ;
	for (i = 0 ; i < n ; i++)
	{
	    PRINT1 (("do_solve: "ID" %30.20e\n", i, Nx [i])) ;
	}
#endif

	/* Note that the downdate, if it deleted entries, would need to compute
	 * the Stack prior to doing any downdates. */

	/* find the union of all the paths in the new L */
	top = n ;	/* "top" is stack pointer, not a row or column index */
	for (ccol = 0 ; ccol < cncol ; ccol++)
	{

	    /* -------------------------------------------------------------- */
	    /* j = first row index of C (:,ccol) */
	    /* -------------------------------------------------------------- */

	    pp1 = Cp [ccol] ;
	    pp2 = (packed) ? (Cp [ccol+1]) : (pp1 + Cnz [ccol]) ;
	    if (pp2 > pp1)
	    {
		/* Column ccol of C has at least one entry. */
		j = Ci [pp1] ;
	    }
	    else
	    {
		/* Column ccol of C is empty */
		j = n-1 ;
	    }
	    PRINT1 (("\ndo_solve:      ccol= "ID"\n", ccol)) ;
	    ASSERT (j >= 0 && j < n) ;
	    len = 0 ;

	    /* -------------------------------------------------------------- */
	    /* find the new rowmark */
	    /* -------------------------------------------------------------- */

	    /* Each column of C can redefine the region of L that takes part in
	     * the update/downdate of the triangular solve Lx=b.  If
	     * i = colmark [ccol] for column C(:,ccol), then i = rowmark [j] is
	     * redefined for all columns along the path modified by C(:,ccol).
	     * If more than one column modifies any given column j of L, then
	     * the rowmark of j is determined by the colmark of the least-
	     * numbered column that affects column j.  That is, if both
	     * C(:,ccol1) and C(:,ccol2) affect column j of L, then
	     * rowmark [j] = colmark [MIN (ccol1, ccol2)].
	     *
	     * rowmark [j] is not modified if rowmark or colmark are NULL,
	     * or if colmark [ccol] is EMPTY.
	     */

	    botrow = (use_colmark && use_rowmark) ? (colmark [ccol]) : EMPTY ;

	    /* -------------------------------------------------------------- */
	    /* traverse from j towards root, stopping if node already visited */
	    /* -------------------------------------------------------------- */

	    while (j != EMPTY && Flag [j] < mark)
	    {
		PRINT1 (("do_solve: subpath j= "ID"\n", j)) ;
		ASSERT (j >= 0 && j < n) ;
		Stack [len++] = j ;		/* place j on the stack */
		Flag [j] = mark ;		/* flag j as visited */

		/* redefine the parts of column j of L that take part in
		 * the triangular solve. */
		if (botrow != EMPTY)
		{
		    /* update rowmark to keep track of botrow for col j */
		    rowmark [j] = botrow ;
		}

		/* go up the tree, to the parent of j */
		j = (Lnz [j] > 1) ? (Li [Lp [j] + 1]) : EMPTY ;
	    }

	    /* -------------------------------------------------------------- */
	    /* move the path down to the bottom of the stack */
	    /* -------------------------------------------------------------- */

	    ASSERT (len <= top) ;
	    while (len > 0)
	    {
		Stack [--top] = Stack [--len] ;
	    }
	}

#ifndef NDEBUG
	/* Union of paths now in Stack [top..n-1] in topological order */
	PRINT1 (("\nTopological order:\n")) ;
	for (i = top ; i < n ; i++)
	{
	    PRINT1 (("column "ID" in full path\n", Stack [i])) ;
	}
#endif

	/* Do the forward solve for the full path part of L */
	for (m = top ; m < n ; m++)
	{
	    j = Stack [m] ;
	    ASSERT (j >= 0 && j < n) ;
	    PRINT1 (("do_solve: path j= "ID"\n", j)) ;
	    p1 = Lp [j] ;
	    lnz = Lnz [j] ;
	    p2 = p1 + lnz ;
	    xj = Nx [j] ;

	    /* copy new solution onto old one, for all cols in full path */
	    Xx [j] = xj ;
	    Nx [j] = 0. ;

	    /* DeltaB -= Lnew (j+1:botrow-1,j) * deltab(j) */
	    botrow = (use_rowmark) ? (rowmark [j]) : n ;
	    for (p = p1 + 1 ; p < p2 ; p++)
	    {
		i = Li [p] ;
		if (i >= botrow)
		{
		    break ;
		}
		Nx [i] -= Lx [p] * xj ;
	    }
	}

	/* clear the Flag */
	mark = CHOLMOD(clear_flag) (Common) ;
    }

    /* ---------------------------------------------------------------------- */
    /* successful update/downdate */
    /* ---------------------------------------------------------------------- */

    Common->modfl = fl ;
    DEBUG (for (j = 0 ; j < n ; j++) ASSERT (IMPLIES (do_solve, Nx[j] == 0.))) ;
    ASSERT (CHOLMOD(dump_work) (TRUE, TRUE, TRUE, Common)) ;
    DEBUG (CHOLMOD(dump_factor) (L, "output L for updown", Common)) ;
    return (TRUE) ;
}
コード例 #3
0
ファイル: umf_blas3_update.c プロジェクト: Al-th/matlab
GLOBAL void UMF_blas3_update
(
    WorkType *Work
)
{
    /* ---------------------------------------------------------------------- */
    /* local variables */
    /* ---------------------------------------------------------------------- */

    Entry *L, *U, *C, *LU ;
    Int i, j, s, k, m, n, d, nb, dc ;
    
#ifndef NBLAS
    Int blas_ok = TRUE ;
#else
#define blas_ok FALSE
#endif

    DEBUG5 (("In UMF_blas3_update "ID" "ID" "ID"\n",
	Work->fnpiv, Work->fnrows, Work->fncols)) ;

    k = Work->fnpiv ;
    if (k == 0)
    {
	/* no work to do */
	return ;
    }

    m = Work->fnrows ;
    n = Work->fncols ;

    d = Work->fnr_curr ;
    dc = Work->fnc_curr ;
    nb = Work->nb ;
    ASSERT (d >= 0 && (d % 2) == 1) ;
    C = Work->Fcblock ;	    /* ldc is fnr_curr */
    L =	Work->Flblock ;	    /* ldl is fnr_curr */
    U = Work->Fublock ;	    /* ldu is fnc_curr, stored by rows */
    LU = Work->Flublock ;   /* nb-by-nb */

#ifndef NDEBUG
    DEBUG5 (("DO RANK-NB UPDATE of frontal:\n")) ;
    DEBUG5 (("DGEMM : "ID" "ID" "ID"\n", k, m, n)) ;
    DEBUG7 (("C  block: ")) ; UMF_dump_dense (C,  d, m, n) ;
    DEBUG7 (("A  block: ")) ; UMF_dump_dense (L,  d, m, k) ;
    DEBUG7 (("B' block: ")) ; UMF_dump_dense (U, dc, n, k) ;
    DEBUG7 (("LU block: ")) ; UMF_dump_dense (LU, nb, k, k) ;
#endif

    if (k == 1)
    {

#ifndef NBLAS
	BLAS_GER (m, n, L, U, C, d) ;
#endif

	if (!blas_ok)
	{
	    /* rank-1 outer product to update the C block */
	    for (j = 0 ; j < n ; j++)
	    {
		Entry u_j = U [j] ;
		if (IS_NONZERO (u_j))
		{
		    Entry *c_ij, *l_is ;
		    c_ij = & C [j*d] ;
		    l_is = & L [0] ;
#pragma ivdep
		    for (i = 0 ; i < m ; i++)
		    {
			/* C [i+j*d]-= L [i] * U [j] */
			MULT_SUB (*c_ij, *l_is, u_j) ;
			c_ij++ ;
			l_is++ ;
		    }
		}
	    }
	}

    }
    else
    {

	/* triangular solve to update the U block */

#ifndef NBLAS
	BLAS_TRSM_RIGHT (n, k, LU, nb, U, dc) ;
#endif

	if (!blas_ok)
	{
	    /* use plain C code if no BLAS at compile time, or if integer
	     * overflow has occurred */
	    for (s = 0 ; s < k ; s++)
	    {
		for (i = s+1 ; i < k ; i++)
		{
		    Entry l_is = LU [i+s*nb] ;
		    if (IS_NONZERO (l_is))
		    {
			Entry *u_ij, *u_sj ;
			u_ij = & U [i*dc] ;
			u_sj = & U [s*dc] ;
#pragma ivdep
			for (j = 0 ; j < n ; j++)
			{
			    /* U [i*dc+j] -= LU [i+s*nb] * U [s*dc+j] ; */
			    MULT_SUB (*u_ij, l_is, *u_sj) ;
			    u_ij++ ;
			    u_sj++ ;
			}
		    }
		}
	    }
	}

	/* rank-k outer product to update the C block */
	/* C = C - L*U' (U is stored by rows, not columns) */

#ifndef NBLAS
	BLAS_GEMM (m, n, k, L, U, dc, C, d) ;
#endif

	if (!blas_ok)
	{
	    /* use plain C code if no BLAS at compile time, or if integer
	     * overflow has occurred */

	    for (s = 0 ; s < k ; s++)
	    {
		for (j = 0 ; j < n ; j++)
		{
		    Entry u_sj = U [j+s*dc] ;
		    if (IS_NONZERO (u_sj))
		    {
			Entry *c_ij, *l_is ;
			c_ij = & C [j*d] ;
			l_is = & L [s*d] ;
#pragma ivdep
			for (i = 0 ; i < m ; i++)
			{
			    /* C [i+j*d]-= L [i+s*d] * U [s*dc+j] */
			    MULT_SUB (*c_ij, *l_is, u_sj) ;
			    c_ij++ ;
			    l_is++ ;
			}
		    }
		}
	    }
	}
    }

#ifndef NDEBUG
    DEBUG5 (("RANK-NB UPDATE of frontal done:\n")) ;
    DEBUG5 (("DGEMM : "ID" "ID" "ID"\n", k, m, n)) ;
    DEBUG7 (("C  block: ")) ; UMF_dump_dense (C,  d, m, n) ;
    DEBUG7 (("A  block: ")) ; UMF_dump_dense (L,  d, m, k) ;
    DEBUG7 (("B' block: ")) ; UMF_dump_dense (U, dc, n, k) ;
    DEBUG7 (("LU block: ")) ; UMF_dump_dense (LU, nb, k, k) ;
#endif

    DEBUG2 (("blas3 "ID" "ID" "ID"\n", k, Work->fnrows, Work->fncols)) ;
}
コード例 #4
0
ファイル: umf_scale.c プロジェクト: Ascronia/fieldtrip
GLOBAL void UMF_scale
(
    Int n,
    Entry pivot,
    Entry X [ ]
)
{
    Entry x ;
    double s ;
    Int i ;

    /* ---------------------------------------------------------------------- */
    /* compute the approximate absolute value of the pivot, and select method */
    /* ---------------------------------------------------------------------- */

    APPROX_ABS (s, pivot) ;

    if (s < RECIPROCAL_TOLERANCE || IS_NAN (pivot))
    {
	/* ------------------------------------------------------------------ */
	/* tiny, or zero, pivot case */
	/* ------------------------------------------------------------------ */

	/* The pivot is tiny, or NaN.  Do not divide zero by the pivot value,
	 * and do not multiply by 1/pivot, either. */

	for (i = 0 ; i < n ; i++)
	{
	    /* X [i] /= pivot ; */
	    x = X [i] ;

#ifndef NO_DIVIDE_BY_ZERO
	    if (IS_NONZERO (x))
	    {
		DIV (X [i], x, pivot) ;
	    }
#else
	    /* Do not divide by zero */
	    if (IS_NONZERO (x) && IS_NONZERO (pivot))
	    {
		DIV (X [i], x, pivot) ;
	    }
#endif

	}

    }
    else
    {

	/* ------------------------------------------------------------------ */
	/* normal case */
	/* ------------------------------------------------------------------ */

	/* The pivot is not tiny, and is not NaN.   Don't bother to check for
	 * zeros in the pivot column, X.  This is slightly more accurate than
	 * multiplying by 1/pivot (but slightly slower), particularly if the
	 * pivot column consists of only IEEE subnormals. */

	for (i = 0 ; i < n ; i++)
	{
	    /* X [i] /= pivot ; */
	    x = X [i] ;
	    DIV (X [i], x, pivot) ;
	}
    }
}
コード例 #5
0
ファイル: umf_usolve.c プロジェクト: Al-th/matlab
GLOBAL double UMF_usolve
(
    NumericType *Numeric,
    Entry X [ ],		/* b on input, solution x on output */
    Int Pattern [ ]		/* a work array of size n */
)
{
    /* ---------------------------------------------------------------------- */
    /* local variables */
    /* ---------------------------------------------------------------------- */

    Entry xk ;
    Entry *xp, *D, *Uval ;
    Int k, deg, j, *ip, col, *Upos, *Uilen, pos,
	*Uip, n, ulen, up, newUchain, npiv, n1, *Ui ;

    /* ---------------------------------------------------------------------- */
    /* get parameters */
    /* ---------------------------------------------------------------------- */

    if (Numeric->n_row != Numeric->n_col) return (0.) ;
    n = Numeric->n_row ;
    npiv = Numeric->npiv ;
    Upos = Numeric->Upos ;
    Uilen = Numeric->Uilen ;
    Uip = Numeric->Uip ;
    D = Numeric->D ;
    n1 = Numeric->n1 ;

#ifndef NDEBUG
    DEBUG4 (("Usolve start:  npiv = "ID" n = "ID"\n", npiv, n)) ;
    for (j = 0 ; j < n ; j++)
    {
	DEBUG4 (("Usolve start "ID": ", j)) ;
	EDEBUG4 (X [j]) ;
	DEBUG4 (("\n")) ;
    }
#endif

    /* ---------------------------------------------------------------------- */
    /* singular case */
    /* ---------------------------------------------------------------------- */

#ifndef NO_DIVIDE_BY_ZERO
    /* handle the singular part of D, up to just before the last pivot */
    for (k = n-1 ; k >= npiv ; k--)
    {
	/* This is an *** intentional *** divide-by-zero, to get Inf or Nan,
	 * as appropriate.  It is not a bug. */
	ASSERT (IS_ZERO (D [k])) ;
	xk = X [k] ;
	/* X [k] = xk / D [k] ; */
	DIV (X [k], xk, D [k]) ;
    }
#else
    /* Do not divide by zero */
#endif

    deg = Numeric->ulen ;
    if (deg > 0)
    {
	/* :: make last pivot row of U (singular matrices only) :: */
	for (j = 0 ; j < deg ; j++)
	{
	    DEBUG1 (("Last row of U: j="ID"\n", j)) ;
	    DEBUG1 (("Last row of U: Upattern[j]="ID"\n",
		Numeric->Upattern [j]) );
	    Pattern [j] = Numeric->Upattern [j] ;
	}
    }

    /* ---------------------------------------------------------------------- */
    /* nonsingletons */
    /* ---------------------------------------------------------------------- */

    for (k = npiv-1 ; k >= n1 ; k--)
    {

	/* ------------------------------------------------------------------ */
	/* use row k of U */
	/* ------------------------------------------------------------------ */

	up = Uip [k] ;
	ulen = Uilen [k] ;
	newUchain = (up < 0) ;
	if (newUchain)
	{
	    up = -up ;
	    xp = (Entry *) (Numeric->Memory + up + UNITS (Int, ulen)) ;
	}
	else
	{
	    xp = (Entry *) (Numeric->Memory + up) ;
	}

	xk = X [k] ;
	for (j = 0 ; j < deg ; j++)
	{
	    DEBUG4 (("  k "ID" col "ID" value", k, Pattern [j])) ;
	    EDEBUG4 (*xp) ;
	    DEBUG4 (("\n")) ;
	    /* xk -= X [Pattern [j]] * (*xp) ; */
	    MULT_SUB (xk, X [Pattern [j]], *xp) ;
	    xp++ ;
	}

#ifndef NO_DIVIDE_BY_ZERO
	/* Go ahead and divide by zero if D [k] is zero */
	/* X [k] = xk / D [k] ; */
	DIV (X [k], xk, D [k]) ;
#else
	/* Do not divide by zero */
	if (IS_NONZERO (D [k]))
	{
	    /* X [k] = xk / D [k] ; */
	    DIV (X [k], xk, D [k]) ;
	}
#endif

	/* ------------------------------------------------------------------ */
	/* make row k-1 of U in Pattern [0..deg-1] */
	/* ------------------------------------------------------------------ */

	if (k == n1) break ;

	if (newUchain)
	{
	    /* next row is a new Uchain */
	    deg = ulen ;
	    ASSERT (IMPLIES (k == 0, deg == 0)) ;
	    DEBUG4 (("end of chain for row of U "ID" deg "ID"\n", k-1, deg)) ;
	    ip = (Int *) (Numeric->Memory + up) ;
	    for (j = 0 ; j < deg ; j++)
	    {
		col = *ip++ ;
		DEBUG4 (("  k "ID" col "ID"\n", k-1, col)) ;
		ASSERT (k <= col) ;
		Pattern [j] = col ;
	    }
	}
	else
	{
	    deg -= ulen ;
	    DEBUG4 (("middle of chain for row of U "ID" deg "ID"\n", k, deg)) ;
	    ASSERT (deg >= 0) ;
	    pos = Upos [k] ;
	    if (pos != EMPTY)
	    {
		/* add the pivot column */
		DEBUG4 (("k "ID" add pivot entry at pos "ID"\n", k, pos)) ;
		ASSERT (pos >= 0 && pos <= deg) ;
		Pattern [deg++] = Pattern [pos] ;
		Pattern [pos] = k ;
	    }
	}
    }

    /* ---------------------------------------------------------------------- */
    /* singletons */
    /* ---------------------------------------------------------------------- */

    for (k = n1 - 1 ; k >= 0 ; k--)
    {
	deg = Uilen [k] ;
	xk = X [k] ;
	DEBUG4 (("Singleton k "ID"\n", k)) ;
	if (deg > 0)
	{
	    up = Uip [k] ;
	    Ui = (Int *) (Numeric->Memory + up) ;
	    up += UNITS (Int, deg) ;
	    Uval = (Entry *) (Numeric->Memory + up) ;
	    for (j = 0 ; j < deg ; j++)
	    {
		DEBUG4 (("  k "ID" col "ID" value", k, Ui [j])) ;
		EDEBUG4 (Uval [j]) ;
		DEBUG4 (("\n")) ;
		/* xk -= X [Ui [j]] * Uval [j] ; */
		ASSERT (Ui [j] >= 0 && Ui [j] < n) ;
		MULT_SUB (xk, X [Ui [j]], Uval [j]) ;
	    }
	}

#ifndef NO_DIVIDE_BY_ZERO
	/* Go ahead and divide by zero if D [k] is zero */
	/* X [k] = xk / D [k] ; */
	DIV (X [k], xk, D [k]) ;
#else
	/* Do not divide by zero */
	if (IS_NONZERO (D [k]))
	{
	    /* X [k] = xk / D [k] ; */
	    DIV (X [k], xk, D [k]) ;
	}
#endif

    }

#ifndef NDEBUG
    for (j = 0 ; j < n ; j++)
    {
	DEBUG4 (("Usolve done "ID": ", j)) ;
	EDEBUG4 (X [j]) ;
	DEBUG4 (("\n")) ;
    }
    DEBUG4 (("Usolve done.\n")) ;
#endif

    return (DIV_FLOPS * ((double) n) + MULTSUB_FLOPS * ((double) Numeric->unz));
}
コード例 #6
0
ファイル: bits.c プロジェクト: bairyn/opencurry
unsigned int is_nonzero_uint(unsigned int val)
{
  return IS_NONZERO(val);
}
コード例 #7
0
ファイル: umfpack_get_numeric.c プロジェクト: rforge/matrix
PRIVATE void get_U
(
    Int Up [ ],		/* of size n_col+1 */
    Int Ui [ ],		/* of size unz, where unz = Up [n_col] */
    double Ux [ ],	/* of size unz */
#ifdef COMPLEX
    double Uz [ ],	/* of size unz */
#endif
    NumericType *Numeric,
    Int Pattern [ ],	/* workspace of size n_col */
    Int Wi [ ]		/* workspace of size n_col */
)
{
    /* ---------------------------------------------------------------------- */
    /* local variables */
    /* ---------------------------------------------------------------------- */

    Entry value ;
    Entry *xp, *D, *Uval ;
    Int deg, j, *ip, col, *Upos, *Uilen, *Uip, n_col, ulen, *Usi,
        unz2, p, k, up, newUchain, pos, npiv, n1 ;
#ifdef COMPLEX
    Int split = SPLIT (Uz) ;
#endif
#ifndef NDEBUG
    Int nnzpiv = 0 ;
#endif

    /* ---------------------------------------------------------------------- */
    /* get parameters */
    /* ---------------------------------------------------------------------- */

    DEBUG4 (("get_U start:\n")) ;
    n_col = Numeric->n_col ;
    n1 = Numeric->n1 ;
    npiv = Numeric->npiv ;
    Upos = Numeric->Upos ;
    Uilen = Numeric->Uilen ;
    Uip = Numeric->Uip ;
    D = Numeric->D ;

    /* ---------------------------------------------------------------------- */
    /* count the nonzeros in each column of U */
    /* ---------------------------------------------------------------------- */

    for (col = 0 ; col < npiv ; col++)
    {
	/* include the diagonal entry in the column counts */
	DEBUG4 (("D ["ID"] = ", col)) ;
	EDEBUG4 (D [col]) ;
	Wi [col] = IS_NONZERO (D [col]) ;
	DEBUG4 ((" is nonzero: "ID"\n", Wi [col])) ;
#ifndef NDEBUG
	nnzpiv += IS_NONZERO (D [col]) ;
#endif
    }
    DEBUG4 (("nnzpiv "ID" "ID"\n", nnzpiv, Numeric->nnzpiv)) ;
    ASSERT (nnzpiv == Numeric->nnzpiv) ;
    for (col = npiv ; col < n_col ; col++)
    {
	/* diagonal entries are zero for structurally singular part */
	Wi [col] = 0 ;
    }

    deg = Numeric->ulen ;
    if (deg > 0)
    {
	/* make last pivot row of U (singular matrices only) */
	DEBUG0 (("Last pivot row of U: ulen "ID"\n", deg)) ;
	for (j = 0 ; j < deg ; j++)
	{
	    Pattern [j] = Numeric->Upattern [j] ;
	    DEBUG0 (("    column "ID"\n", Pattern [j])) ;
	}
    }

    /* non-singletons */
    for (k = npiv-1 ; k >= n1 ; k--)
    {

	/* ------------------------------------------------------------------ */
	/* use row k of U */
	/* ------------------------------------------------------------------ */

	up = Uip [k] ;
	ulen = Uilen [k] ;
	newUchain = (up < 0) ;
	if (newUchain)
	{
	    up = -up ;
	    xp = (Entry *) (Numeric->Memory + up + UNITS (Int, ulen)) ;
	}
	else
	{
	    xp = (Entry *) (Numeric->Memory + up) ;
	}

	for (j = 0 ; j < deg ; j++)
	{
	    DEBUG4 (("  k "ID" col "ID" value\n", k, Pattern [j])) ;
	    col = Pattern [j] ;
	    ASSERT (col >= 0 && col < n_col) ;
	    value = *xp++ ;
	    EDEBUG4 (value) ;
	    DEBUG4 (("\n")) ;
	    if (IS_NONZERO (value))
	    {
		Wi [col]++ ;
	    }
	}

	/* ------------------------------------------------------------------ */
	/* make row k-1 of U in Pattern [0..deg-1] */
	/* ------------------------------------------------------------------ */

	if (k == n1) break ;

	if (newUchain)
	{
	    /* next row is a new Uchain */
	    deg = ulen ;
	    DEBUG4 (("end of chain for row of U "ID" deg "ID"\n", k-1, deg)) ;
	    ip = (Int *) (Numeric->Memory + up) ;
	    for (j = 0 ; j < deg ; j++)
	    {
		col = *ip++ ;
		DEBUG4 (("  k "ID" col "ID"\n", k-1, col)) ;
		ASSERT (k <= col) ;
		Pattern [j] = col ;
	    }
	}
	else
	{
	    deg -= ulen ;
	    DEBUG4 (("middle of chain for row of U "ID" deg "ID"\n", k-1, deg));
	    ASSERT (deg >= 0) ;
	    pos = Upos [k] ;
	    if (pos != EMPTY)
	    {
		/* add the pivot column */
		DEBUG4 (("k "ID" add pivot entry at position "ID"\n", k, pos)) ;
		ASSERT (pos >= 0 && pos <= deg) ;
		Pattern [deg++] = Pattern [pos] ;
		Pattern [pos] = k ;
	    }
	}
    }

    /* singletons */
    for (k = n1 - 1 ; k >= 0 ; k--)
    {
	deg = Uilen [k] ;
	DEBUG4 (("Singleton k "ID"\n", k)) ;
	if (deg > 0)
	{
	    up = Uip [k] ;
	    Usi = (Int *) (Numeric->Memory + up) ;
	    up += UNITS (Int, deg) ;
	    Uval = (Entry *) (Numeric->Memory + up) ;
	    for (j = 0 ; j < deg ; j++)
	    {
		col = Usi [j] ;
		value = Uval [j] ;
		DEBUG4 (("  k "ID" col "ID" value", k, col)) ;
		EDEBUG4 (value) ;
		DEBUG4 (("\n")) ;
		if (IS_NONZERO (value))
		{
		    Wi [col]++ ;
		}
	    }
	}
    }

    /* ---------------------------------------------------------------------- */
    /* construct the final column form of U */
    /* ---------------------------------------------------------------------- */

    /* create the column pointers */
    unz2 = 0 ;
    for (col = 0 ; col < n_col ; col++)
    {
	Up [col] = unz2 ;
	unz2 += Wi [col] ;
    }
    Up [n_col] = unz2 ;
    DEBUG1 (("Numeric->unz "ID"  npiv "ID" nnzpiv "ID" unz2 "ID"\n",
	Numeric->unz, npiv, Numeric->nnzpiv, unz2)) ;
    ASSERT (Numeric->unz + Numeric->nnzpiv == unz2) ;

    for (col = 0 ; col < n_col ; col++)
    {
	Wi [col] = Up [col+1] ;
    }

    /* add all of the diagonal entries */
    for (col = 0 ; col < npiv ; col++)
    {
	if (IS_NONZERO (D [col]))
	{
	    p = --(Wi [col]) ;
	    Ui [p] = col ;
#ifdef COMPLEX
	    if (split)
	    {

	        Ux [p] = REAL_COMPONENT (D [col]) ;
		Uz [p] = IMAG_COMPONENT (D [col]) ;
	    }
	    else
	    {
		Ux [2*p  ] = REAL_COMPONENT (D [col]) ;
		Ux [2*p+1] = IMAG_COMPONENT (D [col]) ;
	    }
#else
	    Ux [p] = D [col] ;
#endif
	}
    }

    /* add all the entries from the rows of U */

    deg = Numeric->ulen ;
    if (deg > 0)
    {
	/* make last pivot row of U (singular matrices only) */
	for (j = 0 ; j < deg ; j++)
	{
	    Pattern [j] = Numeric->Upattern [j] ;
	}
    }

    /* non-singletons */
    for (k = npiv-1 ; k >= n1 ; k--)
    {

	/* ------------------------------------------------------------------ */
	/* use row k of U */
	/* ------------------------------------------------------------------ */

	up = Uip [k] ;
	ulen = Uilen [k] ;
	newUchain = (up < 0) ;
	if (newUchain)
	{
	    up = -up ;
	    xp = (Entry *) (Numeric->Memory + up + UNITS (Int, ulen)) ;
	}
	else
	{
	    xp = (Entry *) (Numeric->Memory + up) ;
	}

	xp += deg ;
	for (j = deg-1 ; j >= 0 ; j--)
	{
	    DEBUG4 (("  k "ID" col "ID" value", k, Pattern [j])) ;
	    col = Pattern [j] ;
	    ASSERT (col >= 0 && col < n_col) ;
	    value = *(--xp) ;
	    EDEBUG4 (value) ;
	    DEBUG4 (("\n")) ;
	    if (IS_NONZERO (value))
	    {
		p = --(Wi [col]) ;
		Ui [p] = k ;
#ifdef COMPLEX
		if (split)
		{
		    Ux [p] = REAL_COMPONENT (value) ;
		    Uz [p] = IMAG_COMPONENT (value) ;
		}
		else
		{
		    Ux [2*p  ] = REAL_COMPONENT (value) ;
		    Ux [2*p+1] = IMAG_COMPONENT (value) ;
		}
#else
		Ux [p] = value ;
#endif

	    }
	}

	/* ------------------------------------------------------------------ */
	/* make row k-1 of U in Pattern [0..deg-1] */
	/* ------------------------------------------------------------------ */

	if (newUchain)
	{
	    /* next row is a new Uchain */
	    deg = ulen ;
	    DEBUG4 (("end of chain for row of U "ID" deg "ID"\n", k-1, deg)) ;
	    ip = (Int *) (Numeric->Memory + up) ;
	    for (j = 0 ; j < deg ; j++)
	    {
		col = *ip++ ;
		DEBUG4 (("  k "ID" col "ID"\n", k-1, col)) ;
		ASSERT (k <= col) ;
		Pattern [j] = col ;
	    }
	}
	else
	{
	    deg -= ulen ;
	    DEBUG4 (("middle of chain for row of U "ID" deg "ID"\n", k-1, deg));
	    ASSERT (deg >= 0) ;
	    pos = Upos [k] ;
	    if (pos != EMPTY)
	    {
		/* add the pivot column */
		DEBUG4 (("k "ID" add pivot entry at position "ID"\n", k, pos)) ;
		ASSERT (pos >= 0 && pos <= deg) ;
		Pattern [deg++] = Pattern [pos] ;
		Pattern [pos] = k ;
	    }
	}
    }

    /* singletons */
    for (k = n1 - 1 ; k >= 0 ; k--)
    {
	deg = Uilen [k] ;
	DEBUG4 (("Singleton k "ID"\n", k)) ;
	if (deg > 0)
	{
	    up = Uip [k] ;
	    Usi = (Int *) (Numeric->Memory + up) ;
	    up += UNITS (Int, deg) ;
	    Uval = (Entry *) (Numeric->Memory + up) ;
	    for (j = 0 ; j < deg ; j++)
	    {
		col = Usi [j] ;
		value = Uval [j] ;
		DEBUG4 (("  k "ID" col "ID" value", k, col)) ;
		EDEBUG4 (value) ;
		DEBUG4 (("\n")) ;
		if (IS_NONZERO (value))
		{
		    p = --(Wi [col]) ;
		    Ui [p] = k ;
#ifdef COMPLEX
		    if (split)
		    {
			Ux [p] = REAL_COMPONENT (value) ;
			Uz [p] = IMAG_COMPONENT (value) ;
		    }
		    else
		    {
			Ux [2*p  ] = REAL_COMPONENT (value) ;
			Ux [2*p+1] = IMAG_COMPONENT (value) ;
		    }
#else
		    Ux [p] = value ;
#endif
		}
	    }
	}
    }

#ifndef NDEBUG
    DEBUG6 (("U matrix:")) ;
    UMF_dump_col_matrix (Ux,
#ifdef COMPLEX
	Uz,
#endif
	Ui, Up, Numeric->n_row, n_col, Numeric->unz + Numeric->nnzpiv) ;
#endif

}
コード例 #8
0
ファイル: umfpack_get_numeric.c プロジェクト: rforge/matrix
PRIVATE void get_L
(
    Int Lp [ ],		/* of size n_row+1 */
    Int Lj [ ],		/* of size lnz, where lnz = Lp [n_row] */
    double Lx [ ],	/* of size lnz */
#ifdef COMPLEX
    double Lz [ ],	/* of size lnz */
#endif
    NumericType *Numeric,
    Int Pattern [ ],	/* workspace of size n_row */
    Int Wi [ ]		/* workspace of size n_row */
)
{
    /* ---------------------------------------------------------------------- */
    /* local variables */
    /* ---------------------------------------------------------------------- */

    Entry value ;
    Entry *xp, *Lval ;
    Int deg, *ip, j, row, n_row, n_col, n_inner, *Lpos, *Lilen, *Lip, p, llen,
        lnz2, lp, newLchain, k, pos, npiv, *Li, n1 ;
#ifdef COMPLEX
    Int split = SPLIT (Lz) ;
#endif

    /* ---------------------------------------------------------------------- */
    /* get parameters */
    /* ---------------------------------------------------------------------- */

    DEBUG4 (("get_L start:\n")) ;
    n_row = Numeric->n_row ;
    n_col = Numeric->n_col ;
    n_inner = MIN (n_row, n_col) ;
    npiv = Numeric->npiv ;
    n1 = Numeric->n1 ;
    Lpos = Numeric->Lpos ;
    Lilen = Numeric->Lilen ;
    Lip = Numeric->Lip ;
    deg = 0 ;

    /* ---------------------------------------------------------------------- */
    /* count the nonzeros in each row of L */
    /* ---------------------------------------------------------------------- */

#pragma ivdep
    for (row = 0 ; row < n_inner ; row++)
    {
	/* include the diagonal entry in the row counts */
	Wi [row] = 1 ;
    }
#pragma ivdep
    for (row = n_inner ; row < n_row ; row++)
    {
	Wi [row] = 0 ;
    }

    /* singletons */
    for (k = 0 ; k < n1 ; k++)
    {
	DEBUG4 (("Singleton k "ID"\n", k)) ;
	deg = Lilen [k] ;
	if (deg > 0)
	{
	    lp = Lip [k] ;
	    Li = (Int *) (Numeric->Memory + lp) ;
	    lp += UNITS (Int, deg) ;
	    Lval = (Entry *) (Numeric->Memory + lp) ;
	    for (j = 0 ; j < deg ; j++)
	    {
		row = Li [j] ;
		value = Lval [j] ;
		DEBUG4 (("  row "ID"  k "ID" value", row, k)) ;
		EDEBUG4 (value) ;
		DEBUG4 (("\n")) ;
		if (IS_NONZERO (value))
		{
		    Wi [row]++ ;
		}
	    }
	}
    }

    /* non-singletons */
    for (k = n1 ; k < npiv ; k++)
    {

	/* ------------------------------------------------------------------ */
	/* make column of L in Pattern [0..deg-1] */
	/* ------------------------------------------------------------------ */

	lp = Lip [k] ;
	newLchain = (lp < 0) ;
	if (newLchain)
	{
	    lp = -lp ;
	    deg = 0 ;
	    DEBUG4 (("start of chain for column of L\n")) ;
	}

	/* remove pivot row */
	pos = Lpos [k] ;
	if (pos != EMPTY)
	{
	    DEBUG4 (("  k "ID" removing row "ID" at position "ID"\n",
	    k, Pattern [pos], pos)) ;
	    ASSERT (!newLchain) ;
	    ASSERT (deg > 0) ;
	    ASSERT (pos >= 0 && pos < deg) ;
	    ASSERT (Pattern [pos] == k) ;
	    Pattern [pos] = Pattern [--deg] ;
	}

	/* concatenate the pattern */
	ip = (Int *) (Numeric->Memory + lp) ;
	llen = Lilen [k] ;
	for (j = 0 ; j < llen ; j++)
	{
	    row = *ip++ ;
	    DEBUG4 (("  row "ID"  k "ID"\n", row, k)) ;
	    ASSERT (row > k && row < n_row) ;
	    Pattern [deg++] = row ;
	}

	xp = (Entry *) (Numeric->Memory + lp + UNITS (Int, llen)) ;

	for (j = 0 ; j < deg ; j++)
	{
	    DEBUG4 (("  row "ID"  k "ID" value", Pattern [j], k)) ;
	    row = Pattern [j] ;
	    value = *xp++ ;
	    EDEBUG4 (value) ;
	    DEBUG4 (("\n")) ;
	    if (IS_NONZERO (value))
	    {
		Wi [row]++ ;
	    }
	}
    }

    /* ---------------------------------------------------------------------- */
    /* construct the final row form of L */
    /* ---------------------------------------------------------------------- */

    /* create the row pointers */
    lnz2 = 0 ;
    for (row = 0 ; row < n_row ; row++)
    {
	Lp [row] = lnz2 ;
	lnz2 += Wi [row] ;
	Wi [row] = Lp [row] ;
    }
    Lp [n_row] = lnz2 ;
    ASSERT (Numeric->lnz + n_inner == lnz2) ;

    /* add entries from the rows of L (singletons) */
    for (k = 0 ; k < n1 ; k++)
    {
	DEBUG4 (("Singleton k "ID"\n", k)) ;
	deg = Lilen [k] ;
	if (deg > 0)
	{
	    lp = Lip [k] ;
	    Li = (Int *) (Numeric->Memory + lp) ;
	    lp += UNITS (Int, deg) ;
	    Lval = (Entry *) (Numeric->Memory + lp) ;
	    for (j = 0 ; j < deg ; j++)
	    {
		row = Li [j] ;
		value = Lval [j] ;
		DEBUG4 (("  row "ID"  k "ID" value", row, k)) ;
		EDEBUG4 (value) ;
		DEBUG4 (("\n")) ;
		if (IS_NONZERO (value))
		{
		    p = Wi [row]++ ;
		    Lj [p] = k ;
#ifdef COMPLEX
		    if (split)
		    {

		        Lx [p] = REAL_COMPONENT (value) ;
			Lz [p] = IMAG_COMPONENT (value) ;
		    }
		    else
		    {
			Lx [2*p  ] = REAL_COMPONENT (value) ;
			Lx [2*p+1] = IMAG_COMPONENT (value) ;
		    }
#else
		    Lx [p] = value ;
#endif
		}
	    }
	}
    }

    /* add entries from the rows of L (non-singletons) */
    for (k = n1 ; k < npiv ; k++)
    {

	/* ------------------------------------------------------------------ */
	/* make column of L in Pattern [0..deg-1] */
	/* ------------------------------------------------------------------ */

	lp = Lip [k] ;
	newLchain = (lp < 0) ;
	if (newLchain)
	{
	    lp = -lp ;
	    deg = 0 ;
	    DEBUG4 (("start of chain for column of L\n")) ;
	}

	/* remove pivot row */
	pos = Lpos [k] ;
	if (pos != EMPTY)
	{
	    DEBUG4 (("  k "ID" removing row "ID" at position "ID"\n",
	    k, Pattern [pos], pos)) ;
	    ASSERT (!newLchain) ;
	    ASSERT (deg > 0) ;
	    ASSERT (pos >= 0 && pos < deg) ;
	    ASSERT (Pattern [pos] == k) ;
	    Pattern [pos] = Pattern [--deg] ;
	}

	/* concatenate the pattern */
	ip = (Int *) (Numeric->Memory + lp) ;
	llen = Lilen [k] ;
	for (j = 0 ; j < llen ; j++)
	{
	    row = *ip++ ;
	    DEBUG4 (("  row "ID"  k "ID"\n", row, k)) ;
	    ASSERT (row > k) ;
	    Pattern [deg++] = row ;
	}

	xp = (Entry *) (Numeric->Memory + lp + UNITS (Int, llen)) ;

	for (j = 0 ; j < deg ; j++)
	{
	    DEBUG4 (("  row "ID"  k "ID" value", Pattern [j], k)) ;
	    row = Pattern [j] ;
	    value = *xp++ ;
	    EDEBUG4 (value) ;
	    DEBUG4 (("\n")) ;
	    if (IS_NONZERO (value))
	    {
		p = Wi [row]++ ;
		Lj [p] = k ;
#ifdef COMPLEX
		if (split)
		{
		    Lx [p] = REAL_COMPONENT (value) ;
		    Lz [p] = IMAG_COMPONENT (value) ;
		}
		else
		{
		    Lx [2*p  ] = REAL_COMPONENT (value) ;
		    Lx [2*p+1] = IMAG_COMPONENT (value) ;
		}
#else
		Lx [p] = value ;
#endif
	    }
	}
    }

    /* add all of the diagonal entries (L is unit diagonal) */
    for (row = 0 ; row < n_inner ; row++)
    {
	p = Wi [row]++ ;
	Lj [p] = row ;

#ifdef COMPLEX
	if (split)
	{
	    Lx [p] = 1. ;
	    Lz [p] = 0. ;
	}
	else
	{
	    Lx [2*p  ] = 1. ;
	    Lx [2*p+1] = 0. ;
	}
#else
	Lx [p] = 1. ;
#endif

	ASSERT (Wi [row] == Lp [row+1]) ;
    }

#ifndef NDEBUG
    DEBUG6 (("L matrix (stored by rows):")) ;
    UMF_dump_col_matrix (Lx,
#ifdef COMPLEX
	Lz,
#endif
	Lj, Lp, n_inner, n_row, Numeric->lnz+n_inner) ;
#endif

    DEBUG4 (("get_L done:\n")) ;
}
コード例 #9
0
ファイル: umf_uhsolve.c プロジェクト: r35krag0th/pysparse
GLOBAL double
#ifdef CONJUGATE_SOLVE
UMF_uhsolve			/* solve U'x=b  (complex conjugate transpose) */
#else
UMF_utsolve			/* solve U.'x=b (array transpose) */
#endif
(
    NumericType *Numeric,
    Entry X [ ],		/* b on input, solution x on output */
    Int Pattern [ ]		/* a work array of size n */
)
{
    /* ---------------------------------------------------------------------- */
    /* local variables */
    /* ---------------------------------------------------------------------- */

    Int k, deg, j, *ip, col, *Upos, *Uilen, kstart, kend, up,
	*Uip, n, uhead, ulen, pos, npiv, n1, *Ui ;
    Entry *xp, xk, *D, *Uval ;

    /* ---------------------------------------------------------------------- */
    /* get parameters */
    /* ---------------------------------------------------------------------- */

    if (Numeric->n_row != Numeric->n_col) return (0.) ;
    n = Numeric->n_row ;
    npiv = Numeric->npiv ;
    Upos = Numeric->Upos ;
    Uilen = Numeric->Uilen ;
    Uip = Numeric->Uip ;
    D = Numeric->D ;
    kend = 0 ;
    n1 = Numeric->n1 ;

#ifndef NDEBUG
    DEBUG4 (("Utsolve start: npiv "ID" n "ID"\n", npiv, n)) ;
    for (j = 0 ; j < n ; j++)
    {
	DEBUG4 (("Utsolve start "ID": ", j)) ;
	EDEBUG4 (X [j]) ;
	DEBUG4 (("\n")) ;
    }
#endif

    /* ---------------------------------------------------------------------- */
    /* singletons */
    /* ---------------------------------------------------------------------- */

    for (k = 0 ; k < n1 ; k++)
    {
	DEBUG4 (("Singleton k "ID"\n", k)) ;
	/* Go ahead and divide by zero if D [k] is zero. */
#ifdef CONJUGATE_SOLVE
	/* xk = X [k] / conjugate (D [k]) ; */
	DIV_CONJ (xk, X [k], D [k]) ;
#else
	/* xk = X [k] / D [k] ; */
	DIV (xk, X [k], D [k]) ;
#endif
	X [k] = xk ;
	deg = Uilen [k] ;
	if (deg > 0 && IS_NONZERO (xk))
	{
	    up = Uip [k] ;
	    Ui = (Int *) (Numeric->Memory + up) ;
	    up += UNITS (Int, deg) ;
	    Uval = (Entry *) (Numeric->Memory + up) ;
	    for (j = 0 ; j < deg ; j++)
	    {
		DEBUG4 (("  k "ID" col "ID" value", k, Ui [j])) ;
		EDEBUG4 (Uval [j]) ;
		DEBUG4 (("\n")) ;
#ifdef CONJUGATE_SOLVE
		/* X [Ui [j]] -= xk * conjugate (Uval [j]) ; */
		MULT_SUB_CONJ (X [Ui [j]], xk, Uval [j]) ;
#else
		/* X [Ui [j]] -= xk * Uval [j] ; */
		MULT_SUB (X [Ui [j]], xk, Uval [j]) ;
#endif
	    }
	}
    }

    /* ---------------------------------------------------------------------- */
    /* nonsingletons */
    /* ---------------------------------------------------------------------- */

    for (kstart = n1 ; kstart < npiv ; kstart = kend + 1)
    {

	/* ------------------------------------------------------------------ */
	/* find the end of this Uchain */
	/* ------------------------------------------------------------------ */

	DEBUG4 (("kstart "ID" kend "ID"\n", kstart, kend)) ;
	/* for (kend = kstart ; kend < npiv && Uip [kend+1] > 0 ; kend++) ; */
	kend = kstart ;
	while (kend < npiv && Uip [kend+1] > 0)
	{
	    kend++ ;
	}

	/* ------------------------------------------------------------------ */
	/* scan the whole Uchain to find the pattern of the first row of U */
	/* ------------------------------------------------------------------ */

	k = kend+1 ;
	DEBUG4 (("\nKend "ID" K "ID"\n", kend, k)) ;

	/* ------------------------------------------------------------------ */
	/* start with last row in Uchain of U in Pattern [0..deg-1] */
	/* ------------------------------------------------------------------ */

	if (k == npiv)
	{
	    deg = Numeric->ulen ;
	    if (deg > 0)
	    {
		/* :: make last pivot row of U (singular matrices only) :: */
		for (j = 0 ; j < deg ; j++)
		{
		    Pattern [j] = Numeric->Upattern [j] ;
		}
	    }
	}
	else
	{
	    ASSERT (k >= 0 && k < npiv) ;
	    up = -Uip [k] ;
	    ASSERT (up > 0) ;
	    deg = Uilen [k] ;
	    DEBUG4 (("end of chain for row of U "ID" deg "ID"\n", k-1, deg)) ;
	    ip = (Int *) (Numeric->Memory + up) ;
	    for (j = 0 ; j < deg ; j++)
	    {
		col = *ip++ ;
		DEBUG4 (("  k "ID" col "ID"\n", k-1, col)) ;
		ASSERT (k <= col) ;
		Pattern [j] = col ;
	    }
	}

	/* empty the stack at the bottom of Pattern */
	uhead = n ;

	for (k = kend ; k > kstart ; k--)
	{
	    /* Pattern [0..deg-1] is the pattern of row k of U */

	    /* -------------------------------------------------------------- */
	    /* make row k-1 of U in Pattern [0..deg-1] */
	    /* -------------------------------------------------------------- */

	    ASSERT (k >= 0 && k < npiv) ;
	    ulen = Uilen [k] ;
	    /* delete, and push on the stack */
	    for (j = 0 ; j < ulen ; j++)
	    {
		ASSERT (uhead >= deg) ;
		Pattern [--uhead] = Pattern [--deg] ;
	    }
	    DEBUG4 (("middle of chain for row of U "ID" deg "ID"\n", k, deg)) ;
	    ASSERT (deg >= 0) ;

	    pos = Upos [k] ;
	    if (pos != EMPTY)
	    {
		/* add the pivot column */
		DEBUG4 (("k "ID" add pivot entry at position "ID"\n", k, pos)) ;
		ASSERT (pos >= 0 && pos <= deg) ;
		Pattern [deg++] = Pattern [pos] ;
		Pattern [pos] = k ;
	    }
	}

	/* Pattern [0..deg-1] is now the pattern of the first row in Uchain */

	/* ------------------------------------------------------------------ */
	/* solve using this Uchain, in reverse order */
	/* ------------------------------------------------------------------ */

	DEBUG4 (("Unwinding Uchain\n")) ;
	for (k = kstart ; k <= kend ; k++)
	{

	    /* -------------------------------------------------------------- */
	    /* construct row k */
	    /* -------------------------------------------------------------- */

	    ASSERT (k >= 0 && k < npiv) ;
	    pos = Upos [k] ;
	    if (pos != EMPTY)
	    {
		/* remove the pivot column */
		DEBUG4 (("k "ID" add pivot entry at position "ID"\n", k, pos)) ;
		ASSERT (k > kstart) ;
		ASSERT (pos >= 0 && pos < deg) ;
		ASSERT (Pattern [pos] == k) ;
		Pattern [pos] = Pattern [--deg] ;
	    }

	    up = Uip [k] ;
	    ulen = Uilen [k] ;
	    if (k > kstart)
	    {
		/* concatenate the deleted pattern; pop from the stack */
		for (j = 0 ; j < ulen ; j++)
		{
		    ASSERT (deg <= uhead && uhead < n) ;
		    Pattern [deg++] = Pattern [uhead++] ;
		}
		DEBUG4 (("middle of chain, row of U "ID" deg "ID"\n", k, deg)) ;
		ASSERT (deg >= 0) ;
	    }

	    /* -------------------------------------------------------------- */
	    /* use row k of U */
	    /* -------------------------------------------------------------- */

	    /* Go ahead and divide by zero if D [k] is zero. */
#ifdef CONJUGATE_SOLVE
	    /* xk = X [k] / conjugate (D [k]) ; */
	    DIV_CONJ (xk, X [k], D [k]) ;
#else
	    /* xk = X [k] / D [k] ; */
	    DIV (xk, X [k], D [k]) ;
#endif
	    X [k] = xk ;
	    if (IS_NONZERO (xk))
	    {
		if (k == kstart)
		{
		    up = -up ;
		    xp = (Entry *) (Numeric->Memory + up + UNITS (Int, ulen)) ;
		}
		else
		{
		    xp = (Entry *) (Numeric->Memory + up) ;
		}
		for (j = 0 ; j < deg ; j++)
		{
		    DEBUG4 (("  k "ID" col "ID" value", k, Pattern [j])) ;
		    EDEBUG4 (*xp) ;
		    DEBUG4 (("\n")) ;
#ifdef CONJUGATE_SOLVE
		    /* X [Pattern [j]] -= xk * conjugate (*xp) ; */
		    MULT_SUB_CONJ (X [Pattern [j]], xk, *xp) ;
#else
		    /* X [Pattern [j]] -= xk * (*xp) ; */
		    MULT_SUB (X [Pattern [j]], xk, *xp) ;
#endif
		    xp++ ;
		}
	    }
	}
	ASSERT (uhead == n) ;
    }

    for (k = npiv ; k < n ; k++)
    {
	/* This is an *** intentional *** divide-by-zero, to get Inf or Nan,
	 * as appropriate.  It is not a bug. */
	ASSERT (IS_ZERO (D [k])) ;
	/* For conjugate solve, D [k] == conjugate (D [k]), in this case */
	/* xk = X [k] / D [k] ; */
	DIV (xk, X [k], D [k]) ;
	X [k] = xk ;
    }

#ifndef NDEBUG
    for (j = 0 ; j < n ; j++)
    {
	DEBUG4 (("Utsolve done "ID": ", j)) ;
	EDEBUG4 (X [j]) ;
	DEBUG4 (("\n")) ;
    }
    DEBUG4 (("Utsolve done.\n")) ;
#endif

    return (DIV_FLOPS * ((double) n) + MULTSUB_FLOPS * ((double) Numeric->unz));
}
コード例 #10
0
ファイル: umf_lsolve.c プロジェクト: Ascronia/fieldtrip
GLOBAL double UMF_lsolve
(
    NumericType *Numeric,
    Entry X [ ],		/* b on input, solution x on output */
    Int Pattern [ ]		/* a work array of size n */
)
{
    Entry xk ;
    Entry *xp, *Lval ;
    Int k, deg, *ip, j, row, *Lpos, *Lilen, *Lip, llen, lp, newLchain,
	pos, npiv, n1, *Li ;

    /* ---------------------------------------------------------------------- */

    if (Numeric->n_row != Numeric->n_col) return (0.) ;
    npiv = Numeric->npiv ;
    Lpos = Numeric->Lpos ;
    Lilen = Numeric->Lilen ;
    Lip = Numeric->Lip ;
    n1 = Numeric->n1 ;

#ifndef NDEBUG
    DEBUG4 (("Lsolve start:\n")) ;
    for (j = 0 ; j < Numeric->n_row ; j++)
    {
	DEBUG4 (("Lsolve start "ID": ", j)) ;
	EDEBUG4 (X [j]) ;
	DEBUG4 (("\n")) ;
    }
#endif

    /* ---------------------------------------------------------------------- */
    /* singletons */
    /* ---------------------------------------------------------------------- */

    for (k = 0 ; k < n1 ; k++)
    {
	DEBUG4 (("Singleton k "ID"\n", k)) ;
	xk = X [k] ;
	deg = Lilen [k] ;
	if (deg > 0 && IS_NONZERO (xk))
	{
	    lp = Lip [k] ;
	    Li = (Int *) (Numeric->Memory + lp) ;
	    lp += UNITS (Int, deg) ;
	    Lval = (Entry *) (Numeric->Memory + lp) ;
	    for (j = 0 ; j < deg ; j++)
	    {
		DEBUG4 (("  row "ID"  k "ID" value", Li [j], k)) ;
		EDEBUG4 (Lval [j]) ;
		DEBUG4 (("\n")) ;
		/* X [Li [j]] -= xk * Lval [j] ; */
		MULT_SUB (X [Li [j]], xk, Lval [j]) ;
	    }
	}
    }

    /* ---------------------------------------------------------------------- */
    /* rest of L */
    /* ---------------------------------------------------------------------- */

    deg = 0 ;

    for (k = n1 ; k < npiv ; k++)
    {

	/* ------------------------------------------------------------------ */
	/* make column of L in Pattern [0..deg-1] */
	/* ------------------------------------------------------------------ */

	lp = Lip [k] ;
	newLchain = (lp < 0) ;
	if (newLchain)
	{
	    lp = -lp ;
	    deg = 0 ;
	    DEBUG4 (("start of chain for column of L\n")) ;
	}

	/* remove pivot row */
	pos = Lpos [k] ;
	if (pos != EMPTY)
	{
	    DEBUG4 (("  k "ID" removing row "ID" at position "ID"\n",
	    k, Pattern [pos], pos)) ;
	    ASSERT (!newLchain) ;
	    ASSERT (deg > 0) ;
	    ASSERT (pos >= 0 && pos < deg) ;
	    ASSERT (Pattern [pos] == k) ;
	    Pattern [pos] = Pattern [--deg] ;
	}

	/* concatenate the pattern */
	ip = (Int *) (Numeric->Memory + lp) ;
	llen = Lilen [k] ;
	for (j = 0 ; j < llen ; j++)
	{
	    row = *ip++ ;
	    DEBUG4 (("  row "ID"  k "ID"\n", row, k)) ;
	    ASSERT (row > k) ;
	    Pattern [deg++] = row ;
	}

	/* ------------------------------------------------------------------ */
	/* use column k of L */
	/* ------------------------------------------------------------------ */

	xk = X [k] ;
	if (IS_NONZERO (xk))
	{
	    xp = (Entry *) (Numeric->Memory + lp + UNITS (Int, llen)) ;
	    for (j = 0 ; j < deg ; j++)
	    {
		DEBUG4 (("  row "ID"  k "ID" value", Pattern [j], k)) ;
		EDEBUG4 (*xp) ;
		DEBUG4 (("\n")) ;
		/* X [Pattern [j]] -= xk * (*xp) ; */
		MULT_SUB (X [Pattern [j]], xk, *xp) ;
		xp++ ;
	    }
	}
    }

#ifndef NDEBUG
    for (j = 0 ; j < Numeric->n_row ; j++)
    {
	DEBUG4 (("Lsolve done "ID": ", j)) ;
	EDEBUG4 (X [j]) ;
	DEBUG4 (("\n")) ;
    }
    DEBUG4 (("Lsolve done.\n")) ;
#endif

    return (MULTSUB_FLOPS * ((double) Numeric->lnz)) ;
}