/* glprfi.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 <math.h>
#include <stddef.h>
#include "glpgel.h"
#include "glprfi.h"

/*----------------------------------------------------------------------
-- create_rfi - create RFI.
--
-- *Synopsis*
--
-- #include "glprfi.h"
-- RFI *create_rfi(int m);
--
-- *Description*
--
-- The create_rfi routine creates RFI for the basis matrix of order m.
-- Initially the created RFI corresponds to the unity matrix.
--
-- *Returns*
--
-- The create_rfi routine returns a pointer to the created RFI. */

RFI *create_rfi(int m)
{     RFI *rfi;
      int k;
      if (m < 1)
         fault("create_rfi: invalid order");
      rfi = umalloc(sizeof(RFI));
      rfi->m = m;
      /* H := I */
      rfi->H = create_eta(m);
      /* V := I */
      rfi->V = create_mat(m, m);
      for (k = 1; k <= m; k++) new_elem(rfi->V, k, k, 1.0);
      /* P := Q := I */
      rfi->P = create_per(m);
      rfi->Q = create_per(m);
      /* initialize counts */
      rfi->nzH0 = 0;
      rfi->nzV0 = m;
      /* use Reid's technique by default */
      rfi->reid = 1;
      /* use Bartels & Golub technique by default */
      rfi->tech = RFI_BG;
      /* allocate memory for transformed column */
      rfi->col = ucalloc(1+m, sizeof(double));
      /* column is not prepared yet */
      rfi->flag = 0;
      /* create auxiliary Duff's schemes */
      rfi->rs = create_duff(m, m);
      rfi->cs = create_duff(m, m);
      /* allocate memory for working array */
      rfi->work = ucalloc(1+m, sizeof(double));
      /* return to the calling program */
      return rfi;
}

/*----------------------------------------------------------------------
-- build_rfi - build RFI for given basis matrix.
--
-- *Synopsis*
--
-- #include "glprfi.h"
-- int build_rfi(RFI *rfi, MAT *A, int indb[]);
--
-- *Description*
--
-- The build_rfi routine builds RFI for the given basis matrix B (see
-- below) in the form B = H*V. This is used when: (a) the current RFI
-- became inaccurate, (b) the current RFI requires too much memory, and
-- (c) the basis matrix B was completely changed.
--
-- The given basis matrix B should be specified implicitly by the matrix
-- A and the array indb. The matrix A should have m rows, where m is the
-- order of the basis matrix B. The array indb should specify a list of
-- column numbers of the matrix A, which form the matrix B. These column
-- numbers should be placed in locations indb[1], indb[2], ..., indb[m].
--
-- *Returns*
--
-- If the RFI has been built, the routine returns zero. Otherwise, the
-- routine returns non-zero. The latter case can happen if the matrix B
-- is numerically singular or ill conditioned; for details see the gel
-- routine. */

static RFI *_rfi;

static void func(int i, int p, double f)
{     /* add the next term to the eta-file H */
      RFI *rfi = _rfi;
      i = rfi->P->row[i], p = rfi->P->row[p];
      app_term(rfi->H, i, p, f);
      return;
}

#define maxtry 4

int build_rfi(RFI *rfi, MAT *A, int indb[])
{     static double tol[1+maxtry] = { 0.00, 0.01, 0.10, 0.40, 0.85 };
      int m = rfi->m, ret, try;
      double Vmax, Vbig, *rmax = rfi->col;
      _rfi = rfi;
      if (A->m != m)
         fault("build_rfi: invalid number of rows");
      for (try = 1; try <= maxtry; try++)
      {  int i, dum = 0;
         /* H := I */
         reset_eta(rfi->H);
         /* V := B */
         clear_mat(rfi->V);
         for (i = 1; i <= m; i++)
         {  ELEM *e;
            int k = indb[i]; /* i-th column of B is k-th column of A */
            if (!(1 <= k && k <= A->n))
               fault("build_rfi: invalid column list");
            for (e = A->col[k]; e != NULL; e = e->col)
            {  if (e->val != 0.0)
                  new_elem(rfi->V, e->i, i, e->val);
            }
         }
         /* P := I, Q := I */
         reset_per(rfi->P);
         reset_per(rfi->Q);
         /* factorize the matrix U = P*V*Q using gaussian elimination
            and accumulate elementary gaussian transformations in the
            eta-file H */
         ret = gel(rfi->V, rfi->P, rfi->Q, func, tol[try], 1e+10, &dum,
            &Vmax, &Vbig, rfi->rs, rfi->cs, rmax, rfi->work);
         if (ret == 0 || try == maxtry) break;
      }
      /* save size of the eta-file H */
      rfi->nzH0 = rfi->H->pool->count;
      /* save number of non-zeros of the matrix V */
      rfi->nzV0 = rfi->V->pool->count;
      /* clear transformed column flag */
      rfi->flag = 0;
      return ret;
}

