/* glpgel.c */

/*----------------------------------------------------------------------
-- Copyright (C) 2000, 2001, 2002 Andrew Makhorin <mao@mai2.rcnet.ru>,
--               Department for Applied Informatics, Moscow Aviation
--               Institute, Moscow, Russia. All rights reserved.
--
-- This file is a part of GLPK (GNU Linear Programming Kit).
--
-- GLPK is free software; you can redistribute it and/or modify it
-- under the terms of the GNU General Public License as published by
-- the Free Software Foundation; either version 2, or (at your option)
-- any later version.
--
-- GLPK is distributed in the hope that it will be useful, but WITHOUT
-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public
-- License for more details.
--
-- You should have received a copy of the GNU General Public License
-- along with GLPK; see the file COPYING. If not, write to the Free
-- Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
-- 02111-1307, USA.
----------------------------------------------------------------------*/

#include <float.h>
#include <math.h>
#include <stddef.h>
#include <time.h>
#include "glpgel.h"

/*----------------------------------------------------------------------
-- gel - sparse gaussian elimination.
--
-- *Synopsis*
--
-- #include "glpgel.h"
-- int gel(MAT *V, PER *P, PER *Q,
--    void (*func)(int i, int k, double f), double tol, double lim,
--    int *Unz, double *Umax, double *Ubig, DUFF *rs, DUFF *cs,
--    double rmax[], double work[]);
--
-- *Description*
--
-- The gel routine uses gaussian elimination technique to transform the
-- given sparse matrix V to the upper triangular form.
--
-- The result of the transformation is the matrix V', which are placed
-- instead the input matrix V, and permutation matrices P and Q, which
-- define the upper triangular matrix U = P*V'*Q. Note that the matrix
-- U has implicit representation, therefore all operations are actually
-- performed on the matrix V that differs from U only in the order of
-- rows and columns determined by permutation matrices P and Q.
--
-- To eliminate subdiagonal elements of the matrix U the routine applies
-- to this matrix elementary transformations of the following types: row
-- permutation, column permutation, and subtraction one row multiplied
-- by a number from other row (gaussian transformation). Each time when
-- gaussian transformation is applied to the matrix U (in order to
-- eliminate one subdiagonal element), the gel routine calls the func
-- routine in order that the calling routine would have possibility to
-- accumulate all information about these transformations (information
-- about row and column permutations are accumulated in the matrices P
-- and Q by the gel routine).
--
-- The point where the func routine is called, and the meaning of the
-- parameters passed to this routine can be explained by means of the
-- following general scheme of elimination process:
--
-- for (k = 1; k <= n; k++)
-- {  (* k-th elimination step starts here *)
--    (* choose the pivot element u[p,q] *)
--    p = ...; assert(k <= p <= n);
--    q = ...; assert(k <= q <= n);
--    (* permute rows of the matrix U with numbers k and p *)
--    ...;
--    (* permute columns of the matrix U with numbers k and q *)
--    ...;
--    (* now the pivot element is u[k,k] *)
--    assert(u[k,k] != 0.0);
--    (* eliminate non-zero subdiagonal elements of the matrix U that
--       are placed in k-th column *)
--    for (i = k+1; i <= n; i++)
--    {  (* eliminate subdiagional element u[i,k] *)
--       if (u[i,k] == 0.0) continue;
--       (* compute gaussian multiplier *)
--       f = u[i,k] / u[k,k];
--       (* (i-th row of U) := (i-th row of U) - f * (k-th row of U) *)
--       ...;
--       assert(u[i,k] == 0.0);
--       (* i-th row of the matrix U has been transformed *)
--       func(i, k, f);
--    }
-- }
--
-- Should note that row numbers passed to the func routine correspond to
-- the matrix U (not to V!). The correspondence between row and column
-- numbers of the matrices U = P*V*Q and V is determined by the row
-- permutation matrix P and the column permutation matrix Q. So, if an
-- element u[i,j] of the matrix U corresponds to an element v[i',j'] of
-- the matrix V, the following formulae take a place:
--
-- i' = P->row[i], j' = Q->col[j], i = P->col[i'], j = Q->row[j'].
--
-- The parameter tol is the tolerance used for threshold pivoting. It
-- should be in the range 0 < tol < 1. For more details see remarks for
-- the find_pivot routine.
--
-- The parameter lim specifies maximal allowable growth of elements of
-- the matrix U during elimination process. The process is considered as
-- numerically stable if on each step the following condition is true:
--
-- Ubig <= lim * Umax
--
-- (description of the parameters Umax and Ubig are given below).
--
-- Before a call the variable Unz should define the total number of
-- non-zeros in the source matrix U. After a call this variable will
-- define the total number of non-zeros in the transformed matrix U'.
-- (If before a call Unz is set to zero, after a call Unz will define
-- the difference between total numbers of non-zeros in the matrices
-- U' and U.)
--
-- The variables Umax and Ubig are ignored before a call. After a call
-- the variable Umax will contain the maximum of absolute values of
-- elements of the source matrix U, and the variable Ubig will contain
-- the maximum of absolute values of those elements, which appeared in
-- the matrix U during elimination process.
--
-- The parameters rs and cs should define Duff schemes used to keep
-- the lists of active rows and columns. Before a call these schemes
-- may contain arbitrary information that is ignored. In the case of
-- error (see below) after a call these schemes will contain active
-- rows and columns of the matrix V (not U!). These schemes should be
-- created by calls rs = create_duff(n, n) and cs = create_duff(n, n),
-- where n is the order of the matrix V.
--
-- The auxiliary arrays rmax and work should have at least 1+n elements,
-- where n is the order of the matrix V.
--
-- *Returns*
--
-- The gel routine returns one of the following error codes:
--
--  0 - no errors;
-- -k - on k-th elimination step pivot can't be chosen because all
--      elements of the active submatrix are zeros;
-- +k - on k-th elimination step numerical stability condition (see
--      above) has been violated. */

static int debug = 0;
/* debug mode flag */

static MAT *V;
/* sparse matrix V that should be transformed */

static PER *P;
/* left permutation matrix P */

static PER *Q;
/* right permutation matrix Q */

static int n;
/* order of matrices P, V, Q, and U = P*V*Q */

static int k;
/* the number of elimination step */

static void (*func)(int i, int k, double f);
/* external routine that accumulates elementary transformations applied
   to the matrix U */

static double tol;
/* tolerance used for pivot choosing */

static double lim;
/* maximal allowable relative growth of elements of the matrix U */

static int Unz;
/* count of non-zero elements of the matrix U */

static double Umax;
/* maximum of absolute values of elements of the matrix U (or of its
   initial active submatrix) */

static double Ubig;
/* maximum of absolute values of elements appeared in the matrix U (or
   in its initial active submatrix) */

static DUFF *rs, *cs;
/* lists of the numbers of rows and columns of the matrix V that belong
   to the active submatrix before k-th elimination step */

static double *rmax; /* double rmax[1+n]; */
/* if i-th row of the matrix V belongs to the active submatrix, rmax[i]
   is maximum of absolute values of elements in i-th row */

static double *work; /* double work[1+n]; */
/* auxiliary array of the eliminate routine */

#define iU(i) (P->col[i])
/* converts row number of V to row number of U */

#define iV(i) (P->row[i])
/* converts row number of U to row number of V */

#define jU(j) (Q->row[j])
/* converts column number of V to column number of U */

#define jV(j) (Q->col[j])
/* converts column number of U to column number of V */

#define include_row(i, nz) include_obj(rs, i, nz)
#define include_col(j, nz) include_obj(cs, j, nz)
#define exclude_row(i)     exclude_obj(rs, i)
#define exclude_col(j)     exclude_obj(cs, j)

static void check_data(void);
/* check main data structures for correctness */

static ELEM *find_pivot(void);
/* choose pivot element */

static void eliminate(ELEM *piv);
/* eliminate subdiagonal elements */

int gel(MAT *_V, PER *_P, PER *_Q,
      void (*_func)(int i, int k, double f), double _tol, double _lim,
      int *_Unz, double *_Umax, double *_Ubig, DUFF *_rs, DUFF *_cs,
      double _rmax[], double _work[])
{     ELEM *piv, *e;
      int i, j, p, q, nz, ret = 0;
      double big;
      /* initialization */
      V = _V; P = _P; Q = _Q; n = V->m;
      func = _func; tol = _tol; lim = _lim;
      Unz = *_Unz; Umax = 0.0; Ubig = 0.0;
      rs = _rs; cs = _cs; rmax = _rmax; work = _work;
      if (V->m != V->n)
         fault("gel: transformed matrix is not square");
      if (!(P->n == n && Q->n == n))
         fault("gel: permutation matrices have invalid order");
      /* reset permutation matrices, because initially U = V */
      reset_per(P);
      reset_per(Q);
      /* build lists of (active) rows of the matrix V, compute Umax and
         Ubig, and fill elements of the array rmax */
      reset_duff(rs);
      for (i = 1; i <= n; i++)
      {  /* count non-zeros in i-th row of the matrix V and determine
            the maximum of absolute values of elements in this row */
         nz = 0;
         big = 0.0;
         for (e = V->row[i]; e != NULL; e = e->row)
         {  if (e->val == 0.0)
               fault("gel: transformed matrix has invalid pattern");
            nz++;
            if (big < fabs(e->val)) big = fabs(e->val);
         }
         /* include i-th row to the active list */
         include_row(i, nz);
         /* store the value max|v[i,*]| for this active row */
         rmax[i] = big;
         /* update the value max|u[*,*]| */
         if (Umax < big) Umax = Ubig = big;
      }
      /* build lists of (active) columns of the matrix V */
      reset_duff(cs);
      for (j = 1; j <= n; j++)
      {  /* count non-zeros in j-th column of the matrix V */
         nz = 0;
         for (e = V->col[j]; e != NULL; e = e->col) nz++;
         /* include j-th column to the active list */
         include_col(j, nz);
      }
      /* clear auxiliary array */
      for (j = 1; j <= n; j++) work[j] = 0.0;
      /* main loop of gaussian elimination */
      for (k = 1; k <= n; k++)
      {  /* the goal of k-th step is to nullify subdiagonal elements
            placed in k-th column of the matrix U */
         check_data();
         /* choose pivot element u[p,q] */
         piv = find_pivot();
         if (piv == NULL)
         {  /* all elements of the active submatrix are zero */
            ret = -k;
            goto done;
         }
         /* piv = v[i,j] = u[p,q] */
         p = iU(piv->i), q = jU(piv->j);
         insist(k <= p && p <= n && k <= q && q <= n);
         insist(piv->val != 0.0);
         /* perform implicit permutations of rows and columns of the
            matrix U in order to move the pivot element from u[p,q] to
            u[k,k] */
         {  int t1, t2;
            /* permute k-th and p-th rows of the matrix U */
            t1 = iV(k); t2 = iV(p);
            iV(k) = t2; iU(t2) = k;
            iV(p) = t1; iU(t1) = p;
            /* permute k-th and q-th columns of the matrix U */
            t1 = jV(k); t2 = jV(q);
            jV(k) = t2; jU(t2) = k;
            jV(q) = t1; jU(t1) = q;
         }
         /* eliminate subdiagonal elements in k-th column of the matrix
            U using the pivot element u[k,k] */
         eliminate(piv);
         *_Unz = Unz; *_Umax = Umax; *_Ubig = Ubig;
         if (Ubig > lim * Umax)
         {  /* elements of the matrix U are growing too intense */
            ret = +k;
            goto done;
         }
      }
      check_data();
done: /* return to the calling program */
      return ret;
}

