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) ; }
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) ; }
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)) ; }
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) ; } } }
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)); }
unsigned int is_nonzero_uint(unsigned int val) { return IS_NONZERO(val); }
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 }
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")) ; }
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)); }
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)) ; }