PRIVATE void dump_singletons
(
Int head, /* head of the queue */
Int tail, /* tail of the queue */
Int Next [ ], /* Next [i] is the next object after i */
char *name, /* "row" or "col" */
Int Deg [ ], /* Deg [i] is the degree of object i */
Int n /* objects are in the range 0 to n-1 */
)
{
Int i, next, cnt ;
DEBUG6 (("%s Singleton list: head "ID" tail "ID"\n", name, head, tail)) ;
i = head ;
ASSERT (head >= EMPTY && head < n) ;
ASSERT (tail >= EMPTY && tail < n) ;
cnt = 0 ;
while (i != EMPTY)
{
DEBUG7 ((" "ID": "ID" deg: "ID"\n", cnt, i, Deg [i])) ;
ASSERT (i >= 0 && i < n) ;
next = Next [i] ;
if (i == tail) ASSERT (next == EMPTY) ;
i = next ;
cnt++ ;
ASSERT (cnt <= n) ;
}
}
// ---------------------------------------------------------------------------
// ---------------------------------------------------------------------------
//
void core_scan_list_c::remove_entries_by_age(
u32_t age )
{
DEBUG1( "core_scan_list_c::remove_entries_by_age() - removing entries older than %u microsecond(s)",
age );
u64_t timestamp(
core_am_tools_c::timestamp() );
core_type_list_iterator_c<core_scan_list_entry_s> iter( scan_list_m );
for( core_scan_list_entry_s* current = iter.first(); current; current = iter.next() )
{
if ( static_cast<u32_t>( timestamp - current->timestamp ) > age )
{
#ifdef _DEBUG
core_mac_address_s bssid(
current->ap_data->bssid() );
DEBUG7( "core_scan_list_c::remove_entries_by_age() - BSSID %02X:%02X:%02X:%02X:%02X:%02X [%u second(s)] removed",
bssid.addr[0], bssid.addr[1], bssid.addr[2],
bssid.addr[3], bssid.addr[4], bssid.addr[5],
static_cast<u32_t>( timestamp - current->timestamp ) / SECONDS_FROM_MICROSECONDS );
#endif // _DEBUG
iter.remove();
delete current->ap_data;
delete current;
current = NULL;
}
}
}
PRIVATE void dump_mat
(
char *xname,
char *yname,
Int nx,
Int ny,
const Int Xp [ ],
const Int Xi [ ],
Int Xdeg [ ],
Int Ydeg [ ]
)
{
Int x, y, p, p1, p2, xdeg, do_xdeg, ydeg ;
DEBUG6 (("\n ==== Dump %s mat:\n", xname)) ;
for (x = 0 ; x < nx ; x++)
{
p1 = Xp [x] ;
p2 = Xp [x+1] ;
xdeg = Xdeg [x] ;
DEBUG6 (("Dump %s "ID" p1 "ID" p2 "ID" deg "ID"\n",
xname, x, p1, p2, xdeg)) ;
do_xdeg = (xdeg >= 0) ;
for (p = p1 ; p < p2 ; p++)
{
y = Xi [p] ;
DEBUG7 ((" %s "ID" deg: ", yname, y)) ;
ASSERT (y >= 0 && y < ny) ;
ydeg = Ydeg [y] ;
DEBUG7 ((ID"\n", ydeg)) ;
if (do_xdeg && ydeg >= 0)
{
xdeg-- ;
}
}
ASSERT (IMPLIES (do_xdeg, xdeg == 0)) ;
}
}
GLOBAL void UMF_garbage_collection
(
NumericType *Numeric,
WorkType *Work,
Int drnew, /* compact current front to drnew-by-dcnew */
Int dcnew,
Int do_Fcpos
)
{
/* ---------------------------------------------------------------------- */
/* local variables */
/* ---------------------------------------------------------------------- */
Int size, e, n_row, n_col, nrows, ncols, nrowsleft, ncolsleft, prevsize,
csize, size2, i2, j2, i, j, cdeg, rdeg, *E, row, col,
*Rows, *Cols, *Rows2, *Cols2, nel, e2, *Row_tuples, *Col_tuples,
*Row_degree, *Col_degree ;
Entry *C, *C1, *C3, *C2 ;
Unit *psrc, *pdest, *p, *pnext ;
Element *epsrc, *epdest ;
#ifndef NDEBUG
Int nmark ;
#endif
/* ---------------------------------------------------------------------- */
/* get parameters */
/* ---------------------------------------------------------------------- */
Col_degree = Numeric->Cperm ; /* for NON_PIVOTAL_COL macro */
Row_degree = Numeric->Rperm ; /* for NON_PIVOTAL_ROW macro */
Row_tuples = Numeric->Uip ;
Col_tuples = Numeric->Lip ;
E = Work->E ;
n_row = Work->n_row ;
n_col = Work->n_col ;
/* note that the tuple lengths (Col_tlen and Row_tlen) are updated, but */
/* the tuple lists themselves are stale and are about to be destroyed */
/* and recreated. Do not attempt to scan them until they are recreated. */
#ifndef NDEBUG
DEBUGm1 (("::::GARBAGE COLLECTION::::\n")) ;
UMF_dump_memory (Numeric) ;
#endif
Numeric->ngarbage++ ;
/* ---------------------------------------------------------------------- */
/* delete the tuple lists by marking the blocks as free */
/* ---------------------------------------------------------------------- */
/* do not modify Row_tlen and Col_tlen */
/* those are needed for UMF_build_tuples */
for (row = 0 ; row < n_row ; row++)
{
if (NON_PIVOTAL_ROW (row) && Row_tuples [row])
{
DEBUG2 (("row "ID" tuples "ID"\n", row, Row_tuples [row])) ;
p = Numeric->Memory + Row_tuples [row] - 1 ;
DEBUG2 (("Freeing tuple list row "ID", p-S "ID", size "ID"\n",
row, (Int) (p-Numeric->Memory), p->header.size)) ;
ASSERT (p->header.size > 0) ;
ASSERT (p >= Numeric->Memory + Numeric->itail) ;
ASSERT (p < Numeric->Memory + Numeric->size) ;
p->header.size = -p->header.size ;
Row_tuples [row] = 0 ;
}
}
for (col = 0 ; col < n_col ; col++)
{
if (NON_PIVOTAL_COL (col) && Col_tuples [col])
{
DEBUG2 (("col "ID" tuples "ID"\n", col, Col_tuples [col])) ;
p = Numeric->Memory + Col_tuples [col] - 1 ;
DEBUG2 (("Freeing tuple list col "ID", p-S "ID", size "ID"\n",
col, (Int) (p-Numeric->Memory), p->header.size)) ;
ASSERT (p->header.size > 0) ;
ASSERT (p >= Numeric->Memory + Numeric->itail) ;
ASSERT (p < Numeric->Memory + Numeric->size) ;
p->header.size = -p->header.size ;
Col_tuples [col] = 0 ;
}
}
/* ---------------------------------------------------------------------- */
/* mark the elements, and compress the name space */
/* ---------------------------------------------------------------------- */
nel = Work->nel ;
ASSERT (nel < Work->elen) ;
#ifndef NDEBUG
nmark = 0 ;
UMF_dump_current_front (Numeric, Work, FALSE) ;
DEBUGm1 (("E [0] "ID" \n", E [0])) ;
ASSERT (IMPLIES (E [0],
Work->Flublock == (Entry *) (Numeric->Memory + E [0]))) ;
ASSERT (IMPLIES (Work->Flublock,
Work->Flublock == (Entry *) (Numeric->Memory + E [0]))) ;
ASSERT ((E [0] != 0) == (Work->Flublock != (Entry *) NULL)) ;
#endif
e2 = 0 ;
for (e = 0 ; e <= nel ; e++) /* for all elements in order of creation */
{
if (E [e])
{
psrc = Numeric->Memory + E [e] ;
psrc-- ; /* get the header of this block */
if (e > 0)
{
e2++ ; /* do not renumber element zero */
}
ASSERT (psrc->header.size > 0) ;
psrc->header.size = e2 ; /* store the new name in the header */
#ifndef NDEBUG
nmark++ ;
#endif
DEBUG7 ((ID":: Mark e "ID" at psrc-S "ID", new e "ID"\n",
nmark, e, (Int) (psrc-Numeric->Memory), e2)) ;
E [e] = 0 ;
if (e == Work->prior_element)
{
Work->prior_element = e2 ;
}
}
}
/* all 1..e2 are now in use (element zero may or may not be in use) */
Work->nel = e2 ;
nel = Work->nel ;
#ifndef NDEBUG
for (e = 0 ; e < Work->elen ; e++)
{
ASSERT (!E [e]) ;
}
#endif
/* ---------------------------------------------------------------------- */
/* compress the elements */
/* ---------------------------------------------------------------------- */
/* point to tail marker block of size 1 + header */
psrc = Numeric->Memory + Numeric->size - 2 ;
pdest = psrc ;
prevsize = psrc->header.prevsize ;
DEBUG7 (("Starting the compression:\n")) ;
while (prevsize > 0)
{
/* ------------------------------------------------------------------ */
/* move up to the next element above the current header, and */
/* get the element name and size */
/* (if it is an element, the name will be positive) */
/* ------------------------------------------------------------------ */
size = prevsize ;
psrc -= (size + 1) ;
e = psrc->header.size ;
prevsize = psrc->header.prevsize ;
/* top block at tail has prevsize of 0 */
/* a free block will have a negative size, so skip it */
/* otherwise, if size >= 0, it holds the element name, not the size */
DEBUG8 (("psrc-S: "ID" prevsize: "ID" size: "ID,
(Int) (psrc-Numeric->Memory), prevsize, size)) ;
if (e == 0)
{
/* -------------------------------------------------------------- */
/* this is the current frontal matrix */
/* -------------------------------------------------------------- */
Entry *F1, *F2, *Fsrc, *Fdst ;
Int c, r, k, dr, dc, gap, gap1, gap2, nb ;
/* shift the frontal matrix down */
F1 = (Entry *) (psrc + 1) ;
/* get the size of the current front. r and c could be zero */
k = Work->fnpiv ;
dr = Work->fnr_curr ;
dc = Work->fnc_curr ;
r = Work->fnrows ;
c = Work->fncols ;
nb = Work->nb ;
ASSERT ((dr >= 0 && (dr % 2) == 1) || dr == 0) ;
ASSERT (drnew >= 0) ;
if (drnew % 2 == 0)
{
/* make sure leading frontal matrix dimension is always odd */
drnew++ ;
}
drnew = MIN (dr, drnew) ;
ASSERT ((drnew >= 0 && (drnew % 2) == 1) || drnew == 0) ;
pnext = pdest ;
#ifndef NDEBUG
DEBUGm2 (("move front: dr "ID" dc "ID" r "ID" drnew "ID" c "ID
" dcnew " ID" k "ID"\n", dr, dc, r, drnew, c, dcnew, k)) ;
DEBUG7 (("\n")) ;
DEBUG7 ((ID":: Move current frontal matrix from: psrc-S: "ID" \n",
nmark, (Int) (psrc-Numeric->Memory))) ;
nmark-- ;
ASSERT (E [e] == 0) ;
ASSERT (Work->Flublock == F1) ;
ASSERT (Work->Flblock == Work->Flublock + nb*nb) ;
ASSERT (Work->Fublock == Work->Flblock + dr*nb) ;
ASSERT (Work->Fcblock == Work->Fublock + nb*dc) ;
DEBUG7 (("C block: ")) ;
UMF_dump_dense (Work->Fcblock, dr, r, c) ;
DEBUG7 (("L block: ")) ;
UMF_dump_dense (Work->Flblock, dr, r, k);
DEBUG7 (("U' block: ")) ;
UMF_dump_dense (Work->Fublock, dc, c, k) ;
DEBUG7 (("LU block: ")) ;
UMF_dump_dense (Work->Flublock, nb, k, k) ;
ASSERT (r <= drnew && c <= dcnew && drnew <= dr && dcnew <= dc) ;
#endif
/* compact frontal matrix to drnew-by-dcnew before moving it */
/* do not compact the LU block (nb-by-nb) */
/* compact the columns of L (from dr-by-nb to drnew-by-nb) */
Fsrc = Work->Flblock ;
Fdst = Work->Flblock ;
ASSERT (Fdst == F1 + nb*nb) ;
gap1 = dr - r ;
gap2 = drnew - r ;
ASSERT (gap1 >= 0) ;
for (j = 0 ; j < k ; j++)
{
for (i = 0 ; i < r ; i++)
{
*Fdst++ = *Fsrc++ ;
}
Fsrc += gap1 ;
Fdst += gap2 ;
}
ASSERT (Fdst == F1 + nb*nb + drnew*k) ;
Fdst += drnew * (nb - k) ;
/* compact the rows of U (U' from dc-by-nb to dcnew-by-nb) */
Fsrc = Work->Fublock ;
ASSERT (Fdst == F1 + nb*nb + drnew*nb) ;
gap1 = dc - c ;
gap2 = dcnew - c ;
for (i = 0 ; i < k ; i++)
{
for (j = 0 ; j < c ; j++)
{
*Fdst++ = *Fsrc++ ;
}
Fsrc += gap1 ;
Fdst += gap2 ;
}
ASSERT (Fdst == F1 + nb*nb + drnew*nb + dcnew*k) ;
Fdst += dcnew * (nb - k) ;
/* compact the columns of C (from dr-by-dc to drnew-by-dcnew) */
Fsrc = Work->Fcblock ;
ASSERT (Fdst == F1 + nb*nb + drnew*nb + nb*dcnew) ;
gap1 = dr - r ;
gap2 = drnew - r ;
for (j = 0 ; j < c ; j++)
{
for (i = 0 ; i < r ; i++)
{
*Fdst++ = *Fsrc++ ;
}
Fsrc += gap1 ;
Fdst += gap2 ;
}
ASSERT (Fdst == F1 + nb*nb + drnew*nb + nb*dcnew + drnew*c) ;
/* recompute Fcpos, if necessary */
if (do_Fcpos)
{
Int *Fcols, *Fcpos ;
Fcols = Work->Fcols ;
Fcpos = Work->Fcpos ;
for (j = 0 ; j < c ; j++)
{
col = Fcols [j] ;
ASSERT (col >= 0 && col < Work->n_col) ;
ASSERT (Fcpos [col] == j * dr) ;
Fcpos [col] = j * drnew ;
}
#ifndef NDEBUG
{
Int cnt = 0 ;
for (j = 0 ; j < Work->n_col ; j++)
{
if (Fcpos [j] != EMPTY) cnt++ ;
}
DEBUGm2 (("Recompute Fcpos cnt "ID" c "ID"\n", cnt, c)) ;
ASSERT (cnt == c) ;
}
#endif
}
#ifndef NDEBUG
DEBUGm2 (("Compacted front, drnew "ID" dcnew "ID"\n", drnew, dcnew)) ;
DEBUG7 (("C block: ")) ;
UMF_dump_dense (F1 + nb*nb + drnew*nb + nb*dcnew, drnew, r, c) ;
DEBUG7 (("L block: ")) ;
UMF_dump_dense (F1 + nb*nb, drnew, r, k) ;
DEBUG7 (("U block: ")) ;
UMF_dump_dense (F1 + nb*nb + drnew*nb, nb, k, c) ;
DEBUG7 (("LU block: ")) ;
UMF_dump_dense (F1, nb, k, k) ;
#endif
/* Compacted dimensions of the new frontal matrix. */
Work->fnr_curr = drnew ;
Work->fnc_curr = dcnew ;
Work->fcurr_size = (drnew + nb) * (dcnew + nb) ;
size = UNITS (Entry, Work->fcurr_size) ;
/* make sure the object doesn't evaporate. The front can have
* zero size (Work->fcurr_size = 0), but the size of the memory
* block containing it cannot have zero size. */
size = MAX (1, size) ;
/* get the destination of frontal matrix */
pnext->header.prevsize = size ;
pdest -= (size + 1) ;
F2 = (Entry *) (pdest + 1) ;
ASSERT ((unsigned Int) psrc + 1 + size <= (unsigned Int) pnext) ;
ASSERT (psrc <= pdest) ;
ASSERT (F1 <= F2) ;
/* move the C block first */
Fsrc = F1 + nb*nb + drnew*nb + nb*dcnew + drnew*c ;
Fdst = F2 + nb*nb + drnew*nb + nb*dcnew + drnew*c ;
gap = drnew - r ;
for (j = c-1 ; j >= 0 ; j--)
{
Fsrc -= gap ;
Fdst -= gap ;
/* move column j of C */
for (i = r-1 ; i >= 0 ; i--)
{
*--Fdst = *--Fsrc ;
}
}
ASSERT (Fsrc == F1 + nb*nb + drnew*nb + nb*dcnew) ;
ASSERT (Fdst == F2 + nb*nb + drnew*nb + nb*dcnew) ;
/* move the U block */
Fsrc -= dcnew * (nb - k) ;
Fdst -= dcnew * (nb - k) ;
ASSERT (Fsrc == F1 + nb*nb + drnew*nb + dcnew*k) ;
ASSERT (Fdst == F2 + nb*nb + drnew*nb + dcnew*k) ;
gap = dcnew - c ;
for (i = k-1 ; i >= 0 ; i--)
{
Fsrc -= gap ;
Fdst -= gap ;
for (j = c-1 ; j >= 0 ; j--)
{
*--Fdst = *--Fsrc ;
}
}
ASSERT (Fsrc == F1 + nb*nb + drnew*nb) ;
ASSERT (Fdst == F2 + nb*nb + drnew*nb) ;
/* move the L block */
Fsrc -= drnew * (nb - k) ;
Fdst -= drnew * (nb - k) ;
ASSERT (Fsrc == F1 + nb*nb + drnew*k) ;
ASSERT (Fdst == F2 + nb*nb + drnew*k) ;
gap = drnew - r ;
for (j = k-1 ; j >= 0 ; j--)
{
Fsrc -= gap ;
Fdst -= gap ;
for (i = r-1 ; i >= 0 ; i--)
{
*--Fdst = *--Fsrc ;
}
}
ASSERT (Fsrc == F1 + nb*nb) ;
ASSERT (Fdst == F2 + nb*nb) ;
/* move the LU block */
Fsrc -= nb * (nb - k) ;
Fdst -= nb * (nb - k) ;
ASSERT (Fsrc == F1 + nb*k) ;
ASSERT (Fdst == F2 + nb*k) ;
gap = nb - k ;
for (j = k-1 ; j >= 0 ; j--)
{
Fsrc -= gap ;
Fdst -= gap ;
for (i = k-1 ; i >= 0 ; i--)
{
*--Fdst = *--Fsrc ;
}
}
ASSERT (Fsrc == F1) ;
ASSERT (Fdst == F2) ;
E [0] = (pdest + 1) - Numeric->Memory ;
Work->Flublock = (Entry *) (Numeric->Memory + E [0]) ;
ASSERT (Work->Flublock == F2) ;
Work->Flblock = Work->Flublock + nb * nb ;
Work->Fublock = Work->Flblock + drnew * nb ;
Work->Fcblock = Work->Fublock + nb * dcnew ;
pdest->header.prevsize = 0 ;
pdest->header.size = size ;
#ifndef NDEBUG
DEBUG7 (("After moving compressed current frontal matrix:\n")) ;
DEBUG7 (("C block: ")) ;
UMF_dump_dense (Work->Fcblock, drnew, r, c) ;
DEBUG7 (("L block: ")) ;
UMF_dump_dense (Work->Flblock, drnew, r, k);
DEBUG7 (("U' block: ")) ;
UMF_dump_dense (Work->Fublock, dcnew, c, k) ;
DEBUG7 (("LU block: ")) ;
UMF_dump_dense (Work->Flublock, nb, k, k) ;
#endif
}
else if (e > 0)
{
/* -------------------------------------------------------------- */
/* this is an element, compress and move from psrc down to pdest */
/* -------------------------------------------------------------- */
#ifndef NDEBUG
DEBUG7 (("\n")) ;
DEBUG7 ((ID":: Move element "ID": from: "ID" \n",
nmark, e, (Int) (psrc-Numeric->Memory))) ;
nmark-- ;
ASSERT (e <= nel) ;
ASSERT (E [e] == 0) ;
#endif
/* -------------------------------------------------------------- */
/* get the element scalars, and pointers to C, Rows, and Cols: */
/* -------------------------------------------------------------- */
p = psrc + 1 ;
GET_ELEMENT (epsrc, p, Cols, Rows, ncols, nrows, C) ;
nrowsleft = epsrc->nrowsleft ;
ncolsleft = epsrc->ncolsleft ;
cdeg = epsrc->cdeg ;
rdeg = epsrc->rdeg ;
#ifndef NDEBUG
DEBUG7 ((" nrows "ID" nrowsleft "ID"\n", nrows, nrowsleft)) ;
DEBUG7 ((" ncols "ID" ncolsleft "ID"\n", ncols, ncolsleft)) ;
DEBUG8 ((" Rows:")) ;
for (i = 0 ; i < nrows ; i++) DEBUG8 ((" "ID, Rows [i])) ;
DEBUG8 (("\n Cols:")) ;
for (j = 0 ; j < ncols ; j++) DEBUG8 ((" "ID, Cols [j])) ;
DEBUG8 (("\n")) ;
#endif
/* -------------------------------------------------------------- */
/* determine the layout of the new element */
/* -------------------------------------------------------------- */
csize = nrowsleft * ncolsleft ;
size2 = UNITS (Element, 1)
+ UNITS (Int, nrowsleft + ncolsleft)
+ UNITS (Entry, csize) ;
DEBUG7 (("Old size "ID" New size "ID"\n", size, size2)) ;
pnext = pdest ;
pnext->header.prevsize = size2 ;
pdest -= (size2 + 1) ;
ASSERT (size2 <= size) ;
ASSERT ((unsigned Int) psrc + 1 + size <= (unsigned Int) pnext) ;
ASSERT (psrc <= pdest) ;
p = pdest + 1 ;
epdest = (Element *) p ;
p += UNITS (Element, 1) ;
Cols2 = (Int *) p ;
Rows2 = Cols2 + ncolsleft ;
p += UNITS (Int, nrowsleft + ncolsleft) ;
C2 = (Entry *) p ;
ASSERT (epdest >= epsrc) ;
ASSERT (Rows2 >= Rows) ;
ASSERT (Cols2 >= Cols) ;
ASSERT (C2 >= C) ;
ASSERT (p + UNITS (Entry, csize) == pnext) ;
/* -------------------------------------------------------------- */
/* move the contribution block */
/* -------------------------------------------------------------- */
/* overlap = psrc + size + 1 > pdest ; */
if (nrowsleft < nrows || ncolsleft < ncols)
{
/* ---------------------------------------------------------- */
/* compress contribution block in place prior to moving it */
/* ---------------------------------------------------------- */
DEBUG7 (("Compress C in place prior to move:\n"));
#ifndef NDEBUG
UMF_dump_dense (C, nrows, nrows, ncols) ;
#endif
C1 = C ;
C3 = C ;
for (j = 0 ; j < ncols ; j++)
{
if (Cols [j] >= 0)
{
for (i = 0 ; i < nrows ; i++)
{
if (Rows [i] >= 0)
{
*C3++ = C1 [i] ;
}
}
}
C1 += nrows ;
}
ASSERT (C3-C == csize) ;
DEBUG8 (("Newly compressed contrib. block (all in use):\n")) ;
#ifndef NDEBUG
UMF_dump_dense (C, nrowsleft, nrowsleft, ncolsleft) ;
#endif
}
/* shift the contribution block down */
C += csize ;
C2 += csize ;
for (i = 0 ; i < csize ; i++)
{
*--C2 = *--C ;
}
/* -------------------------------------------------------------- */
/* move the row indices */
/* -------------------------------------------------------------- */
i2 = nrowsleft ;
for (i = nrows - 1 ; i >= 0 ; i--)
{
ASSERT (Rows2+i2 >= Rows+i) ;
if (Rows [i] >= 0)
{
Rows2 [--i2] = Rows [i] ;
}
}
ASSERT (i2 == 0) ;
j2 = ncolsleft ;
for (j = ncols - 1 ; j >= 0 ; j--)
{
ASSERT (Cols2+j2 >= Cols+j) ;
if (Cols [j] >= 0)
{
Cols2 [--j2] = Cols [j] ;
}
}
ASSERT (j2 == 0) ;
/* -------------------------------------------------------------- */
/* construct the new header */
/* -------------------------------------------------------------- */
/* E [0...e] is now valid */
E [e] = (pdest + 1) - Numeric->Memory ;
epdest = (Element *) (pdest + 1) ;
epdest->next = EMPTY ; /* destroys the son list */
epdest->ncols = ncolsleft ;
epdest->nrows = nrowsleft ;
epdest->ncolsleft = ncolsleft ;
epdest->nrowsleft = nrowsleft ;
epdest->rdeg = rdeg ;
epdest->cdeg = cdeg ;
ASSERT (size2 <= size) ;
pdest->header.prevsize = 0 ;
pdest->header.size = size2 ;
DEBUG7 (("After moving it:\n")) ;
#ifndef NDEBUG
UMF_dump_element (Numeric, Work, e, FALSE) ;
#endif
}
#ifndef NDEBUG
else
{
DEBUG8 ((" free\n")) ;
}
#endif
DEBUG7 (("psrc "ID" tail "ID"\n",
(Int) (psrc-Numeric->Memory), Numeric->itail)) ;
}
ASSERT (psrc == Numeric->Memory + Numeric->itail) ;
ASSERT (nmark == 0) ;
/* ---------------------------------------------------------------------- */
/* final tail pointer */
/* ---------------------------------------------------------------------- */
ASSERT (pdest >= Numeric->Memory + Numeric->itail) ;
Numeric->itail = pdest - Numeric->Memory ;
pdest->header.prevsize = 0 ;
Numeric->ibig = EMPTY ;
Numeric->tail_usage = Numeric->size - Numeric->itail ;
/* ---------------------------------------------------------------------- */
/* clear the unused E [nel+1 .. Work->elen - 1] */
/* ---------------------------------------------------------------------- */
for (e = nel+1 ; e < Work->elen ; e++)
{
E [e] = 0 ;
}
#ifndef NDEBUG
UMF_dump_packed_memory (Numeric, Work) ;
#endif
DEBUG8 (("::::GARBAGE COLLECTION DONE::::\n")) ;
}
GLOBAL Int UMF_store_lu_drop
#else
GLOBAL Int UMF_store_lu
#endif
(
NumericType *Numeric,
WorkType *Work
)
{
/* ---------------------------------------------------------------------- */
/* local variables */
/* ---------------------------------------------------------------------- */
Entry pivot_value ;
#ifdef DROP
double droptol ;
#endif
Entry *D, *Lval, *Uval, *Fl1, *Fl2, *Fu1, *Fu2,
*Flublock, *Flblock, *Fublock ;
Int i, k, fnr_curr, fnrows, fncols, row, col, pivrow, pivcol, *Frows,
*Fcols, *Lpattern, *Upattern, *Lpos, *Upos, llen, ulen, fnc_curr, fnpiv,
uilen, lnz, unz, nb, *Lilen,
*Uilen, *Lip, *Uip, *Li, *Ui, pivcol_position, newLchain, newUchain,
pivrow_position, p, size, lip, uip, lnzi, lnzx, unzx, lnz2i, lnz2x,
unz2i, unz2x, zero_pivot, *Pivrow, *Pivcol, kk,
Lnz [MAXNB] ;
#ifndef NDEBUG
Int *Col_degree, *Row_degree ;
#endif
#ifdef DROP
Int all_lnz, all_unz ;
droptol = Numeric->droptol ;
#endif
/* ---------------------------------------------------------------------- */
/* get parameters */
/* ---------------------------------------------------------------------- */
fnrows = Work->fnrows ;
fncols = Work->fncols ;
fnpiv = Work->fnpiv ;
Lpos = Numeric->Lpos ;
Upos = Numeric->Upos ;
Lilen = Numeric->Lilen ;
Uilen = Numeric->Uilen ;
Lip = Numeric->Lip ;
Uip = Numeric->Uip ;
D = Numeric->D ;
Flublock = Work->Flublock ;
Flblock = Work->Flblock ;
Fublock = Work->Fublock ;
fnr_curr = Work->fnr_curr ;
fnc_curr = Work->fnc_curr ;
Frows = Work->Frows ;
Fcols = Work->Fcols ;
#ifndef NDEBUG
Col_degree = Numeric->Cperm ; /* for NON_PIVOTAL_COL macro */
Row_degree = Numeric->Rperm ; /* for NON_PIVOTAL_ROW macro */
#endif
Lpattern = Work->Lpattern ;
llen = Work->llen ;
Upattern = Work->Upattern ;
ulen = Work->ulen ;
nb = Work->nb ;
#ifndef NDEBUG
DEBUG1 (("\nSTORE LU: fnrows "ID
" fncols "ID"\n", fnrows, fncols)) ;
DEBUG2 (("\nFrontal matrix, including all space:\n"
"fnr_curr "ID" fnc_curr "ID" nb "ID"\n"
"fnrows "ID" fncols "ID" fnpiv "ID"\n",
fnr_curr, fnc_curr, nb, fnrows, fncols, fnpiv)) ;
DEBUG2 (("\nJust the active part:\n")) ;
DEBUG7 (("C block: ")) ;
UMF_dump_dense (Work->Fcblock, fnr_curr, fnrows, fncols) ;
DEBUG7 (("L block: ")) ;
UMF_dump_dense (Work->Flblock, fnr_curr, fnrows, fnpiv);
DEBUG7 (("U' block: ")) ;
UMF_dump_dense (Work->Fublock, fnc_curr, fncols, fnpiv) ;
DEBUG7 (("LU block: ")) ;
UMF_dump_dense (Work->Flublock, nb, fnpiv, fnpiv) ;
DEBUG7 (("Current frontal matrix: (prior to store LU)\n")) ;
UMF_dump_current_front (Numeric, Work, TRUE) ;
#endif
Pivrow = Work->Pivrow ;
Pivcol = Work->Pivcol ;
/* ---------------------------------------------------------------------- */
/* store the columns of L */
/* ---------------------------------------------------------------------- */
for (kk = 0 ; kk < fnpiv ; kk++)
{
/* ------------------------------------------------------------------ */
/* one more pivot row and column is being stored into L and U */
/* ------------------------------------------------------------------ */
k = Work->npiv + kk ;
/* ------------------------------------------------------------------ */
/* find the kth pivot row and pivot column */
/* ------------------------------------------------------------------ */
pivrow = Pivrow [kk] ;
pivcol = Pivcol [kk] ;
#ifndef NDEBUG
ASSERT (pivrow >= 0 && pivrow < Work->n_row) ;
ASSERT (pivcol >= 0 && pivcol < Work->n_col) ;
DEBUGm4 ((
"\n -------------------------------------------------------------"
"Store LU: step " ID"\n", k)) ;
ASSERT (k < MIN (Work->n_row, Work->n_col)) ;
DEBUG2 (("Store column of L, k = "ID", llen "ID"\n", k, llen)) ;
for (i = 0 ; i < llen ; i++)
{
row = Lpattern [i] ;
ASSERT (row >= 0 && row < Work->n_row) ;
DEBUG2 ((" Lpattern["ID"] "ID" Lpos "ID, i, row, Lpos [row])) ;
if (row == pivrow) DEBUG2 ((" <- pivot row")) ;
DEBUG2 (("\n")) ;
ASSERT (i == Lpos [row]) ;
}
#endif
/* ------------------------------------------------------------------ */
/* remove pivot row from L */
/* ------------------------------------------------------------------ */
/* remove pivot row index from current column of L */
/* if a new Lchain starts, then all entries are removed later */
DEBUG2 (("Removing pivrow from Lpattern, k = "ID"\n", k)) ;
ASSERT (!NON_PIVOTAL_ROW (pivrow)) ;
pivrow_position = Lpos [pivrow] ;
if (pivrow_position != EMPTY)
{
/* place the last entry in the column in the */
/* position of the pivot row index */
ASSERT (pivrow == Lpattern [pivrow_position]) ;
row = Lpattern [--llen] ;
/* ASSERT (NON_PIVOTAL_ROW (row)) ; */
Lpattern [pivrow_position] = row ;
Lpos [row] = pivrow_position ;
Lpos [pivrow] = EMPTY ;
}
/* ------------------------------------------------------------------ */
/* store the pivot value, for the diagonal matrix D */
/* ------------------------------------------------------------------ */
/* kk-th column of LU block */
Fl1 = Flublock + kk * nb ;
/* kk-th column of L in the L block */
Fl2 = Flblock + kk * fnr_curr ;
/* kk-th pivot in frontal matrix located in Flublock [kk, kk] */
pivot_value = Fl1 [kk] ;
D [k] = pivot_value ;
zero_pivot = IS_ZERO (pivot_value) ;
DEBUG4 (("Pivot D["ID"]=", k)) ;
EDEBUG4 (pivot_value) ;
DEBUG4 (("\n")) ;
/* ------------------------------------------------------------------ */
/* count nonzeros in kth column of L */
/* ------------------------------------------------------------------ */
lnz = 0 ;
lnz2i = 0 ;
lnz2x = llen ;
#ifdef DROP
all_lnz = 0 ;
for (i = kk + 1 ; i < fnpiv ; i++)
{
Entry x ;
double s ;
x = Fl1 [i] ;
if (IS_ZERO (x)) continue ;
all_lnz++ ;
APPROX_ABS (s, x) ;
if (s <= droptol) continue ;
lnz++ ;
if (Lpos [Pivrow [i]] == EMPTY) lnz2i++ ;
}
for (i = 0 ; i < fnrows ; i++)
{
Entry x ;
double s ;
x = Fl2 [i] ;
if (IS_ZERO (x)) continue ;
all_lnz++ ;
APPROX_ABS (s, x) ;
if (s <= droptol) continue ;
lnz++ ;
if (Lpos [Frows [i]] == EMPTY) lnz2i++ ;
}
#else
for (i = kk + 1 ; i < fnpiv ; i++)
{
if (IS_ZERO (Fl1 [i])) continue ;
lnz++ ;
if (Lpos [Pivrow [i]] == EMPTY) lnz2i++ ;
}
for (i = 0 ; i < fnrows ; i++)
{
if (IS_ZERO (Fl2 [i])) continue ;
lnz++ ;
if (Lpos [Frows [i]] == EMPTY) lnz2i++ ;
}
#endif
lnz2x += lnz2i ;
/* determine if we start a new Lchain or continue the old one */
if (llen == 0 || zero_pivot)
{
/* llen == 0 means there is no prior Lchain */
/* D [k] == 0 means the pivot column is empty */
newLchain = TRUE ;
}
else
{
newLchain =
/* storage for starting a new Lchain */
UNITS (Entry, lnz) + UNITS (Int, lnz)
<=
/* storage for continuing a prior Lchain */
UNITS (Entry, lnz2x) + UNITS (Int, lnz2i) ;
}
if (newLchain)
{
/* start a new chain for column k of L */
DEBUG2 (("Start new Lchain, k = "ID"\n", k)) ;
pivrow_position = EMPTY ;
/* clear the prior Lpattern */
for (i = 0 ; i < llen ; i++)
{
row = Lpattern [i] ;
Lpos [row] = EMPTY ;
}
llen = 0 ;
lnzi = lnz ;
lnzx = lnz ;
}
else
{
/* continue the prior Lchain */
DEBUG2 (("Continue Lchain, k = "ID"\n", k)) ;
lnzi = lnz2i ;
lnzx = lnz2x ;
}
/* ------------------------------------------------------------------ */
/* allocate space for the column of L */
/* ------------------------------------------------------------------ */
size = UNITS (Int, lnzi) + UNITS (Entry, lnzx) ;
#ifndef NDEBUG
UMF_allocfail = FALSE ;
if (UMF_gprob > 0)
{
double rrr = ((double) (rand ( ))) / (((double) RAND_MAX) + 1) ;
DEBUG4 (("Check random %e %e\n", rrr, UMF_gprob)) ;
UMF_allocfail = rrr < UMF_gprob ;
if (UMF_allocfail) DEBUGm2 (("Random garbage coll. (store LU)\n"));
}
#endif
p = UMF_mem_alloc_head_block (Numeric, size) ;
if (!p)
{
Int r2, c2 ;
/* Do garbage collection, realloc, and try again. */
/* Note that there are pivot rows/columns in current front. */
if (Work->do_grow)
{
/* full compaction of current frontal matrix, since
* UMF_grow_front will be called next anyway. */
r2 = fnrows ;
c2 = fncols ;
}
else
{
/* partial compaction. */
r2 = MAX (fnrows, Work->fnrows_new + 1) ;
c2 = MAX (fncols, Work->fncols_new + 1) ;
}
DEBUGm3 (("get_memory from umf_store_lu:\n")) ;
if (!UMF_get_memory (Numeric, Work, size, r2, c2, TRUE))
{
DEBUGm4 (("out of memory: store LU (1)\n")) ;
return (FALSE) ; /* out of memory */
}
p = UMF_mem_alloc_head_block (Numeric, size) ;
if (!p)
{
DEBUGm4 (("out of memory: store LU (2)\n")) ;
return (FALSE) ; /* out of memory */
}
/* garbage collection may have moved the current front */
fnc_curr = Work->fnc_curr ;
fnr_curr = Work->fnr_curr ;
Flublock = Work->Flublock ;
Flblock = Work->Flblock ;
Fublock = Work->Fublock ;
Fl1 = Flublock + kk * nb ;
Fl2 = Flblock + kk * fnr_curr ;
}
/* ------------------------------------------------------------------ */
/* store the column of L */
/* ------------------------------------------------------------------ */
lip = p ;
Li = (Int *) (Numeric->Memory + p) ;
p += UNITS (Int, lnzi) ;
Lval = (Entry *) (Numeric->Memory + p) ;
p += UNITS (Entry, lnzx) ;
for (i = 0 ; i < lnzx ; i++)
{
CLEAR (Lval [i]) ;
}
/* store the numerical entries */
if (newLchain)
{
/* flag the first column in the Lchain by negating Lip [k] */
lip = -lip ;
ASSERT (llen == 0) ;
#ifdef DROP
for (i = kk + 1 ; i < fnpiv ; i++)
{
Entry x ;
double s ;
Int row2, pos ;
x = Fl1 [i] ;
APPROX_ABS (s, x) ;
if (s <= droptol) continue ;
row2 = Pivrow [i] ;
pos = llen++ ;
Lpattern [pos] = row2 ;
Lpos [row2] = pos ;
Li [pos] = row2 ;
Lval [pos] = x ;
}
for (i = 0 ; i < fnrows ; i++)
{
Entry x ;
double s ;
Int row2, pos ;
x = Fl2 [i] ;
APPROX_ABS (s, x) ;
if (s <= droptol) continue ;
row2 = Frows [i] ;
pos = llen++ ;
Lpattern [pos] = row2 ;
Lpos [row2] = pos ;
Li [pos] = row2 ;
Lval [pos] = x ;
}
#else
for (i = kk + 1 ; i < fnpiv ; i++)
{
Entry x ;
Int row2, pos ;
x = Fl1 [i] ;
if (IS_ZERO (x)) continue ;
row2 = Pivrow [i] ;
pos = llen++ ;
Lpattern [pos] = row2 ;
Lpos [row2] = pos ;
Li [pos] = row2 ;
Lval [pos] = x ;
}
for (i = 0 ; i < fnrows ; i++)
{
Entry x ;
Int row2, pos ;
x = Fl2 [i] ;
if (IS_ZERO (x)) continue ;
row2 = Frows [i] ;
pos = llen++ ;
Lpattern [pos] = row2 ;
Lpos [row2] = pos ;
Li [pos] = row2 ;
Lval [pos] = x ;
}
#endif
}
else
{
ASSERT (llen > 0) ;
#ifdef DROP
for (i = kk + 1 ; i < fnpiv ; i++)
{
Entry x ;
double s ;
Int row2, pos ;
x = Fl1 [i] ;
APPROX_ABS (s, x) ;
if (s <= droptol) continue ;
row2 = Pivrow [i] ;
pos = Lpos [row2] ;
if (pos == EMPTY)
{
pos = llen++ ;
Lpattern [pos] = row2 ;
Lpos [row2] = pos ;
*Li++ = row2 ;
}
Lval [pos] = x ;
}
for (i = 0 ; i < fnrows ; i++)
{
Entry x ;
double s ;
Int row2, pos ;
x = Fl2 [i] ;
APPROX_ABS (s, x) ;
if (s <= droptol) continue ;
row2 = Frows [i] ;
pos = Lpos [row2] ;
if (pos == EMPTY)
{
pos = llen++ ;
Lpattern [pos] = row2 ;
Lpos [row2] = pos ;
*Li++ = row2 ;
}
Lval [pos] = x ;
}
#else
for (i = kk + 1 ; i < fnpiv ; i++)
{
Entry x ;
Int row2, pos ;
x = Fl1 [i] ;
if (IS_ZERO (x)) continue ;
row2 = Pivrow [i] ;
pos = Lpos [row2] ;
if (pos == EMPTY)
{
pos = llen++ ;
Lpattern [pos] = row2 ;
Lpos [row2] = pos ;
*Li++ = row2 ;
}
Lval [pos] = x ;
}
for (i = 0 ; i < fnrows ; i++)
{
Entry x ;
Int row2, pos ;
x = Fl2 [i] ;
if (IS_ZERO (x)) continue ;
row2 = Frows [i] ;
pos = Lpos [row2] ;
if (pos == EMPTY)
{
pos = llen++ ;
Lpattern [pos] = row2 ;
Lpos [row2] = pos ;
*Li++ = row2 ;
}
Lval [pos] = x ;
}
#endif
}
DEBUG4 (("llen "ID" lnzx "ID"\n", llen, lnzx)) ;
ASSERT (llen == lnzx) ;
ASSERT (lnz <= llen) ;
DEBUG4 (("lnz "ID" \n", lnz)) ;
#ifdef DROP
DEBUG4 (("all_lnz "ID" \n", all_lnz)) ;
ASSERT (lnz <= all_lnz) ;
Numeric->lnz += lnz ;
Numeric->all_lnz += all_lnz ;
Lnz [kk] = all_lnz ;
#else
Numeric->lnz += lnz ;
Numeric->all_lnz += lnz ;
Lnz [kk] = lnz ;
#endif
Numeric->nLentries += lnzx ;
Work->llen = llen ;
Numeric->isize += lnzi ;
/* ------------------------------------------------------------------ */
/* the pivot column is fully assembled and scaled, and is now the */
/* k-th column of L */
/* ------------------------------------------------------------------ */
Lpos [pivrow] = pivrow_position ; /* not aliased */
Lip [pivcol] = lip ; /* aliased with Col_tuples */
Lilen [pivcol] = lnzi ; /* aliased with Col_tlen */
}
/* ---------------------------------------------------------------------- */
/* store the rows of U */
/* ---------------------------------------------------------------------- */
for (kk = 0 ; kk < fnpiv ; kk++)
{
/* ------------------------------------------------------------------ */
/* one more pivot row and column is being stored into L and U */
/* ------------------------------------------------------------------ */
k = Work->npiv + kk ;
/* ------------------------------------------------------------------ */
/* find the kth pivot row and pivot column */
/* ------------------------------------------------------------------ */
pivrow = Pivrow [kk] ;
pivcol = Pivcol [kk] ;
#ifndef NDEBUG
ASSERT (pivrow >= 0 && pivrow < Work->n_row) ;
ASSERT (pivcol >= 0 && pivcol < Work->n_col) ;
DEBUG2 (("Store row of U, k = "ID", ulen "ID"\n", k, ulen)) ;
for (i = 0 ; i < ulen ; i++)
{
col = Upattern [i] ;
DEBUG2 ((" Upattern["ID"] "ID, i, col)) ;
if (col == pivcol) DEBUG2 ((" <- pivot col")) ;
DEBUG2 (("\n")) ;
ASSERT (col >= 0 && col < Work->n_col) ;
ASSERT (i == Upos [col]) ;
}
#endif
/* ------------------------------------------------------------------ */
/* get the pivot value, for the diagonal matrix D */
/* ------------------------------------------------------------------ */
zero_pivot = IS_ZERO (D [k]) ;
/* ------------------------------------------------------------------ */
/* count the nonzeros in the row of U */
/* ------------------------------------------------------------------ */
/* kk-th row of U in the LU block */
Fu1 = Flublock + kk ;
/* kk-th row of U in the U block */
Fu2 = Fublock + kk * fnc_curr ;
unz = 0 ;
unz2i = 0 ;
unz2x = ulen ;
DEBUG2 (("unz2x is "ID", lnzx "ID"\n", unz2x, lnzx)) ;
/* if row k does not end a Uchain, pivcol not included in ulen */
ASSERT (!NON_PIVOTAL_COL (pivcol)) ;
pivcol_position = Upos [pivcol] ;
if (pivcol_position != EMPTY)
{
unz2x-- ;
DEBUG2 (("(exclude pivcol) unz2x is now "ID"\n", unz2x)) ;
}
ASSERT (unz2x >= 0) ;
#ifdef DROP
all_unz = 0 ;
for (i = kk + 1 ; i < fnpiv ; i++)
{
Entry x ;
double s ;
x = Fu1 [i*nb] ;
if (IS_ZERO (x)) continue ;
all_unz++ ;
APPROX_ABS (s, x) ;
if (s <= droptol) continue ;
unz++ ;
if (Upos [Pivcol [i]] == EMPTY) unz2i++ ;
}
for (i = 0 ; i < fncols ; i++)
{
Entry x ;
double s ;
x = Fu2 [i] ;
if (IS_ZERO (x)) continue ;
all_unz++ ;
APPROX_ABS (s, x) ;
if (s <= droptol) continue ;
unz++ ;
if (Upos [Fcols [i]] == EMPTY) unz2i++ ;
}
#else
for (i = kk + 1 ; i < fnpiv ; i++)
{
if (IS_ZERO (Fu1 [i*nb])) continue ;
unz++ ;
if (Upos [Pivcol [i]] == EMPTY) unz2i++ ;
}
for (i = 0 ; i < fncols ; i++)
{
if (IS_ZERO (Fu2 [i])) continue ;
unz++ ;
if (Upos [Fcols [i]] == EMPTY) unz2i++ ;
}
#endif
unz2x += unz2i ;
ASSERT (IMPLIES (k == 0, ulen == 0)) ;
/* determine if we start a new Uchain or continue the old one */
if (ulen == 0 || zero_pivot)
{
/* ulen == 0 means there is no prior Uchain */
/* D [k] == 0 means the matrix is singular (pivot row might */
/* not be empty, however, but start a new Uchain to prune zero */
/* entries for the deg > 0 test in UMF_u*solve) */
newUchain = TRUE ;
}
else
{
newUchain =
/* approximate storage for starting a new Uchain */
UNITS (Entry, unz) + UNITS (Int, unz)
<=
/* approximate storage for continuing a prior Uchain */
UNITS (Entry, unz2x) + UNITS (Int, unz2i) ;
/* this would be exact, except for the Int to Unit rounding, */
/* because the Upattern is stored only at the end of the Uchain */
}
/* ------------------------------------------------------------------ */
/* allocate space for the row of U */
/* ------------------------------------------------------------------ */
size = 0 ;
if (newUchain)
{
/* store the pattern of the last row in the prior Uchain */
size += UNITS (Int, ulen) ;
unzx = unz ;
}
else
{
unzx = unz2x ;
}
size += UNITS (Entry, unzx) ;
#ifndef NDEBUG
UMF_allocfail = FALSE ;
if (UMF_gprob > 0)
{
double rrr = ((double) (rand ( ))) / (((double) RAND_MAX) + 1) ;
DEBUG4 (("Check random %e %e\n", rrr, UMF_gprob)) ;
UMF_allocfail = rrr < UMF_gprob ;
if (UMF_allocfail) DEBUGm2 (("Random garbage coll. (store LU)\n"));
}
#endif
p = UMF_mem_alloc_head_block (Numeric, size) ;
if (!p)
{
Int r2, c2 ;
/* Do garbage collection, realloc, and try again. */
/* Note that there are pivot rows/columns in current front. */
if (Work->do_grow)
{
/* full compaction of current frontal matrix, since
* UMF_grow_front will be called next anyway. */
r2 = fnrows ;
c2 = fncols ;
}
else
{
/* partial compaction. */
r2 = MAX (fnrows, Work->fnrows_new + 1) ;
c2 = MAX (fncols, Work->fncols_new + 1) ;
}
DEBUGm3 (("get_memory from umf_store_lu:\n")) ;
if (!UMF_get_memory (Numeric, Work, size, r2, c2, TRUE))
{
/* :: get memory, column of L :: */
DEBUGm4 (("out of memory: store LU (1)\n")) ;
return (FALSE) ; /* out of memory */
}
p = UMF_mem_alloc_head_block (Numeric, size) ;
if (!p)
{
/* :: out of memory, column of U :: */
DEBUGm4 (("out of memory: store LU (2)\n")) ;
return (FALSE) ; /* out of memory */
}
/* garbage collection may have moved the current front */
fnc_curr = Work->fnc_curr ;
fnr_curr = Work->fnr_curr ;
Flublock = Work->Flublock ;
Flblock = Work->Flblock ;
Fublock = Work->Fublock ;
Fu1 = Flublock + kk ;
Fu2 = Fublock + kk * fnc_curr ;
}
/* ------------------------------------------------------------------ */
/* store the row of U */
/* ------------------------------------------------------------------ */
uip = p ;
if (newUchain)
{
/* starting a new Uchain - flag this by negating Uip [k] */
uip = -uip ;
DEBUG2 (("Start new Uchain, k = "ID"\n", k)) ;
pivcol_position = EMPTY ;
/* end the prior Uchain */
/* save the current Upattern, and then */
/* clear it and start a new Upattern */
DEBUG2 (("Ending prior chain, k-1 = "ID"\n", k-1)) ;
uilen = ulen ;
Ui = (Int *) (Numeric->Memory + p) ;
Numeric->isize += ulen ;
p += UNITS (Int, ulen) ;
for (i = 0 ; i < ulen ; i++)
{
col = Upattern [i] ;
ASSERT (col >= 0 && col < Work->n_col) ;
Upos [col] = EMPTY ;
Ui [i] = col ;
}
ulen = 0 ;
}
else
{
/* continue the prior Uchain */
DEBUG2 (("Continue Uchain, k = "ID"\n", k)) ;
ASSERT (k > 0) ;
/* remove pivot col index from current row of U */
/* if a new Uchain starts, then all entries are removed later */
DEBUG2 (("Removing pivcol from Upattern, k = "ID"\n", k)) ;
if (pivcol_position != EMPTY)
{
/* place the last entry in the row in the */
/* position of the pivot col index */
ASSERT (pivcol == Upattern [pivcol_position]) ;
col = Upattern [--ulen] ;
ASSERT (col >= 0 && col < Work->n_col) ;
Upattern [pivcol_position] = col ;
Upos [col] = pivcol_position ;
Upos [pivcol] = EMPTY ;
}
/* this row continues the Uchain. Keep track of how much */
/* to trim from the k-th length to get the length of the */
/* (k-1)st row of U */
uilen = unz2i ;
}
Uval = (Entry *) (Numeric->Memory + p) ;
/* p += UNITS (Entry, unzx), no need to increment p */
for (i = 0 ; i < unzx ; i++)
{
CLEAR (Uval [i]) ;
}
if (newUchain)
{
ASSERT (ulen == 0) ;
#ifdef DROP
for (i = kk + 1 ; i < fnpiv ; i++)
{
Entry x ;
double s ;
Int col2, pos ;
x = Fu1 [i*nb] ;
APPROX_ABS (s, x) ;
if (s <= droptol) continue ;
col2 = Pivcol [i] ;
pos = ulen++ ;
Upattern [pos] = col2 ;
Upos [col2] = pos ;
Uval [pos] = x ;
}
for (i = 0 ; i < fncols ; i++)
{
Entry x ;
double s ;
Int col2, pos ;
x = Fu2 [i] ;
APPROX_ABS (s, x) ;
if (s <= droptol) continue ;
col2 = Fcols [i] ;
pos = ulen++ ;
Upattern [pos] = col2 ;
Upos [col2] = pos ;
Uval [pos] = x ;
}
#else
for (i = kk + 1 ; i < fnpiv ; i++)
{
Entry x ;
Int col2, pos ;
x = Fu1 [i*nb] ;
if (IS_ZERO (x)) continue ;
col2 = Pivcol [i] ;
pos = ulen++ ;
Upattern [pos] = col2 ;
Upos [col2] = pos ;
Uval [pos] = x ;
}
for (i = 0 ; i < fncols ; i++)
{
Entry x ;
Int col2, pos ;
x = Fu2 [i] ;
if (IS_ZERO (x)) continue ;
col2 = Fcols [i] ;
pos = ulen++ ;
Upattern [pos] = col2 ;
Upos [col2] = pos ;
Uval [pos] = x ;
}
#endif
}
else
{
ASSERT (ulen > 0) ;
/* store the numerical entries and find new nonzeros */
#ifdef DROP
for (i = kk + 1 ; i < fnpiv ; i++)
{
Entry x ;
double s ;
Int col2, pos ;
x = Fu1 [i*nb] ;
APPROX_ABS (s, x) ;
if (s <= droptol) continue ;
col2 = Pivcol [i] ;
pos = Upos [col2] ;
if (pos == EMPTY)
{
pos = ulen++ ;
Upattern [pos] = col2 ;
Upos [col2] = pos ;
}
Uval [pos] = x ;
}
for (i = 0 ; i < fncols ; i++)
{
Entry x ;
double s ;
Int col2, pos ;
x = Fu2 [i] ;
APPROX_ABS (s, x) ;
if (s <= droptol) continue ;
col2 = Fcols [i] ;
pos = Upos [col2] ;
if (pos == EMPTY)
{
pos = ulen++ ;
Upattern [pos] = col2 ;
Upos [col2] = pos ;
}
Uval [pos] = x ;
}
#else
for (i = kk + 1 ; i < fnpiv ; i++)
{
Entry x ;
Int col2, pos ;
x = Fu1 [i*nb] ;
if (IS_ZERO (x)) continue ;
col2 = Pivcol [i] ;
pos = Upos [col2] ;
if (pos == EMPTY)
{
pos = ulen++ ;
Upattern [pos] = col2 ;
Upos [col2] = pos ;
}
Uval [pos] = x ;
}
for (i = 0 ; i < fncols ; i++)
{
Entry x ;
Int col2, pos ;
x = Fu2 [i] ;
if (IS_ZERO (x)) continue ;
col2 = Fcols [i] ;
pos = Upos [col2] ;
if (pos == EMPTY)
{
pos = ulen++ ;
Upattern [pos] = col2 ;
Upos [col2] = pos ;
}
Uval [pos] = x ;
}
#endif
}
ASSERT (ulen == unzx) ;
ASSERT (unz <= ulen) ;
DEBUG4 (("unz "ID" \n", unz)) ;
#ifdef DROP
DEBUG4 (("all_unz "ID" \n", all_unz)) ;
ASSERT (unz <= all_unz) ;
Numeric->unz += unz ;
Numeric->all_unz += all_unz ;
/* count the "true" flops, based on LU pattern only */
Numeric->flops += DIV_FLOPS * Lnz [kk] /* scale pivot column */
+ MULTSUB_FLOPS * (Lnz [kk] * all_unz) ; /* outer product */
#else
Numeric->unz += unz ;
Numeric->all_unz += unz ;
/* count the "true" flops, based on LU pattern only */
Numeric->flops += DIV_FLOPS * Lnz [kk] /* scale pivot column */
+ MULTSUB_FLOPS * (Lnz [kk] * unz) ; /* outer product */
#endif
Numeric->nUentries += unzx ;
Work->ulen = ulen ;
DEBUG1 (("Work->ulen = "ID" at end of pivot step, k: "ID"\n", ulen, k));
/* ------------------------------------------------------------------ */
/* the pivot row is the k-th row of U */
/* ------------------------------------------------------------------ */
Upos [pivcol] = pivcol_position ; /* not aliased */
Uip [pivrow] = uip ; /* aliased with Row_tuples */
Uilen [pivrow] = uilen ; /* aliased with Row_tlen */
}
/* ---------------------------------------------------------------------- */
/* no more pivots in frontal working array */
/* ---------------------------------------------------------------------- */
Work->npiv += fnpiv ;
Work->fnpiv = 0 ;
Work->fnzeros = 0 ;
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_assemble
#else
GLOBAL void UMF_assemble_fixq
#endif
(
NumericType *Numeric,
WorkType *Work
)
{
/* ---------------------------------------------------------------------- */
/* local variables */
/* ---------------------------------------------------------------------- */
Int e, i, row, col, i2, nrows, ncols, f, tpi, extcdeg, extrdeg, rdeg0,
cdeg0, son_list, next, nrows_to_assemble,
ncols_to_assemble, ngetrows, j, j2,
nrowsleft, /* number of rows remaining in S */
ncolsleft, /* number of columns remaining in S */
prior_Lson, prior_Uson, *E, *Cols, *Rows, *Wm, *Woo,
*Row_tuples, *Row_degree, *Row_tlen,
*Col_tuples, *Col_tlen ;
Unit *Memory, *p ;
Element *ep ;
Tuple *tp, *tp1, *tp2, *tpend ;
Entry
*S, /* a pointer into the contribution block of a son */
*Fcblock, /* current contribution block */
*Fcol ; /* a column of FC */
Int *Frpos,
*Fcpos,
fnrows, /* number of rows in contribution block in F */
fncols ; /* number of columns in contribution block in F */
#if !defined (FIXQ) || !defined (NDEBUG)
Int *Col_degree ;
#endif
#ifndef NDEBUG
Int n_row, n_col ;
n_row = Work->n_row ;
n_col = Work->n_col ;
DEBUG3 (("::Assemble SCANS 1-4\n")) ;
UMF_dump_current_front (Numeric, Work, TRUE) ;
#endif
#if !defined (FIXQ) || !defined (NDEBUG)
Col_degree = Numeric->Cperm ; /* not updated if FIXQ is true */
#endif
/* ---------------------------------------------------------------------- */
/* get parameters */
/* ---------------------------------------------------------------------- */
fncols = Work->fncols ;
fnrows = Work->fnrows ;
Fcpos = Work->Fcpos ;
Frpos = Work->Frpos ;
Row_degree = Numeric->Rperm ;
Row_tuples = Numeric->Uip ;
Row_tlen = Numeric->Uilen ;
Col_tuples = Numeric->Lip ;
Col_tlen = Numeric->Lilen ;
E = Work->E ;
Memory = Numeric->Memory ;
Wm = Work->Wm ;
Woo = Work->Woo ;
rdeg0 = Work->rdeg0 ;
cdeg0 = Work->cdeg0 ;
#ifndef NDEBUG
DEBUG6 (("============================================\n")) ;
DEBUG6 (("Degree update, assembly.\n")) ;
DEBUG6 (("pivot row pattern: fncols="ID"\n", fncols)) ;
for (j = 0 ; j < fncols ; j++)
{
col = Work->Fcols [j] ;
DEBUG6 ((ID" ", col)) ;
ASSERT (Fcpos [col] == j * Work->fnr_curr) ;
ASSERT (NON_PIVOTAL_COL (col)) ;
}
ASSERT (Fcpos [Work->pivcol] >= 0) ;
DEBUG6 (("pivcol: "ID" pos "ID" fnr_curr "ID" fncols "ID"\n",
Work->pivcol, Fcpos [Work->pivcol], Work->fnr_curr, fncols)) ;
ASSERT (Fcpos [Work->pivcol] < fncols * Work->fnr_curr) ;
DEBUG6 (("\npivot col pattern: fnrows="ID"\n", fnrows)) ;
for (i = 0 ; i < fnrows ; i++)
{
row = Work->Frows [i] ;
DEBUG6 ((ID" ", row)) ;
ASSERT (Frpos [row] == i) ;
ASSERT (NON_PIVOTAL_ROW (row)) ;
}
DEBUG6 (("\n")) ;
ASSERT (Frpos [Work->pivrow] >= 0) ;
ASSERT (Frpos [Work->pivrow] < fnrows) ;
ASSERT (Work->Flublock == (Entry *) (Numeric->Memory + E [0])) ;
ASSERT (Work->Fcblock == Work->Flublock + Work->nb *
(Work->nb + Work->fnr_curr + Work->fnc_curr)) ;
#endif
Fcblock = Work->Fcblock ;
/* ---------------------------------------------------------------------- */
/* determine the largest actual frontal matrix size (for Info only) */
/* ---------------------------------------------------------------------- */
ASSERT (fnrows == Work->fnrows_new + 1) ;
ASSERT (fncols == Work->fncols_new + 1) ;
Numeric->maxnrows = MAX (Numeric->maxnrows, fnrows) ;
Numeric->maxncols = MAX (Numeric->maxncols, fncols) ;
/* this is safe from integer overflow, since the current frontal matrix
* is already allocated. */
Numeric->maxfrsize = MAX (Numeric->maxfrsize, fnrows * fncols) ;
/* ---------------------------------------------------------------------- */
/* assemble from prior elements into the current frontal matrix */
/* ---------------------------------------------------------------------- */
DEBUG2 (("New assemble start [prior_element:"ID"\n", Work->prior_element)) ;
/* Currently no rows or columns are marked. No elements are scanned, */
/* that is, (ep->next == EMPTY) is true for all elements */
son_list = 0 ; /* start creating son_list [ */
/* ---------------------------------------------------------------------- */
/* determine if most recent element is Lson or Uson of current front */
/* ---------------------------------------------------------------------- */
if (!Work->do_extend)
{
prior_Uson = ( Work->pivcol_in_front && !Work->pivrow_in_front) ;
prior_Lson = (!Work->pivcol_in_front && Work->pivrow_in_front) ;
if (prior_Uson || prior_Lson)
{
e = Work->prior_element ;
if (e != EMPTY)
{
ASSERT (E [e]) ;
p = Memory + E [e] ;
ep = (Element *) p ;
ep->next = son_list ;
son_list = e ;
#ifndef NDEBUG
DEBUG2 (("e "ID" is Prior son "ID" "ID"\n",
e, prior_Uson, prior_Lson)) ;
UMF_dump_element (Numeric, Work, e, FALSE) ;
#endif
ASSERT (E [e]) ;
}
}
}
Work->prior_element = EMPTY ;
/* ---------------------------------------------------------------------- */
/* SCAN1-row: scan the element lists of each new row in the pivot col */
/* and compute the external column degree for each frontal */
/* ---------------------------------------------------------------------- */
for (i2 = Work->fscan_row ; i2 < fnrows ; i2++)
{
/* Get a row */
row = Work->NewRows [i2] ;
if (row < 0) row = FLIP (row) ;
ASSERT (row >= 0 && row < n_row) ;
DEBUG6 (("SCAN1-row: "ID"\n", row)) ;
#ifndef NDEBUG
UMF_dump_rowcol (0, Numeric, Work, row, FALSE) ;
#endif
ASSERT (NON_PIVOTAL_ROW (row)) ;
tpi = Row_tuples [row] ;
if (!tpi) continue ;
tp = (Tuple *) (Memory + tpi) ;
tp1 = tp ;
tp2 = tp ;
tpend = tp + Row_tlen [row] ;
for ( ; tp < tpend ; tp++)
{
e = tp->e ;
ASSERT (e > 0 && e <= Work->nel) ;
if (!E [e]) continue ; /* element already deallocated */
f = tp->f ;
p = Memory + E [e] ;
ep = (Element *) p ;
p += UNITS (Element, 1) ;
Rows = ((Int *) p) + ep->ncols ;
if (Rows [f] == EMPTY) continue ; /* row already assembled */
ASSERT (row == Rows [f]) ;
if (ep->cdeg < cdeg0)
{
/* first time seen in scan1-row */
ep->cdeg = ep->nrowsleft + cdeg0 ;
DEBUG6 (("e "ID" First seen: cdeg: "ID" ", e, ep->cdeg-cdeg0)) ;
ASSERT (ep->ncolsleft > 0 && ep->nrowsleft > 0) ;
}
ep->cdeg-- ; /* decrement external column degree */
DEBUG6 (("e "ID" New ext col deg: "ID"\n", e, ep->cdeg - cdeg0)) ;
/* this element is not yet in the new son list */
if (ep->cdeg == cdeg0 && ep->next == EMPTY)
{
/* A new LUson or Uson has been found */
ep->next = son_list ;
son_list = e ;
}
ASSERT (ep->cdeg >= cdeg0) ;
*tp2++ = *tp ; /* leave the tuple in the list */
}
Row_tlen [row] = tp2 - tp1 ;
}
/* ---------------------------------------------------------------------- */
/* SCAN1-col: scan the element lists of each new col in the pivot row */
/* and compute the external row degree for each frontal */
/* ---------------------------------------------------------------------- */
for (j2 = Work->fscan_col ; j2 < fncols ; j2++)
{
/* Get a column */
col = Work->NewCols [j2] ;
if (col < 0) col = FLIP (col) ;
ASSERT (col >= 0 && col < n_col) ;
DEBUG6 (("SCAN 1-col: "ID"\n", col)) ;
#ifndef NDEBUG
UMF_dump_rowcol (1, Numeric, Work, col, FALSE) ;
#endif
ASSERT (NON_PIVOTAL_COL (col)) ;
tpi = Col_tuples [col] ;
if (!tpi) continue ;
tp = (Tuple *) (Memory + tpi) ;
tp1 = tp ;
tp2 = tp ;
tpend = tp + Col_tlen [col] ;
for ( ; tp < tpend ; tp++)
{
e = tp->e ;
ASSERT (e > 0 && e <= Work->nel) ;
if (!E [e]) continue ; /* element already deallocated */
f = tp->f ;
p = Memory + E [e] ;
ep = (Element *) p ;
p += UNITS (Element, 1) ;
Cols = (Int *) p ;
if (Cols [f] == EMPTY) continue ; /* column already assembled */
ASSERT (col == Cols [f]) ;
if (ep->rdeg < rdeg0)
{
/* first time seen in scan1-col */
ep->rdeg = ep->ncolsleft + rdeg0 ;
DEBUG6 (("e "ID" First seen: rdeg: "ID" ", e, ep->rdeg-rdeg0)) ;
ASSERT (ep->ncolsleft > 0 && ep->nrowsleft > 0) ;
}
ep->rdeg-- ; /* decrement external row degree */
DEBUG6 (("e "ID" New ext row degree: "ID"\n", e, ep->rdeg-rdeg0)) ;
if (ep->rdeg == rdeg0 && ep->next == EMPTY)
{
/* A new LUson or Lson has been found */
ep->next = son_list ;
son_list = e ;
}
ASSERT (ep->rdeg >= rdeg0) ;
*tp2++ = *tp ; /* leave the tuple in the list */
}
Col_tlen [col] = tp2 - tp1 ;
}
/* ---------------------------------------------------------------------- */
/* assemble new sons via full scans */
/* ---------------------------------------------------------------------- */
next = EMPTY ;
for (e = son_list ; e > 0 ; e = next)
{
ASSERT (e > 0 && e <= Work->nel && E [e]) ;
p = Memory + E [e] ;
DEBUG2 (("New son: "ID"\n", e)) ;
#ifndef NDEBUG
UMF_dump_element (Numeric, Work, e, FALSE) ;
#endif
GET_ELEMENT (ep, p, Cols, Rows, ncols, nrows, S) ;
nrowsleft = ep->nrowsleft ;
ncolsleft = ep->ncolsleft ;
next = ep->next ;
ep->next = EMPTY ;
extrdeg = (ep->rdeg < rdeg0) ? ncolsleft : (ep->rdeg - rdeg0) ;
extcdeg = (ep->cdeg < cdeg0) ? nrowsleft : (ep->cdeg - cdeg0) ;
ncols_to_assemble = ncolsleft - extrdeg ;
nrows_to_assemble = nrowsleft - extcdeg ;
DEBUG2 (("extrdeg "ID" extcdeg "ID"\n", extrdeg, extcdeg)) ;
if (extrdeg == 0 && extcdeg == 0)
{
/* -------------------------------------------------------------- */
/* this is an LUson - assemble an entire contribution block */
/* -------------------------------------------------------------- */
DEBUG6 (("LUson found: "ID"\n", e)) ;
if (nrows == nrowsleft)
{
/* ---------------------------------------------------------- */
/* no rows assembled out of this LUson yet */
/* ---------------------------------------------------------- */
/* compute the compressed column offset vector*/
/* [ use Wm [0..nrows-1] for offsets */
#pragma ivdep
for (i = 0 ; i < nrows ; i++)
{
row = Rows [i] ;
Row_degree [row] -= ncolsleft ;
Wm [i] = Frpos [row] ;
}
if (ncols == ncolsleft)
{
/* ------------------------------------------------------ */
/* no rows or cols assembled out of LUson yet */
/* ------------------------------------------------------ */
for (j = 0 ; j < ncols ; j++)
{
col = Cols [j] ;
#ifndef FIXQ
Col_degree [col] -= nrowsleft ;
#endif
Fcol = Fcblock + Fcpos [col] ;
#pragma ivdep
for (i = 0 ; i < nrows ; i++)
{
/* Fcol [Wm [i]] += S [i] ; */
ASSEMBLE (Fcol [Wm [i]], S [i]) ;
}
S += nrows ;
}
}
else
{
/* ------------------------------------------------------ */
/* only cols have been assembled out of LUson */
/* ------------------------------------------------------ */
for (j = 0 ; j < ncols ; j++)
{
col = Cols [j] ;
if (col >= 0)
{
#ifndef FIXQ
Col_degree [col] -= nrowsleft ;
#endif
Fcol = Fcblock + Fcpos [col] ;
#pragma ivdep
for (i = 0 ; i < nrows ; i++)
{
/* Fcol [Wm [i]] += S [i] ; */
ASSEMBLE (Fcol [Wm [i]], S [i]) ;
}
}
S += nrows ;
}
}
/* ] done using Wm [0..nrows-1] for offsets */
}
else
{
/* ---------------------------------------------------------- */
/* some rows have been assembled out of this LUson */
/* ---------------------------------------------------------- */
/* compute the compressed column offset vector*/
/* [ use Woo,Wm [0..nrowsleft-1] for offsets */
ngetrows = 0 ;
for (i = 0 ; i < nrows ; i++)
{
row = Rows [i] ;
if (row >= 0)
{
Row_degree [row] -= ncolsleft ;
Woo [ngetrows] = i ;
Wm [ngetrows++] = Frpos [row] ;
}
}
ASSERT (ngetrows == nrowsleft) ;
if (ncols == ncolsleft)
{
/* ------------------------------------------------------ */
/* only rows have been assembled out of this LUson */
/* ------------------------------------------------------ */
for (j = 0 ; j < ncols ; j++)
{
col = Cols [j] ;
#ifndef FIXQ
Col_degree [col] -= nrowsleft ;
#endif
Fcol = Fcblock + Fcpos [col] ;
#pragma ivdep
for (i = 0 ; i < nrowsleft ; i++)
{
/* Fcol [Wm [i]] += S [Woo [i]] ; */
ASSEMBLE (Fcol [Wm [i]], S [Woo [i]]) ;
}
S += nrows ;
}
}
else
{
/* ------------------------------------------------------ */
/* both rows and columns have been assembled out of LUson */
/* ------------------------------------------------------ */
for (j = 0 ; j < ncols ; j++)
{
col = Cols [j] ;
if (col >= 0)
{
#ifndef FIXQ
Col_degree [col] -= nrowsleft ;
#endif
Fcol = Fcblock + Fcpos [col] ;
#pragma ivdep
for (i = 0 ; i < nrowsleft ; i++)
{
/* Fcol [Wm [i]] += S [Woo [i]] ; */
ASSEMBLE (Fcol [Wm [i]], S [Woo [i]]) ;
}
}
S += nrows ;
}
}
/* ] done using Woo,Wm [0..nrowsleft-1] */
}
/* deallocate the element: remove from ordered list */
UMF_mem_free_tail_block (Numeric, E [e]) ;
E [e] = 0 ;
}
else if (extcdeg == 0)
{
/* -------------------------------------------------------------- */
/* this is a Uson - assemble all possible columns */
/* -------------------------------------------------------------- */
DEBUG6 (("New USON: "ID"\n", e)) ;
ASSERT (extrdeg > 0) ;
DEBUG6 (("New uson "ID" cols to do "ID"\n", e, ncols_to_assemble)) ;
if (ncols_to_assemble > 0)
{
Int skip = FALSE ;
if (ncols_to_assemble * 16 < ncols && nrows == 1)
{
/* this is a tall and thin frontal matrix consisting of
* only one column (most likely an original column). Do
* not assemble it. It cannot be the pivot column, since
* the pivot column element would be an LU son, not an Lson,
* of the current frontal matrix. */
ASSERT (nrowsleft == 1) ;
ASSERT (Rows [0] >= 0 && Rows [0] < Work->n_row) ;
skip = TRUE ;
Work->any_skip = TRUE ;
}
if (!skip)
{
if (nrows == nrowsleft)
{
/* -------------------------------------------------- */
/* no rows have been assembled out of this Uson yet */
/* -------------------------------------------------- */
/* compute the compressed column offset vector */
/* [ use Wm [0..nrows-1] for offsets */
#pragma ivdep
for (i = 0 ; i < nrows ; i++)
{
row = Rows [i] ;
ASSERT (row >= 0 && row < n_row) ;
Row_degree [row] -= ncols_to_assemble ;
Wm [i] = Frpos [row] ;
}
for (j = 0 ; j < ncols ; j++)
{
col = Cols [j] ;
if ((col >= 0) && (Fcpos [col] >= 0))
{
#ifndef FIXQ
Col_degree [col] -= nrowsleft ;
#endif
Fcol = Fcblock + Fcpos [col] ;
#pragma ivdep
for (i = 0 ; i < nrows ; i++)
{
/* Fcol [Wm [i]] += S [i] ; */
ASSEMBLE (Fcol [Wm [i]], S [i]) ;
}
/* flag the column as assembled from Uson */
Cols [j] = EMPTY ;
}
S += nrows ;
}
/* ] done using Wm [0..nrows-1] for offsets */
}
else
{
/* -------------------------------------------------- */
/* some rows have been assembled out of this Uson */
/* -------------------------------------------------- */
/* compute the compressed column offset vector*/
/* [ use Woo,Wm [0..nrows-1] for offsets */
ngetrows = 0 ;
for (i = 0 ; i < nrows ; i++)
{
row = Rows [i] ;
if (row >= 0)
{
Row_degree [row] -= ncols_to_assemble ;
ASSERT (row < n_row && Frpos [row] >= 0) ;
Woo [ngetrows] = i ;
Wm [ngetrows++] = Frpos [row] ;
}
}
ASSERT (ngetrows == nrowsleft) ;
for (j = 0 ; j < ncols ; j++)
{
col = Cols [j] ;
if ((col >= 0) && (Fcpos [col] >= 0))
{
#ifndef FIXQ
Col_degree [col] -= nrowsleft ;
#endif
Fcol = Fcblock + Fcpos [col] ;
#pragma ivdep
for (i = 0 ; i < nrowsleft ; i++)
{
/* Fcol [Wm [i]] += S [Woo [i]] ; */
ASSEMBLE (Fcol [Wm [i]], S [Woo [i]]) ;
}
/* flag the column as assembled from Uson */
Cols [j] = EMPTY ;
}
S += nrows ;
}
/* ] done using Woo,Wm */
}
ep->ncolsleft = extrdeg ;
}
}
}
else
{
/* -------------------------------------------------------------- */
/* this is an Lson - assemble all possible rows */
/* -------------------------------------------------------------- */
DEBUG6 (("New LSON: "ID"\n", e)) ;
ASSERT (extrdeg == 0 && extcdeg > 0) ;
DEBUG6 (("New lson "ID" rows to do "ID"\n", e, nrows_to_assemble)) ;
if (nrows_to_assemble > 0)
{
Int skip = FALSE ;
if (nrows_to_assemble * 16 < nrows && ncols == 1)
{
/* this is a tall and thin frontal matrix consisting of
* only one column (most likely an original column). Do
* not assemble it. It cannot be the pivot column, since
* the pivot column element would be an LU son, not an Lson,
* of the current frontal matrix. */
ASSERT (ncolsleft == 1) ;
ASSERT (Cols [0] >= 0 && Cols [0] < Work->n_col) ;
Work->any_skip = TRUE ;
skip = TRUE ;
}
if (!skip)
{
/* compute the compressed column offset vector */
/* [ use Woo,Wm [0..nrows-1] for offsets */
ngetrows = 0 ;
for (i = 0 ; i < nrows ; i++)
{
row = Rows [i] ;
if ((row >= 0) && (Frpos [row] >= 0))
{
ASSERT (row < n_row) ;
Row_degree [row] -= ncolsleft ;
Woo [ngetrows] = i ;
Wm [ngetrows++] = Frpos [row] ;
/* flag the row as assembled from the Lson */
Rows [i] = EMPTY ;
}
}
ASSERT (nrowsleft - ngetrows == extcdeg) ;
ASSERT (ngetrows == nrows_to_assemble) ;
if (ncols == ncolsleft)
{
/* -------------------------------------------------- */
/* no columns assembled out this Lson yet */
/* -------------------------------------------------- */
for (j = 0 ; j < ncols ; j++)
{
col = Cols [j] ;
ASSERT (col >= 0 && col < n_col) ;
#ifndef FIXQ
Col_degree [col] -= nrows_to_assemble ;
#endif
Fcol = Fcblock + Fcpos [col] ;
#pragma ivdep
for (i = 0 ; i < nrows_to_assemble ; i++)
{
/* Fcol [Wm [i]] += S [Woo [i]] ; */
ASSEMBLE (Fcol [Wm [i]], S [Woo [i]]) ;
}
S += nrows ;
}
}
else
{
/* -------------------------------------------------- */
/* some columns have been assembled out of this Lson */
/* -------------------------------------------------- */
for (j = 0 ; j < ncols ; j++)
{
col = Cols [j] ;
ASSERT (col < n_col) ;
if (col >= 0)
{
#ifndef FIXQ
Col_degree [col] -= nrows_to_assemble ;
#endif
Fcol = Fcblock + Fcpos [col] ;
#pragma ivdep
for (i = 0 ; i < nrows_to_assemble ; i++)
{
/* Fcol [Wm [i]] += S [Woo [i]] ; */
ASSEMBLE (Fcol [Wm [i]], S [Woo [i]]) ;
}
}
S += nrows ;
}
}
/* ] done using Woo,Wm */
ep->nrowsleft = extcdeg ;
}
}
}
}
/* Note that garbage collection, and build tuples */
/* both destroy the son list. */
/* ] son_list now empty */
/* ---------------------------------------------------------------------- */
/* If frontal matrix extended, assemble old L/Usons from new rows/cols */
/* ---------------------------------------------------------------------- */
/* ---------------------------------------------------------------------- */
/* SCAN2-row: assemble rows of old Lsons from the new rows */
/* ---------------------------------------------------------------------- */
#ifndef NDEBUG
DEBUG7 (("Current frontal matrix: (prior to scan2-row)\n")) ;
UMF_dump_current_front (Numeric, Work, TRUE) ;
#endif
/* rescan the pivot row */
if (Work->any_skip)
{
row_assemble (Work->pivrow, Numeric, Work) ;
}
if (Work->do_scan2row)
{
for (i2 = Work->fscan_row ; i2 < fnrows ; i2++)
{
/* Get a row */
row = Work->NewRows [i2] ;
if (row < 0) row = FLIP (row) ;
ASSERT (row >= 0 && row < n_row) ;
if (!(row == Work->pivrow && Work->any_skip))
{
/* assemble it */
row_assemble (row, Numeric, Work) ;
}
}
}
/* ---------------------------------------------------------------------- */
/* SCAN2-col: assemble columns of old Usons from the new columns */
/* ---------------------------------------------------------------------- */
#ifndef NDEBUG
DEBUG7 (("Current frontal matrix: (prior to scan2-col)\n")) ;
UMF_dump_current_front (Numeric, Work, TRUE) ;
#endif
/* rescan the pivot col */
if (Work->any_skip)
{
col_assemble (Work->pivcol, Numeric, Work) ;
}
if (Work->do_scan2col)
{
for (j2 = Work->fscan_col ; j2 < fncols ; j2++)
{
/* Get a column */
col = Work->NewCols [j2] ;
if (col < 0) col = FLIP (col) ;
ASSERT (col >= 0 && col < n_col) ;
if (!(col == Work->pivcol && Work->any_skip))
{
/* assemble it */
col_assemble (col, Numeric, Work) ;
}
}
}
/* ---------------------------------------------------------------------- */
/* done. the remainder of this routine is used only when in debug mode */
/* ---------------------------------------------------------------------- */
#ifndef NDEBUG
/* ---------------------------------------------------------------------- */
/* when debugging: make sure the assembly did everything that it could */
/* ---------------------------------------------------------------------- */
DEBUG3 (("::Assemble done\n")) ;
for (i2 = 0 ; i2 < fnrows ; i2++)
{
/* Get a row */
row = Work->Frows [i2] ;
ASSERT (row >= 0 && row < n_row) ;
DEBUG6 (("DEBUG SCAN 1: "ID"\n", row)) ;
UMF_dump_rowcol (0, Numeric, Work, row, TRUE) ;
ASSERT (NON_PIVOTAL_ROW (row)) ;
tpi = Row_tuples [row] ;
if (!tpi) continue ;
tp = (Tuple *) (Memory + tpi) ;
tpend = tp + Row_tlen [row] ;
for ( ; tp < tpend ; tp++)
{
e = tp->e ;
ASSERT (e > 0 && e <= Work->nel) ;
if (!E [e]) continue ; /* element already deallocated */
f = tp->f ;
p = Memory + E [e] ;
ep = (Element *) p ;
p += UNITS (Element, 1) ;
Cols = (Int *) p ;
Rows = ((Int *) p) + ep->ncols ;
if (Rows [f] == EMPTY) continue ; /* row already assembled */
ASSERT (row == Rows [f]) ;
extrdeg = (ep->rdeg < rdeg0) ? ep->ncolsleft : (ep->rdeg - rdeg0) ;
extcdeg = (ep->cdeg < cdeg0) ? ep->nrowsleft : (ep->cdeg - cdeg0) ;
DEBUG6 ((
"e "ID" After assembly ext row deg: "ID" ext col degree "ID"\n",
e, extrdeg, extcdeg)) ;
if (Work->any_skip)
{
/* no Lsons in any row, except for very tall and thin ones */
ASSERT (extrdeg >= 0) ;
if (extrdeg == 0)
{
/* this is an unassemble Lson */
ASSERT (ep->ncols == 1) ;
ASSERT (ep->ncolsleft == 1) ;
col = Cols [0] ;
ASSERT (col != Work->pivcol) ;
}
}
else
{
/* no Lsons in any row */
ASSERT (extrdeg > 0) ;
/* Uson external row degree is = number of cols left */
ASSERT (IMPLIES (extcdeg == 0, extrdeg == ep->ncolsleft)) ;
}
}
}
/* ---------------------------------------------------------------------- */
for (j2 = 0 ; j2 < fncols ; j2++)
{
/* Get a column */
col = Work->Fcols [j2] ;
ASSERT (col >= 0 && col < n_col) ;
DEBUG6 (("DEBUG SCAN 2: "ID"\n", col)) ;
#ifndef FIXQ
UMF_dump_rowcol (1, Numeric, Work, col, TRUE) ;
#else
UMF_dump_rowcol (1, Numeric, Work, col, FALSE) ;
#endif
ASSERT (NON_PIVOTAL_COL (col)) ;
tpi = Col_tuples [col] ;
if (!tpi) continue ;
tp = (Tuple *) (Memory + tpi) ;
tpend = tp + Col_tlen [col] ;
for ( ; tp < tpend ; tp++)
{
e = tp->e ;
ASSERT (e > 0 && e <= Work->nel) ;
if (!E [e]) continue ; /* element already deallocated */
f = tp->f ;
p = Memory + E [e] ;
ep = (Element *) p ;
p += UNITS (Element, 1) ;
Cols = (Int *) p ;
Rows = ((Int *) p) + ep->ncols ;
if (Cols [f] == EMPTY) continue ; /* column already assembled */
ASSERT (col == Cols [f]) ;
extrdeg = (ep->rdeg < rdeg0) ? ep->ncolsleft : (ep->rdeg - rdeg0) ;
extcdeg = (ep->cdeg < cdeg0) ? ep->nrowsleft : (ep->cdeg - cdeg0) ;
DEBUG6 (("e "ID" After assembly ext col deg: "ID"\n", e, extcdeg)) ;
if (Work->any_skip)
{
/* no Usons in any column, except for very tall and thin ones */
ASSERT (extcdeg >= 0) ;
if (extcdeg == 0)
{
/* this is an unassemble Uson */
ASSERT (ep->nrows == 1) ;
ASSERT (ep->nrowsleft == 1) ;
row = Rows [0] ;
ASSERT (row != Work->pivrow) ;
}
}
else
{
/* no Usons in any column */
ASSERT (extcdeg > 0) ;
/* Lson external column degree is = number of rows left */
ASSERT (IMPLIES (extrdeg == 0, extcdeg == ep->nrowsleft)) ;
}
}
}
#endif /* NDEBUG */
}
PRIVATE void row_assemble
(
Int row,
NumericType *Numeric,
WorkType *Work
)
{
Entry *S, *Fcblock, *Frow ;
Int tpi, e, *E, *Fcpos, *Frpos, *Row_degree, *Row_tuples, *Row_tlen, rdeg0,
f, nrows, ncols, *Rows, *Cols, col, ncolsleft, j ;
Tuple *tp, *tp1, *tp2, *tpend ;
Unit *Memory, *p ;
Element *ep ;
#ifndef FIXQ
Int *Col_degree ;
Col_degree = Numeric->Cperm ;
#endif
Row_tuples = Numeric->Uip ;
tpi = Row_tuples [row] ;
if (!tpi) return ;
Memory = Numeric->Memory ;
E = Work->E ;
Fcpos = Work->Fcpos ;
Frpos = Work->Frpos ;
Row_degree = Numeric->Rperm ;
Row_tlen = Numeric->Uilen ;
E = Work->E ;
Memory = Numeric->Memory ;
rdeg0 = Work->rdeg0 ;
Fcblock = Work->Fcblock ;
#ifndef NDEBUG
DEBUG6 (("SCAN2-row: "ID"\n", row)) ;
UMF_dump_rowcol (0, Numeric, Work, row, FALSE) ;
#endif
ASSERT (NON_PIVOTAL_ROW (row)) ;
tp = (Tuple *) (Memory + tpi) ;
tp1 = tp ;
tp2 = tp ;
tpend = tp + Row_tlen [row] ;
for ( ; tp < tpend ; tp++)
{
e = tp->e ;
ASSERT (e > 0 && e <= Work->nel) ;
if (!E [e]) continue ; /* element already deallocated */
f = tp->f ;
p = Memory + E [e] ;
ep = (Element *) p ;
p += UNITS (Element, 1) ;
Cols = (Int *) p ;
Rows = Cols + ep->ncols ;
if (Rows [f] == EMPTY) continue ; /* row already assembled */
ASSERT (row == Rows [f] && row >= 0 && row < Work->n_row) ;
if (ep->rdeg == rdeg0)
{
/* ------------------------------------------------------ */
/* this is an old Lson - assemble just one row */
/* ------------------------------------------------------ */
/* flag the row as assembled from the Lson */
Rows [f] = EMPTY ;
nrows = ep->nrows ;
ncols = ep->ncols ;
p += UNITS (Int, ncols + nrows) ;
S = ((Entry *) p) + f ;
DEBUG6 (("Old LSON: "ID"\n", e)) ;
#ifndef NDEBUG
UMF_dump_element (Numeric, Work, e, FALSE) ;
#endif
ncolsleft = ep->ncolsleft ;
Frow = Fcblock + Frpos [row] ;
DEBUG6 (("LSON found (in scan2-row): "ID"\n", e)) ;
Row_degree [row] -= ncolsleft ;
if (ncols == ncolsleft)
{
/* -------------------------------------------------- */
/* no columns assembled out this Lson yet */
/* -------------------------------------------------- */
#pragma ivdep
for (j = 0 ; j < ncols ; j++)
{
col = Cols [j] ;
ASSERT (col >= 0 && col < Work->n_col) ;
#ifndef FIXQ
Col_degree [col] -- ;
#endif
/* Frow [Fcpos [col]] += *S ; */
ASSEMBLE (Frow [Fcpos [col]], *S) ;
S += nrows ;
}
}
else
{
/* -------------------------------------------------- */
/* some columns have been assembled out of this Lson */
/* -------------------------------------------------- */
#pragma ivdep
for (j = 0 ; j < ncols ; j++)
{
col = Cols [j] ;
if (col >= 0)
{
ASSERT (col < Work->n_col) ;
#ifndef FIXQ
Col_degree [col] -- ;
#endif
/* Frow [Fcpos [col]] += *S ; */
ASSEMBLE (Frow [Fcpos [col]], *S) ;
}
S += nrows ;
}
}
ep->nrowsleft-- ;
ASSERT (ep->nrowsleft > 0) ;
}
else
{
*tp2++ = *tp ; /* leave the tuple in the list */
}
}
Row_tlen [row] = tp2 - tp1 ;
#ifndef NDEBUG
DEBUG7 (("row assembled in scan2-row: "ID"\n", row)) ;
UMF_dump_rowcol (0, Numeric, Work, row, FALSE) ;
DEBUG7 (("Current frontal matrix: (scan 1b)\n")) ;
UMF_dump_current_front (Numeric, Work, TRUE) ;
#endif
}
PRIVATE void col_assemble
(
Int col,
NumericType *Numeric,
WorkType *Work
)
{
Entry *S, *Fcblock, *Fcol ;
Int tpi, e, *E, *Fcpos, *Frpos, *Row_degree, *Col_tuples, *Col_tlen, cdeg0,
f, nrows, ncols, *Rows, *Cols, row, nrowsleft, i ;
Tuple *tp, *tp1, *tp2, *tpend ;
Unit *Memory, *p ;
Element *ep ;
#if !defined (FIXQ) || !defined (NDEBUG)
Int *Col_degree ;
Col_degree = Numeric->Cperm ;
#endif
Col_tuples = Numeric->Lip ;
tpi = Col_tuples [col] ;
if (!tpi) return ;
Memory = Numeric->Memory ;
E = Work->E ;
Fcpos = Work->Fcpos ;
Frpos = Work->Frpos ;
Row_degree = Numeric->Rperm ;
Col_tlen = Numeric->Lilen ;
E = Work->E ;
Memory = Numeric->Memory ;
cdeg0 = Work->cdeg0 ;
Fcblock = Work->Fcblock ;
DEBUG6 (("SCAN2-col: "ID"\n", col)) ;
#ifndef NDEBUG
UMF_dump_rowcol (1, Numeric, Work, col, FALSE) ;
#endif
ASSERT (NON_PIVOTAL_COL (col)) ;
tp = (Tuple *) (Memory + tpi) ;
tp1 = tp ;
tp2 = tp ;
tpend = tp + Col_tlen [col] ;
for ( ; tp < tpend ; tp++)
{
e = tp->e ;
ASSERT (e > 0 && e <= Work->nel) ;
if (!E [e]) continue ; /* element already deallocated */
f = tp->f ;
p = Memory + E [e] ;
ep = (Element *) p ;
p += UNITS (Element, 1) ;
Cols = (Int *) p ;
if (Cols [f] == EMPTY) continue ; /* col already assembled */
ASSERT (col == Cols [f] && col >= 0 && col < Work->n_col) ;
if (ep->cdeg == cdeg0)
{
/* ------------------------------------------------------ */
/* this is an old Uson - assemble just one col */
/* ------------------------------------------------------ */
/* flag the col as assembled from the Uson */
Cols [f] = EMPTY ;
nrows = ep->nrows ;
ncols = ep->ncols ;
Rows = Cols + ncols ;
p += UNITS (Int, ncols + nrows) ;
S = ((Entry *) p) + f * nrows ;
DEBUG6 (("Old USON: "ID"\n", e)) ;
#ifndef NDEBUG
UMF_dump_element (Numeric, Work, e, FALSE) ;
#endif
nrowsleft = ep->nrowsleft ;
Fcol = Fcblock + Fcpos [col] ;
DEBUG6 (("USON found (in scan2-col): "ID"\n", e)) ;
#ifndef FIXQ
Col_degree [col] -= nrowsleft ;
#endif
if (nrows == nrowsleft)
{
/* -------------------------------------------------- */
/* no rows assembled out of this Uson yet */
/* -------------------------------------------------- */
#pragma ivdep
for (i = 0 ; i < nrows ; i++)
{
row = Rows [i] ;
ASSERT (row >= 0 && row < Work->n_row) ;
Row_degree [row]-- ;
/* Fcol [Frpos [row]] += S [i] ; */
ASSEMBLE (Fcol [Frpos [row]], S [i]) ;
}
}
else
{
/* -------------------------------------------------- */
/* some rows have been assembled out of this Uson */
/* -------------------------------------------------- */
#pragma ivdep
for (i = 0 ; i < nrows ; i++)
{
row = Rows [i] ;
if (row >= 0)
{
ASSERT (row < Work->n_row) ;
Row_degree [row]-- ;
/* Fcol [Frpos [row]] += S [i] ; */
ASSEMBLE (Fcol [Frpos [row]], S [i]) ;
}
}
}
ep->ncolsleft-- ;
ASSERT (ep->ncolsleft > 0) ;
}
else
{
*tp2++ = *tp ; /* leave the tuple in the list */
}
}
Col_tlen [col] = tp2 - tp1 ;
#ifndef NDEBUG
DEBUG7 (("Column assembled in scan2-col: "ID"\n", col)) ;
UMF_dump_rowcol (1, Numeric, Work, col, FALSE) ;
DEBUG7 (("Current frontal matrix: after scan2-col\n")) ;
UMF_dump_current_front (Numeric, Work, TRUE) ;
#endif
}
GLOBAL Int UMF_extend_front
(
NumericType *Numeric,
WorkType *Work
)
{
/* ---------------------------------------------------------------------- */
/* local variables */
/* ---------------------------------------------------------------------- */
Int j, i, *Frows, row, col, *Wrow, fnr2, fnc2, *Frpos, *Fcpos, *Fcols,
fnrows_extended, rrdeg, ccdeg, fncols_extended, fnr_curr, fnc_curr,
fnrows, fncols, pos, fnpiv, *Wm ;
Entry *Wx, *Wy, *Fu, *Fl ;
/* ---------------------------------------------------------------------- */
/* get current frontal matrix and check for frontal growth */
/* ---------------------------------------------------------------------- */
fnpiv = Work->fnpiv ;
#ifndef NDEBUG
DEBUG2 (("EXTEND FRONT\n")) ;
DEBUG2 (("Work->fnpiv "ID"\n", fnpiv)) ;
ASSERT (Work->Flblock == Work->Flublock + Work->nb*Work->nb) ;
ASSERT (Work->Fublock == Work->Flblock + Work->fnr_curr*Work->nb) ;
ASSERT (Work->Fcblock == Work->Fublock + Work->nb*Work->fnc_curr) ;
DEBUG7 (("C block: ")) ;
UMF_dump_dense (Work->Fcblock, Work->fnr_curr, Work->fnrows, Work->fncols) ;
DEBUG7 (("L block: ")) ;
UMF_dump_dense (Work->Flblock, Work->fnr_curr, Work->fnrows, fnpiv);
DEBUG7 (("U' block: ")) ;
UMF_dump_dense (Work->Fublock, Work->fnc_curr, Work->fncols, fnpiv) ;
DEBUG7 (("LU block: ")) ;
UMF_dump_dense (Work->Flublock, Work->nb, fnpiv, fnpiv) ;
#endif
if (Work->do_grow)
{
fnr2 = UMF_FRONTAL_GROWTH * Work->fnrows_new + 2 ;
fnc2 = UMF_FRONTAL_GROWTH * Work->fncols_new + 2 ;
if (!UMF_grow_front (Numeric, fnr2, fnc2, Work, 1))
{
DEBUGm4 (("out of memory: extend front\n")) ;
return (FALSE) ;
}
}
fnr_curr = Work->fnr_curr ;
fnc_curr = Work->fnc_curr ;
ASSERT (Work->fnrows_new + 1 <= fnr_curr) ;
ASSERT (Work->fncols_new + 1 <= fnc_curr) ;
ASSERT (fnr_curr >= 0 && fnr_curr % 2 == 1) ;
/* ---------------------------------------------------------------------- */
/* get parameters */
/* ---------------------------------------------------------------------- */
Frows = Work->Frows ;
Frpos = Work->Frpos ;
Fcols = Work->Fcols ;
Fcpos = Work->Fcpos ;
fnrows = Work->fnrows ;
fncols = Work->fncols ;
rrdeg = Work->rrdeg ;
ccdeg = Work->ccdeg ;
/* scan starts at the first new column in Fcols */
/* also scan the pivot column if it was not in the front */
Work->fscan_col = fncols ;
Work->NewCols = Fcols ;
/* scan1 starts at the first new row in Frows */
/* also scan the pivot row if it was not in the front */
Work->fscan_row = fnrows ;
Work->NewRows = Frows ;
/* ---------------------------------------------------------------------- */
/* extend row pattern of the front with the new pivot column */
/* ---------------------------------------------------------------------- */
fnrows_extended = fnrows ;
fncols_extended = fncols ;
#ifndef NDEBUG
DEBUG2 (("Pivot col, before extension: "ID"\n", fnrows)) ;
for (i = 0 ; i < fnrows ; i++)
{
DEBUG2 ((" "ID": row "ID"\n", i, Frows [i])) ;
ASSERT (Frpos [Frows [i]] == i) ;
}
DEBUG2 (("Extending pivot column: pivcol_in_front: "ID"\n",
Work->pivcol_in_front)) ;
#endif
Fl = Work->Flblock + fnpiv * fnr_curr ;
if (Work->pivcol_in_front)
{
/* extended pattern and position already in Frows, Frpos. Values above
* the diagonal are already in LU block. Values on and below the
* diagonal are in Wy [0 .. fnrows_extended-1]. Copy into the L
* block. */
fnrows_extended += ccdeg ;
Wy = Work->Wy ;
for (i = 0 ; i < fnrows_extended ; i++)
{
Fl [i] = Wy [i] ;
#ifndef NDEBUG
row = Frows [i] ;
DEBUG2 ((" "ID": row "ID" ", i, row)) ;
EDEBUG2 (Fl [i]) ;
if (row == Work->pivrow) DEBUG2 ((" <- pivrow")) ;
DEBUG2 (("\n")) ;
if (i == fnrows - 1) DEBUG2 ((" :::::::\n")) ;
ASSERT (row >= 0 && row < Work->n_row) ;
ASSERT (Frpos [row] == i) ;
#endif
}
}
else
{
/* extended pattern,values is in (Wm,Wx), not yet in the front */
Entry *F ;
Fu = Work->Flublock + fnpiv * Work->nb ;
Wm = Work->Wm ;
Wx = Work->Wx ;
F = Fu ;
for (i = 0 ; i < fnpiv ; i++)
{
CLEAR_AND_INCREMENT (F) ;
}
F = Fl ;
for (i = 0 ; i < fnrows ; i++)
{
CLEAR_AND_INCREMENT (F) ;
}
for (i = 0 ; i < ccdeg ; i++)
{
row = Wm [i] ;
#ifndef NDEBUG
DEBUG2 ((" "ID": row "ID" (ext) ", fnrows_extended, row)) ;
EDEBUG2 (Wx [i]) ;
if (row == Work->pivrow) DEBUG2 ((" <- pivrow")) ;
DEBUG2 (("\n")) ;
ASSERT (row >= 0 && row < Work->n_row) ;
#endif
pos = Frpos [row] ;
if (pos < 0)
{
pos = fnrows_extended++ ;
Frows [pos] = row ;
Frpos [row] = pos ;
}
Fl [pos] = Wx [i] ;
}
}
ASSERT (fnrows_extended <= fnr_curr) ;
/* ---------------------------------------------------------------------- */
/* extend the column pattern of the front with the new pivot row */
/* ---------------------------------------------------------------------- */
#ifndef NDEBUG
DEBUG6 (("Pivot row, before extension: "ID"\n", fncols)) ;
for (j = 0 ; j < fncols ; j++)
{
DEBUG7 ((" "ID": col "ID"\n", j, Fcols [j])) ;
ASSERT (Fcpos [Fcols [j]] == j * fnr_curr) ;
}
DEBUG6 (("Extending pivot row:\n")) ;
#endif
if (Work->pivrow_in_front)
{
if (Work->pivcol_in_front)
{
ASSERT (Fcols == Work->Wrow) ;
for (j = fncols ; j < rrdeg ; j++)
{
#ifndef NDEBUG
col = Fcols [j] ;
DEBUG2 ((" "ID": col "ID" (ext)\n", j, col)) ;
ASSERT (col != Work->pivcol) ;
ASSERT (col >= 0 && col < Work->n_col) ;
ASSERT (Fcpos [col] < 0) ;
#endif
Fcpos [Fcols [j]] = j * fnr_curr ;
}
}
else
{
/* OUT-IN option: pivcol not in front, but pivrow is in front */
Wrow = Work->Wrow ;
ASSERT (IMPLIES (Work->pivcol_in_front, Wrow == Fcols)) ;
if (Wrow == Fcols)
{
/* Wrow and Fcols are equivalenced */
for (j = fncols ; j < rrdeg ; j++)
{
col = Wrow [j] ;
DEBUG2 ((" "ID": col "ID" (ext)\n", j, col)) ;
ASSERT (Fcpos [col] < 0) ;
/* Fcols [j] = col ; not needed */
Fcpos [col] = j * fnr_curr ;
}
}
else
{
for (j = fncols ; j < rrdeg ; j++)
{
col = Wrow [j] ;
DEBUG2 ((" "ID": col "ID" (ext)\n", j, col)) ;
ASSERT (Fcpos [col] < 0) ;
Fcols [j] = col ;
Fcpos [col] = j * fnr_curr ;
}
}
}
fncols_extended = rrdeg ;
}
else
{
ASSERT (Fcols != Work->Wrow) ;
Wrow = Work->Wrow ;
for (j = 0 ; j < rrdeg ; j++)
{
col = Wrow [j] ;
ASSERT (col >= 0 && col < Work->n_col) ;
if (Fcpos [col] < 0)
{
DEBUG2 ((" col:: "ID" (ext)\n", col)) ;
Fcols [fncols_extended] = col ;
Fcpos [col] = fncols_extended * fnr_curr ;
fncols_extended++ ;
}
}
}
/* ---------------------------------------------------------------------- */
/* pivot row and column have been extended */
/* ---------------------------------------------------------------------- */
#ifndef NDEBUG
ASSERT (fncols_extended <= fnc_curr) ;
ASSERT (fnrows_extended <= fnr_curr) ;
DEBUG6 (("Pivot col, after ext: "ID" "ID"\n", fnrows,fnrows_extended)) ;
for (i = 0 ; i < fnrows_extended ; i++)
{
row = Frows [i] ;
DEBUG7 ((" "ID": row "ID" pos "ID" old: %d", i, row, Frpos [row],
i < fnrows)) ;
if (row == Work->pivrow ) DEBUG7 ((" <-- pivrow")) ;
DEBUG7 (("\n")) ;
ASSERT (Frpos [Frows [i]] == i) ;
}
DEBUG6 (("Pivot row position: "ID"\n", Frpos [Work->pivrow])) ;
ASSERT (Frpos [Work->pivrow] >= 0) ;
ASSERT (Frpos [Work->pivrow] < fnrows_extended) ;
DEBUG6 (("Pivot row, after ext: "ID" "ID"\n", fncols,fncols_extended)) ;
for (j = 0 ; j < fncols_extended ; j++)
{
col = Fcols [j] ;
DEBUG7 ((" "ID": col "ID" pos "ID" old: %d", j, col, Fcpos [col],
j < fncols)) ;
if (col == Work->pivcol ) DEBUG7 ((" <-- pivcol")) ;
DEBUG7 (("\n")) ;
ASSERT (Fcpos [Fcols [j]] == j * fnr_curr) ;
}
DEBUG6 (("Pivot col position: "ID"\n", Fcpos [Work->pivcol])) ;
ASSERT (Fcpos [Work->pivcol] >= 0) ;
ASSERT (Fcpos [Work->pivcol] < fncols_extended * fnr_curr) ;
#endif
/* ---------------------------------------------------------------------- */
/* Zero the newly extended frontal matrix */
/* ---------------------------------------------------------------------- */
zero_front (Work->Flblock, Work->Fublock, Work->Fcblock,
fnrows, fncols, fnr_curr, fnc_curr,
fnpiv, fnrows_extended, fncols_extended) ;
/* ---------------------------------------------------------------------- */
/* finalize extended row and column pattern of the frontal matrix */
/* ---------------------------------------------------------------------- */
Work->fnrows = fnrows_extended ;
Work->fncols = fncols_extended ;
ASSERT (fnrows_extended == Work->fnrows_new + 1) ;
ASSERT (fncols_extended == Work->fncols_new + 1) ;
return (TRUE) ;
}
GLOBAL void UMF_scale_column
(
NumericType *Numeric,
WorkType *Work
)
{
/* ---------------------------------------------------------------------- */
/* local variables */
/* ---------------------------------------------------------------------- */
Entry pivot_value ;
Entry *Fcol, *Flublock, *Flblock, *Fublock, *Fcblock ;
Int k, k1, fnr_curr, fnrows, fncols, *Frpos, *Fcpos, pivrow, pivcol,
*Frows, *Fcols, fnc_curr, fnpiv, *Row_tuples, nb,
*Col_tuples, *Rperm, *Cperm, fspos, col2, row2 ;
#ifndef NDEBUG
Int *Col_degree, *Row_degree ;
#endif
/* ---------------------------------------------------------------------- */
/* get parameters */
/* ---------------------------------------------------------------------- */
fnrows = Work->fnrows ;
fncols = Work->fncols ;
fnpiv = Work->fnpiv ;
/* ---------------------------------------------------------------------- */
Rperm = Numeric->Rperm ;
Cperm = Numeric->Cperm ;
/* ---------------------------------------------------------------------- */
Flublock = Work->Flublock ;
Flblock = Work->Flblock ;
Fublock = Work->Fublock ;
Fcblock = Work->Fcblock ;
fnr_curr = Work->fnr_curr ;
fnc_curr = Work->fnc_curr ;
Frpos = Work->Frpos ;
Fcpos = Work->Fcpos ;
Frows = Work->Frows ;
Fcols = Work->Fcols ;
pivrow = Work->pivrow ;
pivcol = Work->pivcol ;
ASSERT (pivrow >= 0 && pivrow < Work->n_row) ;
ASSERT (pivcol >= 0 && pivcol < Work->n_col) ;
#ifndef NDEBUG
Col_degree = Numeric->Cperm ; /* for NON_PIVOTAL_COL macro */
Row_degree = Numeric->Rperm ; /* for NON_PIVOTAL_ROW macro */
#endif
Row_tuples = Numeric->Uip ;
Col_tuples = Numeric->Lip ;
nb = Work->nb ;
#ifndef NDEBUG
ASSERT (fnrows == Work->fnrows_new + 1) ;
ASSERT (fncols == Work->fncols_new + 1) ;
DEBUG1 (("SCALE COL: fnrows "ID" fncols "ID"\n", fnrows, fncols)) ;
DEBUG2 (("\nFrontal matrix, including all space:\n"
"fnr_curr "ID" fnc_curr "ID" nb "ID"\n"
"fnrows "ID" fncols "ID" fnpiv "ID"\n",
fnr_curr, fnc_curr, nb, fnrows, fncols, fnpiv)) ;
DEBUG2 (("\nJust the active part:\n")) ;
DEBUG7 (("C block: ")) ;
UMF_dump_dense (Fcblock, fnr_curr, fnrows, fncols) ;
DEBUG7 (("L block: ")) ;
UMF_dump_dense (Flblock, fnr_curr, fnrows, fnpiv);
DEBUG7 (("U' block: ")) ;
UMF_dump_dense (Fublock, fnc_curr, fncols, fnpiv) ;
DEBUG7 (("LU block: ")) ;
UMF_dump_dense (Flublock, nb, fnpiv, fnpiv) ;
#endif
/* ====================================================================== */
/* === Shift pivot row and column ======================================= */
/* ====================================================================== */
/* ---------------------------------------------------------------------- */
/* move pivot column into place */
/* ---------------------------------------------------------------------- */
/* Note that the pivot column is already in place. Just shift the last
* column into the position vacated by the pivot column. */
fspos = Fcpos [pivcol] ;
/* one less column in the contribution block */
fncols = --(Work->fncols) ;
if (fspos != fncols * fnr_curr)
{
Int fs = fspos / fnr_curr ;
DEBUG6 (("Shift pivot column in front\n")) ;
DEBUG6 (("fspos: "ID" flpos: "ID"\n", fspos, fncols * fnr_curr)) ;
/* ------------------------------------------------------------------ */
/* move Fe => Fs */
/* ------------------------------------------------------------------ */
/* column of the contribution block: */
{
/* Fs: current position of pivot column in contribution block */
/* Fe: position of last column in contribution block */
Int i ;
Entry *Fs, *Fe ;
Fs = Fcblock + fspos ;
Fe = Fcblock + fncols * fnr_curr ;
#pragma ivdep
for (i = 0 ; i < fnrows ; i++)
{
Fs [i] = Fe [i] ;
}
}
/* column of the U2 block */
{
/* Fs: current position of pivot column in U block */
/* Fe: last column in U block */
Int i ;
Entry *Fs, *Fe ;
Fs = Fublock + fs ;
Fe = Fublock + fncols ;
#pragma ivdep
for (i = 0 ; i < fnpiv ; i++)
{
Fs [i * fnc_curr] = Fe [i * fnc_curr] ;
}
}
/* move column Fe to Fs in the Fcols pattern */
col2 = Fcols [fncols] ;
Fcols [fs] = col2 ;
Fcpos [col2] = fspos ;
}
/* pivot column is no longer in the frontal matrix */
Fcpos [pivcol] = EMPTY ;
#ifndef NDEBUG
DEBUG2 (("\nFrontal matrix after col swap, including all space:\n"
"fnr_curr "ID" fnc_curr "ID" nb "ID"\n"
"fnrows "ID" fncols "ID" fnpiv "ID"\n",
fnr_curr, fnc_curr, nb,
fnrows, fncols, fnpiv)) ;
DEBUG2 (("\nJust the active part:\n")) ;
DEBUG7 (("C block: ")) ;
UMF_dump_dense (Fcblock, fnr_curr, fnrows, fncols) ;
DEBUG7 (("L block: ")) ;
UMF_dump_dense (Flblock, fnr_curr, fnrows, fnpiv+1);
DEBUG7 (("U' block: ")) ;
UMF_dump_dense (Fublock, fnc_curr, fncols, fnpiv) ;
DEBUG7 (("LU block: ")) ;
UMF_dump_dense (Flublock, nb, fnpiv, fnpiv+1) ;
#endif
/* ---------------------------------------------------------------------- */
/* move pivot row into place */
/* ---------------------------------------------------------------------- */
fspos = Frpos [pivrow] ;
/* one less row in the contribution block */
fnrows = --(Work->fnrows) ;
DEBUG6 (("Swap/shift pivot row in front:\n")) ;
DEBUG6 (("fspos: "ID" flpos: "ID"\n", fspos, fnrows)) ;
if (fspos == fnrows)
{
/* ------------------------------------------------------------------ */
/* move Fs => Fd */
/* ------------------------------------------------------------------ */
DEBUG6 (("row case 1\n")) ;
/* row of the contribution block: */
{
Int j ;
Entry *Fd, *Fs ;
Fd = Fublock + fnpiv * fnc_curr ;
Fs = Fcblock + fspos ;
#pragma ivdep
for (j = 0 ; j < fncols ; j++)
{
Fd [j] = Fs [j * fnr_curr] ;
}
}
/* row of the L2 block: */
if (Work->pivrow_in_front)
{
Int j ;
Entry *Fd, *Fs ;
Fd = Flublock + fnpiv ;
Fs = Flblock + fspos ;
#pragma ivdep
for (j = 0 ; j <= fnpiv ; j++)
{
Fd [j * nb] = Fs [j * fnr_curr] ;
}
}
else
{
Int j ;
Entry *Fd, *Fs ;
Fd = Flublock + fnpiv ;
Fs = Flblock + fspos ;
#pragma ivdep
for (j = 0 ; j < fnpiv ; j++)
{
ASSERT (IS_ZERO (Fs [j * fnr_curr])) ;
CLEAR (Fd [j * nb]) ;
}
Fd [fnpiv * nb] = Fs [fnpiv * fnr_curr] ;
}
}
else
{
/* ------------------------------------------------------------------ */
/* move Fs => Fd */
/* move Fe => Fs */
/* ------------------------------------------------------------------ */
DEBUG6 (("row case 2\n")) ;
/* this is the most common case, by far */
/* row of the contribution block: */
{
/* Fd: destination of pivot row on U block */
/* Fs: current position of pivot row in contribution block */
/* Fe: position of last row in contribution block */
Entry *Fd, *Fs, *Fe ;
Fd = Fublock + fnpiv * fnc_curr ;
Fs = Fcblock + fspos ;
Fe = Fcblock + fnrows ;
shift_pivot_row (Fd, Fs, Fe, fncols, fnr_curr) ;
}
/* row of the L2 block: */
if (Work->pivrow_in_front)
{
/* Fd: destination of pivot row in LU block */
/* Fs: current position of pivot row in L block */
/* Fe: last row in L block */
Int j ;
Entry *Fd, *Fs, *Fe ;
Fd = Flublock + fnpiv ;
Fs = Flblock + fspos ;
Fe = Flblock + fnrows ;
#pragma ivdep
for (j = 0 ; j <= fnpiv ; j++)
{
Fd [j * nb] = Fs [j * fnr_curr] ;
Fs [j * fnr_curr] = Fe [j * fnr_curr] ;
}
}
else
{
Int j ;
Entry *Fd, *Fs, *Fe ;
Fd = Flublock + fnpiv ;
Fs = Flblock + fspos ;
Fe = Flblock + fnrows ;
#pragma ivdep
for (j = 0 ; j < fnpiv ; j++)
{
ASSERT (IS_ZERO (Fs [j * fnr_curr])) ;
CLEAR (Fd [j * nb]) ;
Fs [j * fnr_curr] = Fe [j * fnr_curr] ;
}
Fd [fnpiv * nb] = Fs [fnpiv * fnr_curr] ;
Fs [fnpiv * fnr_curr] = Fe [fnpiv * fnr_curr] ;
}
/* move row Fe to Fs in the Frows pattern */
row2 = Frows [fnrows] ;
Frows [fspos] = row2 ;
Frpos [row2] = fspos ;
}
/* pivot row is no longer in the frontal matrix */
Frpos [pivrow] = EMPTY ;
#ifndef NDEBUG
DEBUG2 (("\nFrontal matrix after row swap, including all space:\n"
"fnr_curr "ID" fnc_curr "ID" nb "ID"\n"
"fnrows "ID" fncols "ID" fnpiv "ID"\n",
Work->fnr_curr, Work->fnc_curr, Work->nb,
Work->fnrows, Work->fncols, Work->fnpiv)) ;
DEBUG2 (("\nJust the active part:\n")) ;
DEBUG7 (("C block: ")) ;
UMF_dump_dense (Fcblock, fnr_curr, fnrows, fncols) ;
DEBUG7 (("L block: ")) ;
UMF_dump_dense (Flblock, fnr_curr, fnrows, fnpiv+1);
DEBUG7 (("U' block: ")) ;
UMF_dump_dense (Fublock, fnc_curr, fncols, fnpiv+1) ;
DEBUG7 (("LU block: ")) ;
UMF_dump_dense (Flublock, nb, fnpiv+1, fnpiv+1) ;
#endif
/* ---------------------------------------------------------------------- */
/* Frpos [row] >= 0 for each row in pivot column pattern. */
/* offset into pattern is given by: */
/* Frpos [row] == offset - 1 */
/* Frpos [pivrow] is EMPTY */
/* Fcpos [col] >= 0 for each col in pivot row pattern. */
/* Fcpos [col] == (offset - 1) * fnr_curr */
/* Fcpos [pivcol] is EMPTY */
/* Fcols [0..fncols-1] is the pivot row pattern (excl pivot cols) */
/* Frows [0..fnrows-1] is the pivot col pattern (excl pivot rows) */
/* ====================================================================== */
/* === scale pivot column =============================================== */
/* ====================================================================== */
/* pivot column (except for pivot entry itself) */
Fcol = Flblock + fnpiv * fnr_curr ;
/* fnpiv-th pivot in frontal matrix located in Flublock (fnpiv, fnpiv) */
pivot_value = Flublock [fnpiv + fnpiv * nb] ;
/* this is the kth global pivot */
k = Work->npiv + fnpiv ;
DEBUG4 (("Pivot value: ")) ;
EDEBUG4 (pivot_value) ;
DEBUG4 (("\n")) ;
UMF_scale (fnrows, pivot_value, Fcol) ;
/* ---------------------------------------------------------------------- */
/* deallocate the pivot row and pivot column tuples */
/* ---------------------------------------------------------------------- */
UMF_mem_free_tail_block (Numeric, Row_tuples [pivrow]) ;
UMF_mem_free_tail_block (Numeric, Col_tuples [pivcol]) ;
Row_tuples [pivrow] = 0 ;
Col_tuples [pivcol] = 0 ;
DEBUG5 (("number of pivots prior to this one: "ID"\n", k)) ;
ASSERT (NON_PIVOTAL_ROW (pivrow)) ;
ASSERT (NON_PIVOTAL_COL (pivcol)) ;
/* save row and column inverse permutation */
k1 = ONES_COMPLEMENT (k) ;
Rperm [pivrow] = k1 ; /* aliased with Row_degree */
Cperm [pivcol] = k1 ; /* aliased with Col_degree */
ASSERT (!NON_PIVOTAL_ROW (pivrow)) ;
ASSERT (!NON_PIVOTAL_COL (pivcol)) ;
/* ---------------------------------------------------------------------- */
/* Keep track of the pivot order. This is the kth pivot row and column. */
/* ---------------------------------------------------------------------- */
/* keep track of pivot rows and columns in the LU, L, and U blocks */
ASSERT (fnpiv < MAXNB) ;
Work->Pivrow [fnpiv] = pivrow ;
Work->Pivcol [fnpiv] = pivcol ;
/* ====================================================================== */
/* === one step in the factorization is done ============================ */
/* ====================================================================== */
/* One more step is done, except for pending updates to the U and C blocks
* of this frontal matrix. Those are saved up, and applied by
* UMF_blas3_update when enough pivots have accumulated. Also, the
* LU factors for these pending pivots have not yet been stored. */
Work->fnpiv++ ;
#ifndef NDEBUG
DEBUG7 (("Current frontal matrix: (after pivcol scale)\n")) ;
UMF_dump_current_front (Numeric, Work, TRUE) ;
#endif
}