/*----------------------------------------------------------------------
-- check_data - check main data structures for correctness.
--
-- This routine checks the correctness of the main data structures
-- before k-th elimination step. The following conditions are checked:
--
-- 1. Matrices V, P, and Q should have correct representations.
--
-- 2. Matrix U = P*V*Q should be the following:
--
--    1       k         n
-- 1  x x x x x x x x x x
--    . x x x x x x x x x
--    . . x x x x x x x x
--    . . . x x x x x x x
-- k  . . . . * * * * * *
--    . . . . * * * * * *
--    . . . . * * * * * *
--    . . . . * * * * * *
--    . . . . * * * * * *
-- n  . . . . * * * * * *
--
-- (elements of the active submatrix are marked by '*').
--
-- 3. All zeros of the matrix V should be symbolic zeros.
--
-- 4. Rows and columns of the matrix V corresponding to the rows and
--    columns 1, 2, ..., k-1 of the matrix U should be missing from the
--    active lists, and rows and columns of V corresponding to the rows
--    and columns k, k+1, ..., n should be placed in the active lists.
--    In the latter case counters of the active rows and columns should
--    correctly reflect the number of non-zeros in the active submatrix.
--
-- 5. Maximums of absolute values of elements of the active rows of the
--    matrix V should be stored in the array rmax.
--
-- This routine allows a call when k = m+1 in order to check the
-- correctness of the main data structures after the last elimination
-- step. */

static void check_data(void)
{     ELEM *e;
      int i, j, nz;
      double big;
      if (!debug) goto skip;
      insist(1 <= k && k <= n+1);
      check_mat(V);
      check_per(P);
      check_per(Q);
      /* check for rows */
      for (i = 1; i <= n; i++)
      {  if (i < k)
         {  /* i-th row of U is placed above the active submatrix */
            for (e = V->row[iV(i)]; e != NULL; e = e->row)
            {  j = jU(e->j);
               insist(j >= i);
               insist(e->val != 0.0);
            }
            insist(rs->len[iV(i)] < 0);
         }
         else
         {  /* i-th row of U belongs to the active submatrix */
            nz = 0;
            big = 0.0;
            for (e = V->row[iV(i)]; e != NULL; e = e->row)
            {  j = jU(e->j);
               insist(j >= k);
               insist(e->val != 0.0);
               nz++;
               if (big < fabs(e->val)) big = fabs(e->val);
            }
            insist(rs->len[iV(i)] == nz);
            insist(rmax[iV(i)] == big);
         }
      }
      /* check for columns */
      for (j = 1; j <= n; j++)
      {  if (j < k)
         {  /* j-th column of U is placed left the active submatrix */
            for (e = V->col[jV(j)]; e != NULL; e = e->col)
            {  i = iU(e->i);
               insist(i <= j);
               insist(e->val != 0.0);
            }
            insist(cs->len[jV(j)] < 0);
         }
         else
         {  /* j-th column of U belongs to the active submatrix */
            nz = 0;
            for (e = V->col[jV(j)]; e != NULL; e = e->col)
            {  i = iU(e->i);
               insist(e->val != 0.0);
               if (i >= k) nz++;
            }
            insist(cs->len[jV(j)] == nz);
         }
      }
skip: return;
}

/*----------------------------------------------------------------------
-- find_pivot - choose pivot element.
--
-- This routine chooses a pivot element in the active submatrix of the
-- matrix U = P*V*Q and returns a pointer to the chosen element (the
-- routine returns NULL, if appropriate element cannot be chosen; see
-- below).
--
-- It is assumed that on a call the matrix U is the following:
--
--    1       k         n
-- 1  x x x x x x x x x x
--    . x x x x x x x x x
--    . . x x x x x x x x
--    . . . x x x x x x x
-- k  . . . . * * * * * *
--    . . . . * * * * * *
--    . . . . * * * * * *
--    . . . . * * * * * *
--    . . . . * * * * * *
-- n  . . . . * * * * * *
--
-- where rows and columns with numbers k, k+1, ..., n from the active
-- submatrix (elements of this submatrix are marked by '*').
--
-- Each active row of the matrix V should be in the list R[nz], where
-- nz is the number of non-zeros in that row. Analogously, each active
-- column should be in the list C[nz], where nz is the number of
-- non-zeros in that column (except elements missing from the active
-- submatrix). If i-th row of the matrix V is active, the element
-- rmax[i] should contain the maximum of absolute values of elements in
-- this row.
--
-- In order that computations to be numerically stable the routine uses
-- so called threshold pivoting proposed by J.Reid. The element u[i,j]
-- satisfies to the stability condition if it is not very small among
-- other elements in the same row, i.e. if |u[i,j]| >= tol * max|u[i,*]|
-- where 0 < tol < 1 is the given tolerance.
--
-- In order to preserve sparsity of the matrix U the routine uses the
-- Markowitz strategy, trying to choose such element u[i,j], which
-- satisfies to the stability condition (see above) and also has the
-- smallest Markowitz cost (nr[i]-1) * (nc[j]-1), where nr[i] and nc[j]
-- are the number of non-zeros in i-th row and in j-th column resp. of
-- the active submatrix of the matrix U.
--
-- In order to reduce the search in active rows and columns (i.e. in
-- order not to look through entire active submatrix) the routine uses
-- the technique proposed by I.Duff. If there is a column or a row that
-- contains exactly one non-zero element (singlet), the routine chooses
-- such element at once. Otherwise the routine continues the search for
-- nz = 2, 3, ..., n, analyzing at each step those rows and columns that
-- contain nz non-zeros in the active submatrix. The routine stops the
-- search in the following two cases: (a) if all columns containing nz
-- non-zeros were analyzed and best <= nz * (nz-1), or (b) if all rows
-- containing nz non-zeros were analyzed and best <= (nz-1) * (nz-1),
-- where best = (nr[i]-1) * (nc[j]-1) is best (smallest) Markowitz cost,
-- that was reached for some element u[i,j], which the routine chooses
-- as the pivot element. Such partial pivoting is able to reduce the
-- search keeping good sparsity for the most practical cases.
--
-- If all elements of the active submatrix are zero and it is impossible
-- to choose the pivot element, the routine returns NULL.
--
-- The main data structures should satisfy the same conditions, which
-- are checked by the routine check_data. */

static ELEM *find_pivot(void)
{     ELEM *piv = NULL, *e;
      int i, j, nz;
      double best = DBL_MAX, cost;
      insist(1 <= k && k <= n);
      /* if there is a column containing exactly one non-zero in the
         active submatrix (all such columns are in the list C[1]), the
         corresponding element may be chosen as pivot. */
      j = cs->head[1];
      if (j != 0)
      {  /* j-th column contains column singlet, but this column may
            contain other elements that are not belong to the active
            submatrix (in the matrix U all such elements are placed
            above k-th row), so singlet should be found */
         for (piv = V->col[j]; piv != NULL; piv = piv->col)
            if (iU(piv->i) >= k) break;
         insist(piv != NULL);
         goto done;
      }
      /* if there is a row containing exactly one non-zero in the
         active submatrix (all such rows are in the list R[1]), the
         corresponding element may be chosen as pivot */
      i = rs->head[1];
      if (i != 0)
      {  /* i-th row contains row singlet (there should be no other
            elements in this row) */
          piv = V->row[i];
          insist(piv != NULL && piv->row == NULL);
          goto done;
      }
      /* main loop for searching for pivot */
      for (nz = 2; nz <= n; nz++)
      {  /* look up columns from the list C[nz] */
         for (j = cs->head[nz]; j != 0; j = cs->next[j])
         {  /* j-th column contains exactly nz non-zeros in the active
               submatrix */
            for (e = V->col[j]; e != NULL; e = e->col)
            {  i = e->i;
               /* if v[i,j] is not in the active submatrix, it should
                  be skipped */
               if (iU(i) < k) continue;
               /* if v[i,j] doesn't satisfy to the numerical stability
                  condition, it should be skipped */
               if (fabs(e->val) < tol * rmax[i]) continue;
               /* compute Markowitz cost of v[i,j] */
               cost = (double)(rs->len[i] - 1) * (double)(nz - 1);
               /* decide, whether v[i,j] fits to be pivot */
               if (piv == NULL || best > cost ||
                  best == cost && fabs(piv->val) < fabs(e->val))
                     piv = e, best = cost;
            }
            /* check Duff's criterion to terminate searching */
            if (best <= (double)(nz) * (double)(nz - 1)) goto done;
         }
         /* look up rows from the list R[nz] */
         for (i = rs->head[nz]; i != 0; i = rs->next[i])
         {  /* i-th row contains exactly nz non-zeros in the active
               submatrix */
            for (e = V->row[i]; e != NULL; e = e->row)
            {  j = e->j;
               /* v[i,j] is always in the active submatrix */
               insist(jU(j) >= k);
               /* if v[i,j] doesn't satisfy to the numerical stability
                  condition, it should be skipped */
               if (fabs(e->val) < tol * rmax[i]) continue;
               /* compute Markowitz cost of v[i,j] */
               cost = (double)(nz - 1) * (double)(cs->len[j] - 1);
               /* decide, whether v[i,j] fits to be pivot */
               if (piv == NULL || best > cost ||
                  best == cost && fabs(piv->val) < fabs(e->val))
                     piv = e, best = cost;
            }
            /* check Duff's criterion to terminate searching */
            if (best <= (double)(nz - 1) * (double)(nz - 1)) goto done;
         }
      }
done: if (piv != NULL)
      {  /* the chosen pivot should be in the active submatrix */
         insist(k <= iU(piv->i) && iU(piv->i) <= n);
         insist(k <= jU(piv->j) && jU(piv->j) <= n);
      }
      return piv;
}