/*----------------------------------------------------------------------
-- rfi_ftran - perform forward transformation (FTRAN) using RFI.
--
-- *Synopsis*
--
-- #include "glprfi.h"
-- double *rfi_ftran(RFI *rfi, double z[], int save);
--
-- *Description*
--
-- The rfi_ftran routine performs forward transformation of the vector
-- z using RFI which rfi points to.
--
-- In order to perform this operation the routine solves the system
-- B*x = z, where B is the basis matrix defined by RFI, x is vector of
-- unknowns (transformed vector that should be computed), z is vector of
-- right-hand sides (given vector that should be transformed). On entry
-- the array z should contain elements of the vector z in locations
-- z[1], z[2], ..., z[m], where m is the order of the matrix B. On exit
-- this array will contain the vector x in the same locations.
--
-- The parameter save is a flag. If this flag is set, it means that the
-- vector z is a column corresponding to that non-basis variable, which
-- has been chosen to enter the basis. And the rfi_ftran routine saves
-- this column after partial transformation in order that the update_rfi
-- routine could use it to update RFI for adjacent basis matrix. It is
-- assumed that the simplex method routine should perform at least one
-- call to the rfi_ftran routine with the save parameter set.
--
-- *Returns*
--
-- The rfi_ftran routine returns a pointer to the array z. */

double *rfi_ftran(RFI *rfi, double z[], int save)
{     /* B = H*V, therefore inv(B) = inv(V)*inv(H) */
      h_solve(rfi->H, z);
      if (save)
      {  /* save partially transformed column inv(H)*z */
         int i;
         for (i = 1; i <= rfi->m; i++) rfi->col[i] = z[i];
         rfi->flag = 1;
      }
      v_solve(rfi->P, rfi->V, rfi->Q, z, rfi->work);
      return z;
}

/*----------------------------------------------------------------------
-- rfi_btran - perform backward transformation (BTRAN) using RFI.
--
-- *Synopsis*
--
-- #include "glprfi.h"
-- double *rfi_btran(RFI *rfi, double z[]);
--
-- *Description*
--
-- The rfi_btran routine performs backward transformation of the vector
-- z using RFI which rfi points to.
--
-- In order to perform this operation the routine solves the system
-- B'*x = z, where B' is a matrix transposed to the basis matrix B that
-- is defined by RFI, x is vector of unknowns (transformed vector that
-- should be computed), z is vector of right-hand sides (given vector
-- that should be transformed). On entry the array z should contain
-- elements of the vector z in locations z[1], z[2], ..., z[m], where
-- m is the order of the matrix B. On exit this array will contain the
-- vector x in the same locations.
--
-- *Returns*
--
-- The rfi_btran routine returns a pointer to the array z. */

double *rfi_btran(RFI *rfi, double z[])
{     vt_solve(rfi->P, rfi->V, rfi->Q, z, rfi->work);
      ht_solve(rfi->H, z);
      return z;
}

/*----------------------------------------------------------------------
-- update_rfi - update RFI for adjacent basis matrix.
--
-- *Synopsis*
--
-- #include "glprfi.h"
-- int update_rfi(RFI *rfi, int p);
--
-- *Description*
--
-- The update_rfi routine recomputes RFI corresponding to the current
-- basis matrix B, so that the updated RFI will correspond to the new
-- (adjacent) basis matrix Bnew, where Bnew is a result of change p-th
-- column of B by other column.
--
-- Note that new p-th column of the basis matrix is passed implicitly to
-- this routine: the update_rfi routine assumes that the transformed new
-- p-th column was saved before by the rfi_ftran routine.
--
-- *Returns*
--
-- The update_rfi routine returns one of the following codes:
--
-- 0 - RFI has been successfully updated;
-- 1 - RFI became inaccurate;
-- 2 - RFI became too long.
--
-- If the returned code is non-zero, RFI should be rebuilt by the means
-- of the build_rfi routine. */

static RFI *_rfi = NULL;

#define func func1

static void func(int i, int p, double f)
{     /* add the next term to the eta-file H */
      RFI *rfi = _rfi;
      i = rfi->P->row[i], p = rfi->P->row[p];
      app_term(rfi->H, i, p, f);
      return;
}

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

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

