/* glppfi.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 "glppfi.h"

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

PFI *create_pfi(int m)
{     PFI *pfi;
      if (m < 1)
         fault("create_pfi: invalid order");
      pfi = umalloc(sizeof(PFI));
      pfi->m = m;
      pfi->lu = create_lu(m);
      pfi->eta = create_eta(m);
      pfi->col = ucalloc(1+m, sizeof(double));
      pfi->flag = 0;
      pfi->work = ucalloc(1+m, sizeof(double));
      return pfi;
}

/*----------------------------------------------------------------------
-- build_pfi - build PFI for given basis matrix.
--
-- *Synopsis*
--
-- #include "glppfi.h"
-- int build_pfi(PFI *pfi, MAT *A, int indb[]);
--
-- *Description*
--
-- The build_pfi routine builds PFI for the given basis matrix B (see
-- below) in the form B = B0*H, where B0 = B and H = I (unity matrix).
-- This is used when: (a) the current PFI became inaccurate, (b) the
-- current PFI 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 PFI 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 (in this case the partial
-- LU-factorization can be used to analyze what caused the problem; for
-- details see LU-factorization routines). */

#define maxtry 4

int build_pfi(PFI *pfi, MAT *A, int indb[])
{     static double tol[1+maxtry] = { 0.00, 0.01, 0.10, 0.40, 0.85 };
      int m = pfi->m, ret, try;
      double Bmax, Ubig;
      if (A->m != m)
         fault("build_pfi: invalid number of rows");
      /* try to build LU-factorization of the given basis matrix B */
      for (try = 1; try <= maxtry; try++)
      {  int i;
         /* U := B */
         clear_mat(pfi->lu->U);
         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_pfi: invalid column list");
            for (e = A->col[k]; e != NULL; e = e->col)
            {  if (e->val != 0.0)
                  new_elem(pfi->lu->U, e->i, i, e->val);
            }
         }
         /* build LU-factorization using gaussian elimination */
         ret = build_lu(pfi->lu, pfi->lu->U, tol[try], 1e+10, NULL,
            &Bmax, &Ubig);
         if (ret == 0 || try == maxtry) break;
      }
      /* reset eta-file (H := I) */
      reset_eta(pfi->eta);
      /* clear transformed column flag */
      pfi->flag = 0;
      return ret;
}

/*----------------------------------------------------------------------
-- pfi_ftran - perform forward transformation (FTRAN) using PFI.
--
-- *Synopsis*
--
-- #include "glppfi.h"
-- double *pfi_ftran(PFI *pfi, double z[], int save);
--
-- *Description*
--
-- The pfi_ftran routine performs forward transformation of the vector
-- z using PFI which pfi points to.
--
-- In order to perform this operation the routine solves the system
-- B*x = z, where B is the basis matrix defined by PFI, 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 then the pfi_ftran routine
-- saves the vector x (i.e. transformed column), which will be used by
-- the update_pfi routine to update PFI for adjacent basis matrix. It is
-- assumed that the simplex method routine should perform at least one
-- call to the pfi_ftran routine with the save parameter set.
--
-- *Returns*
--
-- The pfi_ftran routine returns a pointer to the array z. */

double *pfi_ftran(PFI *pfi, double z[], int save)
{     /* B = B0*H, therefore inv(B) = inv(H)*inv(B0) */
      solve_lu(pfi->lu, 0, z, pfi->work);
      h_solve(pfi->eta, z);
      if (save)
      {  /* save transformed column */
         int i;
         for (i = 1; i <= pfi->m; i++) pfi->col[i] = z[i];
         pfi->flag = 1;
      }
      return z;
}

/*----------------------------------------------------------------------
-- pfi_btran - perform backward transformation (BTRAN) using PFI.
--
-- *Synopsis*
--
-- #include "glppfi.h"
-- double *pfi_btran(PFI *pfi, double z[]);
--
-- *Description*
--
-- The pfi_btran routine performs backward transformation of the vector
-- z using PFI which pfi 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 PFI, 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 pfi_btran routine returns a pointer to the array z. */

double *pfi_btran(PFI *pfi, double z[])
{     ht_solve(pfi->eta, z);
      solve_lu(pfi->lu, 1, z, pfi->work);
      return z;
}

/*----------------------------------------------------------------------
-- update_pfi - update PFI for adjacent basis matrix.
--
-- *Synopsis*
--
-- #include "glppfi.h"
-- int update_pfi(PFI *pfi, int p);
--
-- *Description*
--
-- The update_pfi routine recomputes PFI corresponding to the current
-- basis matrix B, so that the updated PFI 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_pfi routine assumes that the transformed new
-- p-th column was saved before by the pfi_ftran routine.
--
-- *Returns*
--
-- The update_pfi routine returns one of the following codes:
--
-- 0 - PFI has been successfully updated;
-- 1 - PFI became inaccurate;
-- 2 - PFI became too long.
--
-- If the returned code is non-zero, PFI should be rebuilt by the means
-- of the build_pfi routine. */

int update_pfi(PFI *pfi, int p)
{     int m = pfi->m, i;
      double big, *h, rtol = 1e-6, drop = 1e-15;
      if (!(1 <= p && p <= m))
         fault("update_pfi: invalid column number");
      if (!pfi->flag)
         fault("update_pfi: transformed column not ready");
      /* the current basis matrix is B = B0*H; the new basis matrix is
         Bnew = B*Hcol = B0*H*Hcol = B0*Hnew, where Hnew = H*Hcol, and
         Hcol differs from the unity matrix only by one column, which
         is inv(B)*(new p-th column), i.e. that column is a result of
         forward transformation of new p-th column */
      h = pfi->col; /* p-th column of Hcol */
      /* compute maximal absolute value of elements of column h */
      big = 0.0;
      for (i = 1; i <= m; i++)
      {  double t = fabs(h[i]);
         if (big < t) big = t;
      }
      /* if diagonal element h[p] is relatively small, Hcol is near to
         singular matrix; therefore PFI should be rebuilt */
      if (h[p] == 0.0 || fabs(h[p]) < rtol * big) return 1;
      /* diagonal element of p-th column of Hcol becomes the first
         eta-term */
      app_term(pfi->eta, p, p, h[p]);
      /* non-zero non-diagonal elements of p-th column of Hcol become
         other eta-terms */
      for (i = 1; i <= m; i++)
      {  if (i == p) continue;
         if (h[i] == 0.0 || fabs(h[i]) < drop * big) continue;
         app_term(pfi->eta, i, p, h[i]);
      }
      /* if eta-file is too long, PFI should be rebuilt */
      {  int size = pfi->eta->pool->count;
         int nzL  = pfi->lu->L->pool->count;
         int nzU  = pfi->lu->U->pool->count;
         if (size > 3 * (nzL + nzU)) return 2;
      }
      /* the transformed column is no longer valid */
      pfi->flag = 0;
      /* PFI has been successfully updated */
      return 0;
}

/*----------------------------------------------------------------------
-- delete_pfi - delete PFI.
--
-- *Synopsis*
--
-- #include "glppfi.h"
-- void delete_pfi(PFI *pfi);
--
-- *Description*
--
-- The delete_pfi routine deletes PFI which pfi points to freeing all
-- memory allocated to this object. */

void delete_pfi(PFI *pfi)
{     delete_lu(pfi->lu);
      delete_eta(pfi->eta);
      ufree(pfi->col);
      ufree(pfi->work);
      ufree(pfi);
      return;
}

/* eof */