/*----------------------------------------------------------------------
-- eliminate - eliminate subdiagonal elements.
--
-- This routine performs gaussian elimination to nullify subdiagonal
-- elements of the matrix U = P*V*Q that are placed in the pivot (k-th)
-- column. The piv parameter points to the pivot element u[k,k].
--
-- It is assumed that before a call the matrix U is the following:
--
--    1       k         n
-- 1  x x x x x x x x x x
--    . x x x x x x x x x
--    . . x x x x x x x x
--    . . . x x x x x x x
-- k  . . . . * * * * * *
--    . . . . # * * * * *
--    . . . . # * * * * *
--    . . . . # * * * * *
--    . . . . # * * * * *
-- n  . . . . # * * * * *
--
-- where rows and columns k, k+1, ..., n belong to the active submatrix
-- (eliminated elements are marked by '#', other elements of the active
-- submatrix are marked by '*').
--
-- (Since the matrix U has implicit representation, all transformations
-- are performed actually on the matrix V, which differs from the matrix
-- U only in the order of rows and columns.)
--
-- The auxiliary array work is used as an accumulator and before a call
-- it should contain zeros. The routine remains this array in the same
-- state after a call.
--
-- Let u[k,k] = v[p,q] is the pivot element. To eliminate subdiagonals
-- elements u[i',k] = v[i,q], i' = k+1, k+2, ..., n, the routine applies
-- the following gaussian transformation:
--
-- (i-th row of V) := (i-th row of V) - f[i] * (p-th row of V),
--
-- where f[i] = v[i,q]/v[p,q] is gaussian multiplier, and the
-- correspondence between row numbers i and i' is determined by the
-- permutation matrix P.
--
-- The main data structures should satisfy the same conditions, which
-- are checked by the routine check_data. After a call these conditions
-- will also take a place. */

static void eliminate(ELEM *piv)
{     ELEM *v, *vn, *e, *en, *ep;
      int i, j, k, p, q, count, nz;
      double f, big, drop = 1e-15;
      insist(piv != NULL && piv->val != 0.0);
      /* determine the pivot v[p,q] = u[k,k] */
      p = piv->i;
      q = piv->j;
      k = iU(p);
      insist(k == jU(q));
      /* main elimination loop */
      for (v = V->col[q]; v != NULL; v = v->col)
      {  i = v->i;
         /* if v[i,q] = u[i',k], where i' <= k, this element needn't to
            be eliminated (because it is placed on the main diagonal of
            the matrix U or above that diagonal) */
         if (iU(i) <= k) continue;
         /* compute gaussian multiplier f = v[i,q]/v[p,q] */
         f = v->val / piv->val;
         /* work := (i-th row of V) */
         for (e = V->row[i]; e != NULL; e = e->row)
            work[e->j] = e->val;
         /* work := work - f * (p-th row of V) */
         for (e = V->row[p]; e != NULL; e = e->row)
            work[e->j] -= f * e->val;
         /* the eliminated element v[i,q] should become exact zero */
         work[q] = 0.0;
         /* now new elements of i-th row of the matrix V are placed in
            the array work */
         /* replace existing elements of i-th row */
         big = 0.0; /* is a new value of max|v[i,*]| */
         for (e = V->row[i]; e != NULL; e = e->row)
         {  j = e->j;
            /* if |v[i,j]| < drop * max|v[i,*]|, where drop is relative
               drop tolerance, the element v[i,j] can be replaced by
               exact zero; this slightly decreases accuracy but allows
               to improve sparsity */
            if (fabs(work[j]) < drop * rmax[i]) work[j] = 0.0;
            /* replace element v[i,j] */
            if (big < fabs(work[j])) big = fabs(work[j]);
            e->val = work[j], work[j] = 0.0;
         }
         /* create new elements, which appeared in i-th row as a result
            of elimination */
         count = 0; /* number of new elements of i-th row */
         for (e = V->row[p]; e != NULL; e = e->row)
         {  j = e->j;
            /* (see notice above) */
            if (fabs(work[j]) < drop * rmax[i]) work[j] = 0.0;
            if (work[j] == 0.0) continue;
            /* create new (non-zero) element v[i,j] */
            if (big < fabs(work[j])) big = fabs(work[j]);
            new_elem(V, i, j, work[j]), Unz++, work[j] = 0.0;
            /* number of elements in i-th row and in j-th column now is
               increased by one */
            count++;
            nz = cs->len[j];
            exclude_col(j), include_col(j, nz+1);
         }
         if (count != 0)
         {  nz = rs->len[i];
            exclude_row(i), include_row(i, nz+count);
         }
         /* (now the array work again contains all zeros) */
         /* update the maximum max|v[i,*]| */
         rmax[i] = big;
         /* update the relative growth of elements of the matrix U
            during elimination */
         if (Ubig < big) Ubig = big;
         /* i-th row of the matrix V has been transformed */
         if (func != NULL) func(iU(i), k, f);
      }
      /* now all zeros appeared in the active submatrix as a result of
         elimination should be removed */
      /* most of zeros are usually placed in the q-th (pivot) column of
         the matrix V, since in other columns zeros can appear only as
         a result of numerical cancellation that happens relatively
         seldom (except some specific cases). To reduce number of passes
         through the pivot column this operations is performed in the
         following way. The outermost loop scans the pivot (q-th) column
         and removes all v[i,q] = 0 from the corresponding column list,
         so to remove most of zeros only one pass through the pivot
         column is needed. The middle loop scans each i-th row, where
         v[i,q] = 0 (this condition can take a place if and only if the
         i-th row was touched by elimination, hence this row can contain
         other zeros), and removes all v[i,j] = 0 from the corresponding
         row lists. The innermost loop scans each j-th column (except
         q-th column), where v[i,j] = 0, in order to remove these zeros
         from the corresponding column lists (so, to remove one zero
         from j-th column one pass of this column is needed) */
      for (v = V->col[q], V->col[q] = NULL; v != NULL; v = vn)
      {  vn = v->col;
         if (v->val != 0.0)
         {  /* element v[i,q] is non-zero, so it stays in the list of
               q-th column */
            v->col = V->col[q], V->col[q] = v;
            continue;
         }
         i = v->i;
         /* element v[i,q] is zero, hence i-th row was touched by
            elimination and can contain other zeros */
         count = 0; /* number of zeros placed in i-th row */
         for (e = V->row[i], V->row[i] = NULL; e != NULL; e = en)
         {  en = e->row;
            if (e->val != 0.0)
            {  /* element v[i,j] is non-zero, so it stays in the list
                  of i-th row */
               e->row = V->row[i], V->row[i] = e;
               continue;
            }
            j = e->j;
            /* element v[i,j] is zero */
            count++;
            /* remove this zero from the list of j-th column (but only
               if j != q, since zeros from the pivot column are removed
               in the outermost loop) */
            if (j == q) continue;
            if (V->col[j] == e)
               V->col[j] = e->col;
            else
            {  for (ep = V->col[j]; ep != NULL; ep = ep->col)
                  if (ep->col == e) break;
               insist(ep != NULL);
               ep->col = e->col;
            }
            /* return v[i,j] to the memory pool */
            free_atom(V->pool, e), Unz--;
            /* one element was removed from j-th column */
            nz = cs->len[j];
            exclude_col(j), include_col(j, nz-1);
         }
         /* number of elements in i-th row is decreased */
         if (count != 0)
         {  nz = rs->len[i];
            exclude_row(i), include_row(i, nz-count);
         }
         /* returns v[i,q] to the memory pool (in this case it is not
            needed to update number of zeros in q-th column, because
            this column will be removed from the corresponding active
            list) */
         free_atom(V->pool, v), Unz--;
      }
      /* k-th elimination step is finished, so the pivot (p-th) row and
         the pivot (q-th) column of the matrix V should be removed from
         the active lists; since the deletion of the pivot row involves
         the deletion of all its elements from the active submatrix,
         the corresponding column counters should be decreased (this is
         not needed for the corresponding row counters, because now all
         subdiagonal elements of the pivot row are zeros) */
      for (e = V->row[p]; e != NULL; e = e->row)
      {  j = e->j;
         /* element v[p,j] left the active submatrix, so the counter of
            j-th column should be decreased */
         nz = cs->len[j];
         exclude_col(j), include_col(j, nz-1);
      }
      /* remove the pivot row and the pivot column of the matrix V from
         the active lists */
      exclude_row(p), exclude_col(q);
      return;
}