int update_rfi(RFI *rfi, int p)
{     ELEM *e;
      int m = rfi->m, i, k1, k2;
      double big, *v, drop = 1e-15;
      _rfi = rfi;
      if (!(1 <= p && p <= m))
         fault("update_rfi: invalid column number");
      if (!rfi->flag)
         fault("update_rfi: transformed column not ready");
      /* the current basis matrix is B = H*V; the new basis matrix is
         Bnew = H*Vnew, where Vnew differs from V only by p-th column,
         which is inv(H)*(new p-th column of B) (i.e. this is partially
         transformed column saved by the rfi_ftran routine) */
      v = rfi->col; /* new p-th column of V */
      /* compute maximal absolute value of elements of column v */
      big = 0.0;
      for (i = 1; i <= m; i++)
      {  double t = fabs(v[i]);
         if (big < t) big = t;
      }
      /* change p-th column of V by v = inv(H)*(new p-th column of B)
         ignoring relatively small elements to improve sparsity of V */
      clear_line(rfi->V, -p);
      for (i = 1; i <= m; i++)
      {  if (v[i] == 0.0 || fabs(v[i]) < drop * big) continue;
         new_elem(rfi->V, i, p, v[i]);
      }
      /* now Bnew = H*Vnew, however the matrix Unew = P*Vnew*Q is not
         upper triangular and has the following form:

              1     k1     k2   m
         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
         k1   . . . * x x x x x x
              . . . * x x x x x x
              . . . * . x x x x x
              . . . * . . x x x x
         k2   . . . * . . . x x x
              . . . . . . . . x x
              . . . . . . . . . x

         elements of changed column of Unew that corresponds to the
         column v are marked by '*'; other non-zeros of Unew are marked
         by 'x'; k1 is number of changed column of Unew which can be
         determined by p and row permutation matrix P; k2 is maximal
         row number which contain non-zero element of changed column */
      k1 = jU(p), k2 = 0;
      for (e = rfi->V->col[p]; e != NULL; e = e->col)
         if (k2 < iU(e->i)) k2 = iU(e->i);
      /* if k1 > k2, the matrix Unew is singular since u[k1,k1] = 0 */
      if (k1 > k2) return 1;
      /* try to minimize the size of "bump" (i.e. the size of submatrix
         of U formed by rows and columns k1, k1+1, ..., k2) using Reid's
         technique; this affects only matrices P and Q, therefore the
         main equality Bnew = H*Vnew remains actual */
      if (rfi->reid && k1 < k2)
      {  min_bump(rfi->P, rfi->V, rfi->Q, &k1, &k2, rfi->rs, rfi->cs,
            (int *)rfi->col, (int *)rfi->work);
         insist(k1 <= k2);
      }
      /* now k1 <= k2; if k1 < k2, the matrix Unew should be transformed
         to the upper diagonal form by means of special version of
         gaussian elimination (Bartels & Golub or Forrest & Tomlin) that
         takes into account special structure of the matrix Unew; all
         elementary gaussian transformation are accumulated in the eta
         file H to provide the main equality Bnew = H*Vnew; in the case
         of k1 = k2 the matrix Unew is upper diagonal yet and therefore
         no transformations are needed; however since u[k1,k1] may be
         zero (as a result of Reid's structural transformation), the
         routine performing gaussian elimination is used not to perform
         it but only to check that u[k1,k1] is non-zero */
      {  int dum = 0, ret;
         switch (rfi->tech)
         {  case RFI_BG:
               /* Bartels & Golub technique */
               ret = gel_bg(rfi->P, rfi->V, rfi->Q, k1, k2, func, 0.35,
                  1e-5, &dum, rfi->work);
               break;
            case RFI_FT:
               /* Forrest & Tomlin technique */
               ret = gel_ft(rfi->P, rfi->V, rfi->Q, k1, k2, func, 1e-5,
                  &dum, rfi->work);
               break;
            default:
               insist(rfi->tech != rfi->tech);
         }
         /* if gaussian elimination routine returned detected that the
            matrix U is near to singular or inaccurate, RFI should be
            rebuilt */
         if (ret != 0) return 1;
      }
      /* if the total size of matrices H and V are too big, RFI should
         be rebuilt */
      {  int nzH = rfi->H->pool->count;
         int nzV = rfi->V->pool->count;
         if ((nzH + nzV) > 2 * (rfi->nzH0 + rfi->nzV0)) return 2;
      }
      /* the transformed column is no longer valid */
      rfi->flag = 0;
      /* RFI has been successfully updated */
      return 0;
}

/*----------------------------------------------------------------------
-- delete_rfi - delete RFI.
--
-- *Synopsis*
--
-- #include "glprfi.h"
-- void delete_rfi(RFI *rfi);
--
-- *Description*
--
-- The delete_rfi routine deletes RFI which rfi points to freeing all
-- memory allocated to this object. */

void delete_rfi(RFI *rfi)
{     delete_eta(rfi->H);
      delete_mat(rfi->V);
      delete_per(rfi->P);
      delete_per(rfi->Q);
      ufree(rfi->col);
      delete_duff(rfi->rs);
      delete_duff(rfi->cs);
      ufree(rfi->work);
      ufree(rfi);
      return;
}

/* eof */