/*----------------------------------------------------------------------
-- gel_bg - sparse gaussian elimination (Bartels & Golub technique).
--
-- *Synopsis*
--
-- #include "glpgel.h"
-- int gel_bg(PER *P, MAT *V, PER *Q, int k1, int k2,
--    void (*func)(int i, int k, double f), double tol, double eps,
--    int *Unz, double work[]);
--
-- *Description*
--
-- The gel_bg routine uses Bartels & Golub version of the gaussian
-- elimination technique to transform the matrix U = P*V*Q to the upper
-- triangular form, where V is the given sparse matrix, P and Q are the
-- given permutation matrices.
--
-- (The matrix U has implicit representation, therefore all operations
-- are actually performed on the matrix V, that differs from U only in
-- the order of rows and columns determining by the permutation matrices
-- P and Q.)
--
-- It is assumed that on entry the matrix U has the following special
-- structure:
--
--     1   k1       k2   n
-- 1   x x x x x x x x x x
--     . x x x x x x x x x
-- k1  . . * * * * * * * *
--     . . * * * * * * * *
--     . . * . * * * * * *
--     . . * . . * * * * *
--     . . * . . . * * * *
-- k2  . . * . . . . * * *
--     . . . . . . . . x x
-- n   . . . . . . . . . x
--
-- Hence only the submatrix with rows k1, k1+1, ..., k2 and columns
-- k1, k1+1, ..., n should be transformed (elements of this submatrix
-- are marked by '*', all other elements of the matrix U are marked by
-- 'x').
--
-- The result of the transformation is the matrices P', V', and Q' that
-- define the upper triangular matrix U' = P'*V'*Q' (these new matrices
-- are stored instead the source matrices P, V, and Q).
--
-- To eliminate subdiagonal elements of the matrix U the routine applies
-- to this matrix elementary transformations of the following types: row
-- permutation, column permutation, and subtraction one row multiplied
-- by a number from other row (gaussian transformation). Each time when
-- gaussian transformation is applied to the matrix U (in order to
-- eliminate one subdiagonal element), the gel_bg routine calls the func
-- routine in order that the calling routine would have possibility to
-- accumulate all information about these transformations (information
-- about row and column permutations are accumulated in the matrices P
-- and Q by the gel_bg routine).
--
-- The point where the func routine is called, and the meaning of the
-- parameters passed to this routine can be explained by means of the
-- following general scheme of elimination process.
--
-- Before elimination the routine shifts columns k1+1, k1+2, ..., k2 of
-- the matrix U by one position to the left and moves the column k1 to
-- the position k2. As a result the matrix U becomes an upper Hessenberg
-- matrix (elements which should be eliminated are marked by '#'):
--
--     1   k1       k2   n
-- 1   x x x x x x x x x x
--     . x x x x x x x x x
-- k1  . . * * * * * * * *
--     . . # * * * * * * *
--     . . . # * * * * * *
--     . . . . # * * * * *
--     . . . . . # * * * *
-- k2  . . . . . . # * * *
--     . . . . . . . . x x
-- n   . . . . . . . . . x
--
-- Then the routine uses gaussian elimination to nullify all subdiagonal
-- elements of the matrix U.
--
-- Bartels & Golub technique assumes partial pivoting in the active
-- (leftmost) column of the active submatrix. Before k-th elimination
-- step (k = k1, k1+1, ..., k2-1) k-th (active) column of the active
-- submatrix has only one subdiagonal element, hence the choice of the
-- pivot is limited only by two elements u[k,k] and u[k+1,k]. In the
-- original Bartels & Golub proposes to choose that element which has
-- largest magnitude for the sake of good numerical stability. However
-- the gel_bg routine tries to improve the sparsity of the matrix U,
-- possibly at the expense of accuracy. The following heuristic rule is
-- used by the routine, where the parameter tol (0 < tol < 1) is the
-- given tolerance:
--
-- if |u[k+1,k]| < tol * |u[k,k]|, the routine chooses u[k,k];
--
-- if |u[k,k]| < tol * |u[k+1,k]|, the routine chooses u[k+1,k];
--
-- in other cases the routine chooses u[k,k] or u[k+1,k] depending on
-- which one has less non-zeros.
--
-- (Therefore the original Bartels & Golub technique corresponds to the
-- case when tol = 1.)
--
-- So, the general scheme of the elimination process is the following:
--
-- (* permute columns of the matrix U *)
-- ...;
-- for (k = k1; k < k2; k++)
-- {  (* k-th elimination step starts here *)
--    (* choose the pivot element u[k,k] or u[k+1,k] *)
--    ...;
--    (* if u[k+1,k] has been chosen, permute rows k and k+1 of the
--       matrix U *)
--    if (...) ...;
--    (* now the pivot element is u[k,k] *)
--    assert(u[k,k] != 0.0);
--    (* eliminate non-zero subdiagonal element u[k+1,k] *)
--    i = k+1;
--    if (u[i,k] == 0.0) continue;
--    (* compute gaussian multiplier *)
--    f = u[i,k] / u[k,k];
--    (* (i-th row of U) := (i-th row of U) - f * (k-th row of U) *)
--    ...;
--    assert(u[i,k] == 0.0);
--    (* i-th row of the matrix U has been transformed *)
--    func(i, k, f);
-- }
-- assert(u[k2,k2] != 0.0);
--
-- Should note that row numbers passed to the func routine correspond to
-- the matrix U (not to V!). The correspondence between row and column
-- numbers of the matrices U = P*V*Q and V is determined by the row
-- permutation matrix P and the column permutation matrix Q. So, if an
-- element u[i,j] of the matrix U corresponds to an element v[i',j'] of
-- the matrix V, the following formulae take a place:
--
-- i' = P->row[i], j' = Q->col[j], i = P->col[i'], j = Q->row[j'].
--
-- The parameter eps is the given tolerance used for checking diagonal
-- elements of the transformed matrix U'. The performed transformation
-- is considered to be satisfactory (from the numerical point of view)
-- if the following condition is true for all diagonal elements of the
-- matrix U':
--
-- |u'[k,k]| >= eps * max|u'[k,*]| > 0,
--
-- i.e. if each diagonal element of the matrix U' is non-zero and it is
-- not too small among other elements in the same row. (This condition
-- gives some guarantee that the solution of the system with the matrix
-- U' will be relatively accurate.)
--
-- Should note that the mentioned condition is checked only for rows
-- k1, k1+1, ..., k2.
--
-- On entry the variable Unz should define the total number of non-zeros
-- in the source matrix U. On exit this variable will define the total
-- number of non-zeros in the transformed matrix U'. (If on entry Unz is
-- set to zero, on exit Unz will define the difference between total
-- numbers of non-zeros in the matrices U' and U.)
--
-- The auxiliary array work should have at least n elements, where n is
-- the order of the matrix U.
--
-- *Returns*
--
-- The gel_bg routine returns one of the following error codes:
--
--  0 - no errors;
-- -k - if k1 <= k < k2, on k-th elimination step both elements u[k,k]
--      and u[k+1,k] are found equal to zero; if k = k2, after the last
--      elimination step the element u[k2,k2] is found equal to zero;
-- +k - if k1 <= k < k2, on k-th elimination step numerical stability
--      condition (see above) has been violated; if k = k2, this
--      condition has been violated for the element u[k2,k2].
--
-- Should note that if the matrix U passed to the gel_bg routine is
-- already a result of preceding transformations of some initial matrix
-- U0, the appearence of numerical errors in this routine is usually
-- connected with all sequence of transformations. Hence in such case
-- instead this routine the general gaussian elimination should be
-- applied directly to the initial matrix U0.
--
-- *Reference*
--
-- Bartels R.H., Golub G.H. The simplex method of linear programming
-- using LU decomposition. Comm. ACM, 12 (1969), pp. 266-68. */

#define iU(i) (P->col[i])
/* converts row number of V to row number of U */

#define iV(i) (P->row[i])
/* converts row number of U to row number of V */

#define jU(j) (Q->row[j])
/* converts column number of V to column number of U */

#define jV(j) (Q->col[j])
/* converts column number of U to column number of V */

int gel_bg(PER *P, MAT *V, PER *Q, int k1, int k2,
      void (*func)(int i, int k, double f), double tol, double eps,
      int *Unz, double work[])
{     ELEM *vpq, *viq, *e, *ee, *en;
      int n = V->m, i, j, k, p, q, nz1, nz2, ret = 0;
      double rmax1, rmax2, f, drop = 1e-15;
      if (V->m != V->n)
         fault("gel_bg: transformed matrix is not square");
      if (!(P->n == n && Q->n == n))
         fault("gel_bg: permutation matrices have invalid order");
      if (!(1 <= k1 && k1 <= k2 && k2 <= n))
         fault("gel_bg: initial active submatrix has invalid position");
      /* shift columns k1+1, k1+2, ..., k2 of the matrix U to the left
         by one position and move the column k1 to the position k2 */
      for (k = k1; k < k2; k++)
      {  /* permute columns k and k+1 of the matrix U */
         int t1, t2;
         t1 = jV(k); t2 = jV(k+1);
         jV(k)   = t2; jU(t2) = k;
         jV(k+1) = t1; jU(t1) = k+1;
      }
      /* clear auxiliary array */
      for (j = 1; j <= n; j++) work[j] = 0.0;
      /* main loop of gaussian elimination */
      for (k = k1; k < k2; k++)
      {  /* the goal of k-th step is to nullify the subdiagonal element
            u[k+1,k] */
         p = iV(k);   /* k-th row of U    = p-th row of V */
         q = jV(k);   /* k-th column of U = q-th column of V */
         i = iV(k+1); /* k+1-th row of U  = i-th row of V */
         /* search for element u[k,k] = v[p,q], count non-zero elements,
            and determine largest of absolute values of elements in k-th
            row of the matrix U */
         vpq = NULL; nz1 = 0; rmax1 = 0.0; /* = max|v[p,*]| */
         for (e = V->row[p]; e != NULL; e = e->row)
         {  if (jU(e->j) < k || e->val == 0.0)
err:           fault("gel_bg: transformed matrix has invalid pattern");
            if (e->j == q) vpq = e;
            nz1++;
            if (rmax1 < fabs(e->val)) rmax1 = fabs(e->val);
         }
         /* search for element u[k+1,k] = v[i,q], count non-zeros, and
            determine largest of absolute values of elements in k+1-th
            row of the matrix U */
         viq = NULL; nz2 = 0; rmax2 = 0.0; /* = max|v[i,*]| */
         for (e = V->row[i]; e != NULL; e = e->row)
         {  if (jU(e->j) < k || e->val == 0.0) goto err;
            if (e->j == q) viq = e;
            nz2++;
            if (rmax2 < fabs(e->val)) rmax2 = fabs(e->val);
         }
         /* if u[k,k] = u[k+1,k] = 0, it's impossible to choose the
            pivot element */
         if (vpq == NULL && viq == NULL)
         {  ret = -k;
            goto done;
         }
         /* if u[k+1,k] = 0 then u[k,k] != 0; hence only checking the
            numerical stability condition is needed */
         if (viq == NULL) goto chk;
         /* if u[k,k] = 0 then u[k+1,k] != 0; hence permutation k-th
            and k+1-th rows of the matrix U and checking the numerical
            stability condition are needed */
         if (vpq == NULL) goto per;
         /* if |u[k+1,k]| < tol * |u[k,k]|, the element u[k,k] should
            be chosen as pivot */
         if (fabs(viq->val) < tol * fabs(vpq->val)) goto chk;
         /* if |u[k,k]| < tol * |u[k+1,k]|, the element u[k+1,k] should
            be chosen as pivot */
         if (fabs(vpq->val) < tol * fabs(viq->val)) goto per;
         /* use freedom to choose u[k,k] or u[k+1,k] depending which
            row (k-th or k+1-th) has less non-zeros */
         if (nz1 <= nz2) goto chk;
per:     /* permute k-th and k+1-th rows of the matrix U */
         p = iV(k+1); i = iV(k);
         iV(k)   = p; iU(p) = k;
         iV(k+1) = i; iU(i) = k+1;
         e = vpq; vpq = viq; viq = e;
         f = rmax1; rmax1 = rmax2; rmax2 = f;
chk:     /* check the numerical stability condition for the diagonal
            (i.e. pivot) element u[k,k] */
         if (fabs(vpq->val) < eps * rmax1)
         {  ret = +k;
            goto done;
         }
         /* if u[k+1,k] = 0, no elimination is needed */
         if (viq == NULL) continue;
         /* compute gaussian multiplier f = v[i,q]/v[p,q] */
         f = viq->val / vpq->val;
         /* work := (i-th row of V) */
         for (e = V->row[i]; e != NULL; e = e->row)
            work[e->j] = e->val;
         /* work := work - f * (p-th row of V) */
         for (e = V->row[p]; e != NULL; e = e->row)
            work[e->j] -= f * e->val;
         /* the eliminated element u[k+1,k] = v[i,q] should be exact
            zero */
         work[q] = 0.0;
         /* now new elements of i-th row of the matrix V are placed in
            the array work */
         /* replace existing elements of i-th row */
         for (e = V->row[i]; e != NULL; e = e->row)
         {  j = e->j;
            /* if |v[i,j]| < drop * max|v[i,*]|, where drop is relative
               drop tolerance, the element v[i,j] can be replaced by
               exact zero; this slightly decreases accuracy but allows
               to improve sparsity */
            if (fabs(work[j]) < drop * rmax2) work[j] = 0.0;
            /* replace element v[i,j] */
            e->val = work[j], work[j] = 0.0;
         }
         /* create new elements, which appeared in i-th row as a result
            of elimination */
         for (e = V->row[p]; e != NULL; e = e->row)
         {  j = e->j;
            /* (see notice above) */
            if (fabs(work[j]) < drop * rmax2) work[j] = 0.0;
            if (work[j] == 0.0) continue;
            /* create new (non-zero) element v[i,j] */
            new_elem(V, i, j, work[j]), (*Unz)++, work[j] = 0.0;
         }
         /* (now the array work again contains all zeros) */
         /* i-th row of the matrix V has been transformed */
         func(iU(i) /* = k+1 */, k, f);
         /* now all zeros appeared in i-th row of the matrix V as a
            result of elimination should be removed */
         for (e = V->row[i], V->row[i] = NULL; e != NULL; e = en)
         {  en = e->row;
            if (e->val != 0.0)
            {  /* v[i,j] != 0, keep this element */
               e->row = V->row[i], V->row[i] = e;
               continue;
            }
            /* v[i,j] = 0; remove this element from the list of j-th
               column of the matrix V */
            j = e->j;
            if (V->col[j] == e)
               V->col[j] = e->col;
            else
            {  for (ee = V->col[j]; ee != NULL; ee = ee->col)
                  if (ee->col == e) break;
               insist(ee != NULL);
               ee->col = e->col;
            }
            /* return the element v[i,j] to the memory pool */
            free_atom(V->pool, e), (*Unz)--;
         }
         /* k-th elimination step is finished */
      }
      /* check the numerical stability condition for the last diagonal
         element u[k2,k2] */
      vpq = NULL; rmax1 = 0.0;
      for (e = V->row[iV(k)]; e != NULL; e = e->row)
      {  if (e->j == jV(k)) vpq = e;
         if (rmax1 < fabs(e->val)) rmax1 = fabs(e->val);
      }
      if (vpq == NULL)
         ret = -k;
      else if (fabs(vpq->val) < eps * rmax1)
         ret = +k;
done: /* return to the calling program */
      return ret;
}

/*----------------------------------------------------------------------
-- gel_ft - sparse gaussian elimination (Forrest & Tomlin technique).
--
-- *Synopsis*
--
-- #include "glpgel.h"
-- int gel_ft(PER *P, MAT *V, PER *Q, int k1, int k2,
--    void (*func)(int i, int k, double f), double eps, int *Unz,
--    double work[]);
--
-- *Description*
--
-- The gel_ft routine uses Forrest & Tomlin version of the gaussian
-- elimination technique to transform the matrix U = P*V*Q to the upper
-- triangular form, where V is the given sparse matrix, P and Q are the
-- given permutation matrices.
--
-- (The matrix U has implicit representation, therefore all operations
-- are actually performed on the matrix V, that differs from U only in
-- the order of rows and columns determining by the permutation matrices
-- P and Q.)
--
-- It is assumed that on entry the matrix U has the following special
-- structure:
-- It is assumed that on entry the matrix U has the following special
-- structure:
--
--     1   k1       k2   n
-- 1   x x x x x x x x x x
--     . x x x x x x x x x
-- k1  . . * * * * * * * *
--     . . * * * * * * * *
--     . . * . * * * * * *
--     . . * . . * * * * *
--     . . * . . . * * * *
-- k2  . . * . . . . * * *
--     . . . . . . . . x x
-- n   . . . . . . . . . x
--
-- Hence only the submatrix with rows k1, k1+1, ..., k2 and columns
-- k1, k1+1, ..., n should be transformed (elements of this submatrix
-- are marked by '*', all other elements of the matrix U are marked by
-- 'x').
--
-- The result of the transformation is the matrices P', V', and Q' that
-- define the upper triangular matrix U' = P'*V'*Q' (these new matrices
-- are stored instead the source matrices P, V, and Q).
--
-- To eliminate subdiagonal elements of the matrix U the routine applies
-- to this matrix elementary transformations of the following types: row
-- permutation, column permutation, and subtraction one row multiplied
-- by a number from other row (gaussian transformation). Each time when
-- gaussian transformation is applied to the matrix U (in order to
-- eliminate one subdiagonal element), the gel_bg routine calls the func
-- routine in order that the calling routine would have possibility to
-- accumulate all information about these transformations (information
-- about row and column permutations are accumulated in the matrices P
-- and Q by the gel_bg routine).
--
-- The point where the func routine is called, and the meaning of the
-- parameters passed to this routine can be explained by means of the
-- following general scheme of elimination process.
--
-- Before elimination the routine shifts columns k1+1, k1+2, ..., k2 of
-- the matrix U by one position to the left and upwards and also moves
-- k1-th row and k1-th column to the position k2. As a result of such
-- symmetric permutation of rows and columns the matrix U becomes the
-- following:
--
--     1   k1       k2   n
-- 1   x x x x x x x x x x
--     . x x x x x x x x x
-- k1  . . * * * * * * * *
--     . . . * * * * * * *
--     . . . . * * * * * *
--     . . . . . * * * * *
--     . . . . . . * * * *
-- k2  . . * * * * * * * *
--     . . . . . . . . x x
-- n   . . . . . . . . . x
--
-- Then the routine uses gaussian elimination to nullify all subdiagonal
-- elements of the matrix U.
--
-- Forrest & Tomlin technique assumes no pivoting. On k-th elimination
-- step (k = k1, k1+1, ..., k2-1) the diagonal element u[k,k] is always
-- used as the pivot. It's obvious that k-th step consists of nullifying
-- the element u[k2,k] (if this element differs from zero).
--
-- Forrest & Tomlin technique involves no filling in, that is the
-- important advantage of this technique, but from the other hand this
-- technique in many cases is less numerically stable because of there
-- is no pivoting.
--
-- So, the general scheme of the elimination process is the following:
--
-- (* permute symmetrically rows and columns of the matrix U *)
-- ...;
-- for (k = k1; k < k2; k++)
-- {  (* k-th elimination step starts here *)
--    (* the pivot element is always u[k,k] *)
--    assert(u[k,k] != 0.0);
--    (* eliminate non-zero subdiagonal element u[k2,k] *)
--    i = k2;
--    if (u[i,k] == 0.0) continue;
--    (* compute gaussian multiplier *)
--    f = u[i,k] / u[k,k];
--    (* (i-th row of U) := (i-th row of U) - f * (k-th row of U) *)
--    ...;
--    assert(u[i,k] == 0.0);
--    (* elementary transformation of i-th row of the matrix U has been
--       performed *)
--    func(i, k, f);
-- }
-- assert(u[k2,k2] != 0.0);
--
-- Should note that row numbers passed to the func routine correspond to
-- the matrix U (not to V!). The correspondence between row and column
-- numbers of the matrices U = P*V*Q and V is determined by the row
-- permutation matrix P and the column permutation matrix Q. So, if an
-- element u[i,j] of the matrix U corresponds to an element v[i',j'] of
-- the matrix V, the following formulae take a place:
--
-- i' = P->row[i], j' = Q->col[j], i = P->col[i'], j = Q->row[j'].
--
-- Since the using Forrest and Tomlin technique changes only one row of
-- the matrix U (which has the number k2), this routine uses simplified
-- checking for the "quality" of the transformation. The transformation
-- is considered as satisfactory (from the numerical point of view) if
-- after the transformation has been finished the following condition is
-- true:
--
-- |u'[k2,k2]| >= eps * big > 0,
--
-- where eps is the given relative tolerance, big is the largest of
-- absolute values of elements which appeared in the transformed row
-- during all eliminating process. (This condition gives some guarantee
-- that the solution of the system with the matrix U' will be relatively
-- accurate.)
--
-- Should note that the routine checks the element u[k,k] only if the
-- element u[k2,k] is not zero, i.e. if gaussian transformation should
-- be actually applied.
--
-- On entry the variable Unz should define the total number of non-zeros
-- in the source matrix U. On exit this variable will define the total
-- number of non-zeros in the transformed matrix U'. (If on entry Unz is
-- set to zero, on exit Unz will define the difference between total
-- numbers of non-zeros in the matrices U' and U.)
--
-- The auxiliary array work should have at least n elements, where n is
-- the order of the matrix U.
--
-- *Returns*
--
-- The gel_ft routine returns one of the following error codes:
--
--  0 - no errors;
-- -k - if k1 <= k < k2, on k-th elimination step the pivot element
--      u[k,k] is found equal to zero; if k = k2, after the last step
--      the element u[k2,k2] is found equal to zero;
-- +k - in this case always k = k2; this means that for the diagonal
--      element u[k2,k2] the numerical stability condition (see above)
--      has been violated.
--
-- Should note that if the matrix U passed to the gel_ft routine is
-- already a result of preceding transformations of some initial matrix
-- U0, the appearence of numerical errors in this routine is usually
-- connected with all sequence of transformations. Hence in such case
-- instead this routine the general gaussian elimination should be
-- applied directly to the initial matrix U0.
--
-- *Reference*
--
-- Forrest J.J.H, Tomlin J.A. Updating triangular factors of the basis
-- to maintain sparsity in the product-form simplex method. Math.Prog.,
-- 2 (1972), pp. 263-78. */

#define iU(i) (P->col[i])
/* converts row number of V to row number of U */

#define iV(i) (P->row[i])
/* converts row number of U to row number of V */

#define jU(j) (Q->row[j])
/* converts column number of V to column number of U */

#define jV(j) (Q->col[j])
/* converts column number of U to column number of V */

int gel_ft(PER *P, MAT *V, PER *Q, int k1, int k2,
      void (*func)(int i, int k, double f), double eps, int *Unz,
      double work[])
{     ELEM *vpq, *e, *ee, *en;
      int n = V->m, i, j, k, p, q, ret = 0;
      double f, big, drop = 1e-15;
      if (V->m != V->n)
         fault("gel_ft: transformed matrix is not square");
      if (!(P->n == n && Q->n == n))
         fault("gel_ft: permutation matrices have invalid order");
      if (!(1 <= k1 && k1 <= k2 && k2 <= n))
         fault("gel_ft: initial active submatrix has invalid position");
      /* shift rows and columns k1+1, k1+2, ..., k2 of the matrix U by
         one position to the left and upwards, and move the row and the
         column having number k1 to the position k2 */
      for (k = k1; k < k2; k++)
      {  int t1, t2;
         /* permute k-th and k+1-th rows of the matrix U */
         t1 = iV(k); t2 = iV(k+1);
         iV(k)   = t2; iU(t2) = k;
         iV(k+1) = t1; iU(t1) = k+1;
         /* permute k-th and k+1-th columns of the matrix U */
         t1 = jV(k); t2 = jV(k+1);
         jV(k)   = t2; jU(t2) = k;
         jV(k+1) = t1; jU(t1) = k+1;
      }
      /* clear auxiliary array */
      for (j = 1; j <= n; j++) work[j] = 0.0;
      /* k2-th row of U = i-th row of V */
      i = iV(k2);
      /* work := (i-th row of V) */
      big = 0.0; /* = max|v[i,*]| */
      for (e = V->row[i]; e != NULL; e = e->row)
      {  if (jU(e->j) < k1 || e->val == 0.0)
err:        fault("gel_ft: transformed matrix has invalid pattern");
         work[e->j] = e->val;
         if (big < fabs(e->val)) big = fabs(e->val);
      }
      /* main loop of gaussian elimination */
      for (k = k1; k < k2; k++)
      {  /* the goal of k-th step is to nullify the subdiagonal element
            u[k2,k] */
         p = iV(k); /* k-h row of U     = p-th row of V */
         q = jV(k); /* k-th column of U = q-th column of V */
         /* if u[k2,k] = 0, no elimination is needed */
         if (work[q] == 0.0) continue;
         /* search for u[k,k] = v[p,q] */
         vpq = NULL;
         for (e = V->row[p]; e != NULL; e = e->row)
         {  if (jU(e->j) < k || e->val == 0.0) goto err;
            if (e->j == q) vpq = e;
         }
         if (vpq == NULL)
         {  /* the diagonal element u[k,k] is equal to zero */
            ret = -k;
            goto done;
         }
         /* compute gaussian multiplier f = v[i,q]/v[p,q] */
         f = work[q] / vpq->val;
         /* work := work - f * (p-th row of V) */
         for (e = V->row[p]; e != NULL; e = e->row)
         {  work[e->j] -= f * e->val;
            /* if |v[i,j]| < drop * max|v[i,*]|, where drop is relative
               drop tolerance, the element v[i,j] can be replaced by
               exact zero; this slightly decreases accuracy but allows
               to improve sparsity */
            if (fabs(work[e->j]) < drop * big) work[e->j] = 0.0;
            if (big < fabs(work[e->j])) big = fabs(work[e->j]);
         }
         /* u[k2,k] = v[i,q] should be exact zero */
         work[q] = 0.0;
         /* elementary gaussian transformation of i-th row of the matrix
            V has been performed */
         func(iU(i) /* = k2 */, k, f);
         /* k-th elimination step is finished */
      }
      /* check the numerical stability condition for the last diagonal
         element u[k2,k2] */
      j = jV(k2);
      if (work[j] == 0.0)
      {  ret = -k2;
         goto done;
      }
      if (fabs(work[j]) < eps * big)
      {  ret = +k2;
         goto done;
      }
      /* replace existing elements of i-th row of the matrix V */
      for (e = V->row[i]; e != NULL; e = e->row)
      {  j = e->j;
         e->val = work[j], work[j] = 0.0;
      }
      /* create new elements, which appeared in i-th row as a result
         of elimination */
      for (j = 1; j <= n; j++)
         if (work[j] != 0.0) new_elem(V, i, j, work[j]), (*Unz)++;
      /* remove zero elements, which appeared in i-th row as a result
         of numerical cancellation */
      for (e = V->row[i], V->row[i] = NULL; e != NULL; e = en)
      {  en = e->row;
         if (e->val != 0.0)
         {  /* v[i,j] != 0, keep this element */
            e->row = V->row[i], V->row[i] = e;
            continue;
         }
         /* v[i,j] = 0; remove this element from the list of j-th
            column of the matrix V */
         j = e->j;
         if (V->col[j] == e)
            V->col[j] = e->col;
         else
         {  for (ee = V->col[j]; ee != NULL; ee = ee->col)
              if (ee->col == e) break;
            insist(ee != NULL);
            ee->col = e->col;
         }
         /* return the element v[i,j] to the memory pool */
         free_atom(V->pool, e), (*Unz)--;
      }
done: /* return to the calling program */
      return ret;
}

/*----------------------------------------------------------------------
-- min_bump - minimize bump size of given matrix (Reid's technique).
--
-- *Synopsis*
--
-- #include "glpgel.h"
-- void min_bump(PER *P, MAT *V, PER *Q, int *k1, int *k2,
--    DUFF *rs, DUFF *cs, int prev[], int next[]);
--
-- *Description*
--
-- The min_bump routine performs symmetric permutations of rows and
-- columns of the given matrix U = P*V*Q in order to minimize the size
-- of the bump of this matrix saving its special structure (see below).
-- The routine is based on the transformation proposed by J.Reid.
--
-- Actually the matrix V remains unchanged, since row and column
-- permutations are implicit and accumulated in permutation matrices
-- P and Q.
--
-- It is assumed that on entry the matrix U = P*V*Q has the following
-- special structure:
--
--     1   k1       k2   m
-- 1   x x x x x x x x x x
--     . x x x x x x x x x
-- k1  . . + * * * * * x x
--     . . + * * * * * x x
--     . . + . * * * * x x
--     . . + . . * * * x x
--     . . + . . . * * x x
-- k2  . . + . . . . * x x
--     . . . . . . . . x x
-- m   . . . . . . . . . x
--
-- where rows and columns k1, k1+1, ..., k2 form so called bump. So,
-- the matrix U differs from upper triangular matrix by k1-th column,
-- which is called spike. Additionally it is assumed that all diagonal
-- elements of the matrix U (except may be the element u[k1,k1]) are
-- non-zero. The element u[k2,k1] also should be non-zero (otherwise
-- the initial bump size may be decreased).
--
-- If in the bump there is a column which is not the spike and which
-- has only one non-zero (column singlet), this element is placed on
-- the main diagonal. Let u[k,k] is the column singlet. Then the routine
-- shifts rows and columns with numbers k1, k1+1, ..., k-1 by one
-- position respectively to the right and downwards, and places the row
-- and the column with number k to the position k1. This transformation
-- allows to decrease the bump size by one:
--
--     1   k1    k  k2   m        1     k1     k2   m
-- 1   x x x x x x x x x x    1   x x x x x x x x x x
--     . x x x x x x x x x        . x x x x x x x x x
-- k1  . . + * * . * * x x        . . s + . . * * x x
--     . . + * * . * * x x    k1  . . . + * * * * x x
--     . . + . * . * * x x        . . . + * * * * x x
-- k   . . + . . s * * x x        . . . + . * * * x x
--     . . + . . . * * x x        . . . + . . * * x x
-- k2  . . + . . . . * x x    k2  . . . + . . . * x x
--     . . . . . . . . x x        . . . . . . . . x x
-- m   . . . . . . . . . x    m   . . . . . . . . . x
--
-- Analogously, if in the bump there is a row which is not the row that
-- is symmetric to the spike and which has only one non-zero (row
-- singlet), this element is placed on the main diagonal. Let u[k,k] is
-- the row singlet. The the routine shifts rows and columns with numbers
-- k+1, k+2, ..., k2 by one position respectively to the left and
-- upwards, and places the row and the column with number k to the
-- position k2. This transformation again allows to decrease the bump
-- size by one:
--
--     1   k1    k  k2   m        1   k1     k2     m
-- 1   x x x x x x x x x x    1   x x x x x x x x x x
--     . x x x x x x x x x        . x x x x x x x x x
-- k1  . . + * * * * * x x    k1  . . + * * * * * x x
--     . . + * * * * * x x        . . + * * * * * x x
--     . . + . * * * * x x        . . + . * * * * x x
-- k   . . . . . s . . x x        . . + . . * * . x x
--     . . + . . . * * x x    k2  . . + . . . * . x x
-- k2  . . + . . . . * x x        . . . . . . . s x x
--     . . . . . . . . x x        . . . . . . . . x x
-- m   . . . . . . . . . x    m   . . . . . . . . . x
--
-- Removing row or column from the bump may involve new singlets to be
-- appeared, so the routine repeats these elementary transformations as
-- long as possible.
--
-- After the matrix U has been transformed the routine assigns to the
-- parameter k1 and k2 positions of the final bump. (The case k1 = k2
-- would mean that the matrix U has became fully upper triangular and
-- that all its diagonal elements, except may be the diagonal element
-- forming the final bump, are non-zero.)
--
-- The following details are important for efficient implementation.
-- Explicit row and column permutations of the matrix U (this matrix
-- has implicit representation U = P*V*Q) would be very expensive, since
-- one shift of row or column would require up to n transpositions (i.e.
-- up to n movements of elements of the matrices P and Q), where n is
-- the size of the current bump. Hence, the total time estimation would
-- be O(n^2). Therefore the min_bump routine performs all elementary
-- transformations on other matrix U', which differs from the matrix U
-- only by order of rows and columns. For representing the matrix U' the
-- routine doesn't use permutation matrices (like P and Q). Instead that
-- it uses double-linked list, elements of which are numbers of rows and
-- columns of the matrix U and the order of which is the same as the
-- order of rows and columns of the matrix U' (it's enough to have only
-- one linked list, because all permutations are symmetric). Initially
-- the matrix U' is identical to the matrix U. And after the matrix U
-- has been transformed this double-linked list is used to reorder rows
-- and columns of the matrix U. Such technique allows to perform any
-- movement of rows and columns (of the matrix U') for a fixed time,
-- because one movement is equivalent to one exclusion from and one
-- inclusion to the linked list, so in this case the time estimation is
-- O(nz), where nz is number of non-zeros.
--
-- To find row and column singlets for a fixed time the routine uses
-- Duff's search technique. The parameters rs and cs should specify Duff
-- schemes for holding lists of active (i.e. belonging to the current
-- bump) rows and columns. The initial contents of these schemes is not
-- essential; on exit these schemes will contain respectively numbers of
-- rows and columns of the matrix U (not V!), which belong to the final
-- (minimized) bump. These schemes may be created by the statements
-- rs = create_duff(n, n) and cs = create_duff(n, n), where n is the
-- order of the matrix U. To hold double-linked lists the routine also
-- uses two working array prev and next, which should have at least 1+n
-- elements.
--
-- *Reference*
--
-- Reid J.K. A Sparsity-Exploiting Variant of the Bartels-Golub
-- Decomposition for Linear Programming Bases. Math.Prog., 24, 1982,
-- pp. 55-69. */

#define iU(i) (P->col[i])
/* converts row number of V to row number of U */

#define iV(i) (P->row[i])
/* converts row number of U to row number of V */

#define jU(j) (Q->row[j])
/* converts column number of V to column number of U */

#define jV(j) (Q->col[j])
/* converts column number of U to column number of V */

void min_bump(PER *P, MAT *V, PER *Q, int *_k1, int *_k2,
      DUFF *rs, DUFF *cs, int prev[], int next[])
{     ELEM *e;
      int n = V->m, k1 = *_k1, k2 = *_k2, head, tail;
      int i, j, k, nz, t, t1, t2, t1new, t2new;
      int *old_iV = &iU(0), *old_jV = &jU(0);
      if (V->m != V->n)
         fault("min_bump: transformed matrix is not square");
      if (!(P->n == n && Q->n == n))
         fault("min_bump: permutation matrices have invalid order");
      if (!(1 <= k1 && k1 <= k2 && k2 <= n))
         fault("min_bump: initial bump has invalid position");
      /* build linked lists containing rows and columns of the matrix U
         (initially the matrix U' is identical to the matrix U) */
      head = 1, tail = n;
      for (t = 1; t <= n; t++)
         prev[t] = t-1, next[t] = (t < n ? t+1 : 0);
      /* build active lists containing rows and columns of the matrix U
         (initially these are rows and columns of the initial bump, but
         except the spike and the symmetric row, because their choice
         should be locked) */
      reset_duff(rs);
      for (i = k1+1; i <= k2; i++)
      {  nz = 0;
         for (e = V->row[iV(i)]; e != NULL; e = e->row)
         {  j = jU(e->j);
            if (j < k1)
err:           fault("min_bump: transformed matrix has invalid pattern")
                  ;
            if (j <= k2) nz++;
         }
         include_obj(rs, i, nz);
      }
      reset_duff(cs);
      for (j = k1+1; j <= k2; j++)
      {  nz = 0;
         for (e = V->col[jV(j)]; e != NULL; e = e->col)
         {  i = iU(e->i);
            if (i > k2) goto err;
            if (i >= k1) nz++;
         }
         include_obj(cs, j, nz);
      }
      /* row and column numbers t1 and t2 of the matrix U correspond to
         bounds k1 and k2 of the current bump of the matrix U' */
      t1 = k1, t2 = k2;
loop: /* main loop starts here */
      t = cs->head[1];
      if (t != 0)
      {  /* the element u[t,t] is in the bump and is a column singlet */
         for (e = V->col[jV(t)]; e != NULL; e = e->col)
         {  /* the active row is a sign of the singlet */
            i = iU(e->i);
            if (rs->len[i] >= 0) break;
         }
         if (!(e != NULL && i == t)) goto err;
         /* determine bounds of new bump */
         t1new = (t1 == t ? next[t1] : t1);
         t2new = (t2 == t ? prev[t2] : t2);
         /* t-th column and row of the matrix U should be removed from
            the bump and placed before t1-th row and column */
         if (t != t1)
         {  /* remove the element t from the linked list */
            if (prev[t] == 0)
               head = next[t];
            else
               next[prev[t]] = next[t];
            if (next[t] == 0)
               tail = prev[t];
            else
               prev[next[t]] = prev[t];
            /* insert the element t before the element t1 */
            prev[t] = prev[t1];
            next[t] = t1;
            if (prev[t1] == 0)
               head = t;
            else
               next[prev[t1]] = t;
            prev[t1] = t;
         }
         /* correct counts of active columns of the matrix U */
         for (e = V->row[iV(t)]; e != NULL; e = e->row)
         {  j = jU(e->j);
            nz = cs->len[j];
            if (nz >= 0)
               exclude_obj(cs, j), include_obj(cs, j, nz-1);
         }
         /* remove t-th row and column from active lists */
         exclude_obj(rs, t), exclude_obj(cs, t);
         /* continue the search */
         t1 = t1new, t2 = t2new, k1++;
         goto loop;
      }
      t = rs->head[1];
      if (t != 0)
      {  /* the element u[t,t] is in the bump and is a row singlet */
         for (e = V->row[iV(t)]; e != NULL; e = e->row)
         {  /* the active column is a sign of the singlet */
            j = jU(e->j);
            if (cs->len[j] >= 0) break;
         }
         if (!(e != NULL && j == t)) goto err;
         /* determine bounds of new bump */
         t1new = (t1 == t ? next[t1] : t1);
         t2new = (t2 == t ? prev[t2] : t2);
         /* t-th column and row of the matrix U should be removed from
            the bump and placed after t2-th row and column */
         if (t != t2)
         {  /* remove the element t from the linked list */
            if (prev[t] == 0)
               head = next[t];
            else
               next[prev[t]] = next[t];
            if (next[t] == 0)
               tail = prev[t];
            else
               prev[next[t]] = prev[t];
            /* insert the element t after the element t2 */
            prev[t] = t2;
            next[t] = next[t2];
            if (next[t2] == 0)
               tail = t;
            else
               prev[next[t2]] = t;
            next[t2] = t;
         }
         /* correct counts of active rows of the matrix U */
         for (e = V->col[jV(t)]; e != NULL; e = e->col)
         {  i = iU(e->i);
            nz = rs->len[i];
            if (nz >= 0)
               exclude_obj(rs, i), include_obj(rs, i, nz-1);
         }
         /* remove t-th row and column from active lists */
         exclude_obj(rs, t), exclude_obj(cs, t);
         /* continue the search */
         t1 = t1new, t2 = t2new, k2--;
         goto loop;
      }
      insist(tail == tail); /* relax compiler about never used */
      /* igitur, the matrix U' has desired form, where the order of
         rows and columns of the original matrix U that form the matrix
         ing U' is determined by the linked list; it allows performing
         implicit permutations of rows and columns of the matrix U in
         order to turn it into the matrix U' */
      for (i = 1; i <= n; i++) old_iV[i] = iV(i);
      for (k = 0, i = head; i != 0; i = next[i])
         k++, iV(k) = old_iV[i];
      for (j = 1; j <= n; j++) old_jV[j] = jV(j);
      for (k = 0, j = head; j != 0; j = next[j])
         k++, jV(k) = old_jV[j];
      for (k = 1; k <= n; k++) iU(iV(k)) = k, jU(jV(k)) = k;
      /* k1 and k2 are bounds of the final bump of the matrix U which
         now is identical to the matrix U' (k1 <= k2, moreover k1 = k2
         only if the final bump contains only one spike) */
      *_k1 = k1, *_k2 = k2;
      return;
}

/*----------------------------------------------------------------------
-- create_lu - create LU-factorization.
--
-- *Synopsis*
--
-- #include "glpgel.h"
-- LU *create_lu(int n);
--
-- *Description*
--
-- The create_lu routine creates LU-factorization of order n. Initially
-- the created factorization corresponds to unity matrix.
--
-- *Returns*
--
-- The create_lu routine returns a pointer to the data structure that
-- represents LU-factorization of order n. */

LU *create_lu(int n)
{     LU *lu;
      int k;
      if (n < 1)
         fault("create_lu: invalid order");
      lu = umalloc(sizeof(LU));
      lu->n = n;
      lu->P = create_per(n);
      lu->L = create_mat(n, n);
      for (k = 1; k <= n; k++) new_elem(lu->L, k, k, 1.0);
      lu->U = create_mat(n, n);
      for (k = 1; k <= n; k++) new_elem(lu->U, k, k, 1.0);
      lu->Q = create_per(n);
      return lu;
}

/*----------------------------------------------------------------------
-- build_lu - compute LU-factorization of given matrix.
--
-- *Synopsis*
--
-- #include "glpgel.h"
-- int build_lu(LU *lu, MAT *A, double tol, double lim,
--    void (*monit)(LU *lu, int kase, int i, int k, double f),
--    double *Amax, double *Ubig);
--
-- *Description*
--
-- The build_lu routine computes LU-factorization of the sparse matrix
-- A in the form A = P*L*U*Q, where L is lower triangular matrix with
-- unit diagonal, U is upper triangular matrix, P and Q are permutation
-- matrices. To perform factorization the build_lu routine uses the gel
-- routine which implements sparse gaussian elimination.
--
-- The LU-factorization which lu points to should be created before by
-- the create_lu routine and may be used many times for different
-- matrices of the same order to factorize them by means of the build_lu
-- routine. It is allowed to use lu->U as the input matrix A; otherwise
-- the matrix A remains unchanged.
--
-- The parameter tol is the tolerance used for threshold pivoting. It
-- should be in the range 0 < tol < 1. An element u[i,j] of the active
-- submatrix is considered as acceptable (from the point of view of the
-- numerical stability) to be a pivot, if |u[i,j]| >= tol * max|u[i,*]|
-- on some elimination step. Decreasing tol usually involves improving
-- sparsity at the expense of accuracy and vice versa. If the input
-- matrix is expected to be well conditioned, tol = 0.01-0.1 is a good
-- choice. For more hard matrices tol sholud be increased. For details
-- see the description of the gel routine.
--
-- The parameter lim specifies maximal allowable growth of elements of
-- the matrix U during factorization process. The process is considered
-- as numerically stable if the condition Ubig <= lim * Amax is true on
-- each step (parameters Amax and Ubig are described below). If double
-- corresponds to 16 decimal places, lim = 1e10-1e12 may be used.
--
-- The monit routine is intended for monitoring purposes. The build_lu
-- routine calls the monit routine in the following cases (recognised
-- by the parameter kase):
--
-- kase = 0: once before the beginning of factorization (parameters i,
--           k, and f should be ignored);
--
-- kase = 1: each time when the next elementary gaussian transformation
--           on the matrix U has been performed:
--
--           (i-th row of U) := (i-th row of U) - f * (k-th row of U),
--
--           where i is number of transformed row, k is number of pivot
--           row. As a result of this transformation the next non-zero
--           element is appended to the matrix L. Should note that
--           during factorization lu->L and lu->U differ from matrices
--           L and U in ordering of rows and columns that is determined
--           by permutation matrices P and Q. This is used to avoid
--           explicit permutations of rows and columns of L and U (for
--           details see the build_lu routine).
--
-- kase = 2: once after the end of factorization (parameters i, k, and
--           f should be ignored).
--
-- There is standard monitoring routine monit_lu, that can be passed to
-- the build_lu routine. Each second the monit_lu routine outputs the
-- following: n (order of the matrix A), k (number of elimination step),
-- nz(L) (number of non-zeros in the matrix L), and nz(U) (number of
-- non-zeros in the matrix U).
--
-- If the parameter monit is NULL, no monitoring is performed.
--
-- The variables Amax and Ubig (i.e. locations which these parameters
-- point to) are ignored before a call. After a call the variable Amax
-- will contain the maximum of absolute values of elements of the input
-- matrix A, and the variable Ubig will contain the maximum of absolute
-- values of those elements which appeared in the matrix U during
-- factorization.
--
-- Factorization may fail when the matrix A is numerically singular or
-- ill conditioned. In this case the matrices L and U will look as the
-- following (k is number of factorization step that failed):
--
--    1       k         n        1       k         n
-- 1  1 . . . . . . . . .     1  x x x x x x x x x x
--    x 1 . . . . . . . .        . x x x x x x x x x
--    x x 1 . . . . . . .        . . x x x x x x x x
--    x x x 1 . . . . . .        . . . x x x x x x x
-- k  x x x x 1 . . . . .     k  . . . . * * * * * *
--    x x x x x 1 . . . .        . . . . * * * * * *
--    x x x x x . 1 . . .        . . . . * * * * * *
--    x x x x x . . 1 . .        . . . . * * * * * *
--    x x x x x . . . 1 .        . . . . * * * * * *
-- n  x x x x x . . . . 1     n  . . . . * * * * * *
--
-- where '*' marks the submatrix of the matrix U that caused a problem.
-- Since A = P*L*U*Q even in case of error, this information may be used
-- to perform further analysis of the matrix A.
--
-- *Returns*
--
-- The build_lu routine returns one of the following error codes:
--
--  0 - no errors, factorization has been successfully computed;
-- -k - on k-th factorization step pivot can't be chosen because all
--      elements of the active submatrix are zeros;
-- +k - on k-th factorization step numerical stability condition (see
--      above) has been violated. */

static LU *lu;
/* LU-factorization of the matrix A */

static void (*monit)(LU *lu, int kase, int i, int k, double f);
/* monitoring routine */

#define func func1

static void func(int i, int k, double f);
/* auxiliary routine */

int build_lu(LU *_lu, MAT *A, double tol, double lim,
      void (*_monit)(LU *lu, int kase, int i, int k, double f),
      double *Amax, double *Ubig)
{     MAT *M, *V;
      DUFF *rs, *cs;
      int k, ret, dum = 0;
      double *rmax, *work;
      /* initialization */
      lu = _lu;
      if (!(A->m == lu->n && A->n == lu->n))
         fault("build_lu: order of LU-factorization conflicts with orde"
            "r of input matrix");
      if (!(0.0 < tol && tol < 1.0))
         fault("build_lu: invalid value of tol");
      if (lim < 1.0)
         fault("build_lu: invalid value of lim");
      monit = _monit;
      *Amax = *Ubig = 0.0;
      M = lu->L; /* M is alias for L */
      V = lu->U; /* V is alias for U */
      /* compute auxiliary factorization A = M*V, where L = P*M*P' and
         U = P*V*Q (order of rows and columns of the matrices M and V
         remain unchanged during transformation of the matrix U to upper
         triangular form) */
      /* P := I, M := I, V := A, Q := I */
      reset_per(lu->P);
      clear_mat(M);
      for (k = 1; k <= lu->n; k++) new_elem(M, k, k, 1.0);
      copy_mat(V, A);
      reset_per(lu->Q);
      /* allocate working storage */
      rs = create_duff(lu->n, lu->n);
      cs = create_duff(lu->n, lu->n);
      rmax = ucalloc(1+lu->n, sizeof(double));
      work = ucalloc(1+lu->n, sizeof(double));
      /* transform the matrix U = P*V*Q to upper triangular form using
         gaussian elimination; elementary gaussian transformations will
         be accumulated in the matrix M */
      if (monit != NULL) monit(lu, 0, 0, 0, 0.0);
      ret = gel(V, lu->P, lu->Q, func, tol, lim, &dum, Amax, Ubig, rs,
         cs, rmax, work);
      if (monit != NULL) monit(lu, 2, 0, 0, 0.0);
      /* compute final factorization A = P*L*U*Q */
      insist(sizeof(void *) <= sizeof(double));
      /* U := P*V*Q, L := P*M*PT, P := P', Q := Q' */
      copy_mat(lu->U, V);
      per_mat(lu->P, lu->U, (void **)work);
      mat_per(lu->U, lu->Q, (void **)work);
      copy_mat(lu->L, M);
      per_mat(lu->P, lu->L, (void **)work);
      inv_per(lu->P);
      mat_per(lu->L, lu->P, (void **)work);
      inv_per(lu->Q);
      /* free working storage */
      delete_duff(rs);
      delete_duff(cs);
      ufree(rmax);
      ufree(work);
      /* return to the calling program */
      return ret;
}

/*----------------------------------------------------------------------
-- func - accumulate elementary transformations.
--
-- The gel routine calls this routine each time when the following
-- elementary gaussian transformation is applied to the matrix U:
--
-- (i-th row of U) := (i-th row of U) - f * (k-th row of U).
--
-- This routine is used i, k, and f to append the next non-zero to the
-- matrix M that determines auxiliary factorization A = M*V. The matrix
-- M differs from the lower triangular matrix L only in symmetric order
-- of rows and columns. */

static void func(int i, int k, double f)
{     MAT *M = lu->L; /* M is alias for L */
      /* row numbers i and k correspond to the matrix U, but the matrix
         M compensates the corresponding elementary transformation of
         the matrix V, not U; therefore instead i and k we should use
         row numbers i' and k' that correspond to the matrix V and that
         is determined by the row permutation matrix P */
      int ii = lu->P->row[i], kk = lu->P->row[k];
      new_elem(M, ii, kk, f);
      if (monit != NULL) monit(lu, 1, i, k, f);
      return;
}

/*----------------------------------------------------------------------
-- monit_lu - standard monitoring routine.
--
-- *Synopsis*
--
-- #include "glpgel.h"
-- void monit_lu(LU *lu, int kase, int i, int k, double f);
--
-- *Description*
--
-- The monit_lu routine is standard monitoring routine, that may be
-- passed to the build_lu routine. For more details see description of
-- the build_lu routine. */

void monit_lu(LU *lu, int kase, int i, int k, double f)
{     static clock_t t = 0;
      insist(i == i && f == f);
      switch (kase)
      {  case 0:
            t = clock();
            break;
         case 1:
            if (lu->L->pool->count % 1000 == 0)
            {  if (t + CLOCKS_PER_SEC < clock())
               {  print("monit_lu: n = %d; k = %d (%d%%); nz(L) = %d; n"
                     "z(U) = %d", lu->n, k,
                     (int)(((double)k / (double)lu->n) * 100.0 + 0.5),
                     lu->L->pool->count, lu->U->pool->count);
                  t = clock();
               }
            }
            break;
         case 2:
            t = 0;
            break;
      }
      return;
}

/*----------------------------------------------------------------------
-- solve_lu - solve linear system using LU-factorization.
--
-- *Synopsis*
--
-- #include "glpgel.h"
-- void solve_lu(LU *lu, int flag, double x[], double work[]);
--
-- *Description*
--
-- The solve_lu routine obtains solution of the linear system A*x = b
-- or A'*x = b, where A is coefficient matrix, A' is matrix transposed
-- to A, x is dense vector of unknowns, b is dense vector of right-hand
-- sides.
--
-- The parameter lu should define LU-factorization of the coefficient
-- matrix A computed by means of the build_lu routine. If the build_lu
-- reported failure, the solve_lu routine should not be used.
--
-- The parameter flag determines what system will be solved. If flag
-- is 0, the routine obtains solution of A*x = b. Otherwise the routine
-- obtains solution of A'*x = b, where A' is transposed to A. (In the
-- latter case LU-factorization should correspond to A, not to A'!)
--
-- Before a call the array x should contain elements of the vector b
-- in locations x[1], x[2], ..., x[n], where n is order of the system.
-- After a call this array will contain the vector x in the same
-- locations.
--
-- The auxiliary array work should have at least 1+n elements. */

void solve_lu(LU *lu, int flag, double x[], double work[])
{     if (flag == 0)
      {  /* A = P*L*U*Q => inv(A) = Q'*inv(U)*inv(L)*P' */
         iper_vec(work, lu->P, x);
         l_solve(lu->L, work);
         u_solve(lu->U, work);
         iper_vec(x, lu->Q, work);
      }
      else
      {  /* A' = Q'*U'*L'*P' => inv(A') = P*inv(L')*inv(U')*Q */
         per_vec(work, lu->Q, x);
         ut_solve(lu->U, work);
         lt_solve(lu->L, work);
         per_vec(x, lu->P, work);
      }
      return;
}

/*----------------------------------------------------------------------
-- delete_lu - delete LU-factorization.
--
-- *Synopsis*
--
-- #include "glpgel.h"
-- void delete_lu(LU *lu);
--
-- *Description*
--
-- The delete_lu routine deletes the LU-factorization, which lu points
-- to, freeing all memory allocated to this object. */

void delete_lu(LU *lu)
{     delete_per(lu->P);
      delete_mat(lu->L);
      delete_mat(lu->U);
      delete_per(lu->Q);
      ufree(lu);
      return;
}

/* eof */
