/* glpapi6.c (glp_pivoting) */

/*----------------------------------------------------------------------
-- 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 "glpk.h"
#include "glprsm.h"

#define error print

/*----------------------------------------------------------------------
-- glp_init_piv1 - initialize parameter block by default values.
--
-- *Synopsis*
--
-- #include "glpk.h"
-- void glp_init_piv1(struct piv1 *parm);
--
-- *Description*
--
-- The routine glp_init_piv1 initializes parameter block passed to the
-- driver routines glp_pivot_in and glp_pivot_out by default values. */

void glp_init_piv1(struct piv1 *parm)
{     parm->scale = 0;
      parm->tol = 0.01;
      return;
}

/*----------------------------------------------------------------------
-- check_parm - check control parameters for correctness.
--
-- This routine checks control parameters specified in the parameter
-- block for correctness and returns one of the following codes:
--
-- 0 - no errors;
-- 1 - some control parameter has invalid value. */

static int check_parm(char *who, struct piv1 *p)
{     if (!(p->scale == 0 || p->scale == 1))
      {  error("%s: scale = %d; invalid parameter", who, p->scale);
         return 1;
      }
      if (!(0.0 < p->tol && p->tol < 1.0))
      {  error("%s: tol = %g; invalid parameter", who, p->tol);
         return 1;
      }
      return 0;
}

/*----------------------------------------------------------------------
-- scale_matrix - scale the constraint matrix.
--
-- This routine obtains row and column scale factors from the problem
-- object and constructs the scaling matrices R and S. Then the routine
-- uses the scaling matrices in order to scale the constraint matrix in
-- the RSM block (the problem object is not changed). */

static void scale_matrix(RSM *rsm, LPI *lp)
{     int m = rsm->m, n = rsm->n, i, j;
      double *R, *S;
      R = ucalloc(1+m, sizeof(double));
      S = ucalloc(1+n, sizeof(double));
      for (i = 1; i <= m; i++)
      {  R[i] = glp_get_row_fctr(lp, i);
         insist(R[i] > 0.0);
      }
      for (j = 1; j <= n; j++)
      {  S[j] = glp_get_col_fctr(lp, j);
         insist(S[j] > 0.0);
      }
      scale_rsm(rsm, R, S);
      ufree(R), ufree(S);
      return;
}

/*----------------------------------------------------------------------
-- assign_tagp - assign status to basic variable xB[p].
--
-- This routine assign status to the basic variable xB[p], which has
-- been chosen to leave the basis. */

static int assign_tagp(RSM *rsm, int p)
{     int k, tagp;
      insist(1 <= p && p <= rsm->m);
      k = rsm->indb[p]; /* xB[p] = x[k] */
      switch (rsm->type[k])
      {  case 'F':
            tagp = 'F'; break;
         case 'L':
            tagp = 'L'; break;
         case 'U':
            tagp = 'U'; break;
         case 'D':
            tagp = (fabs(rsm->lb[k]) <= fabs(rsm->ub[k]) ? 'L' : 'U');
            break;
         case 'S':
            tagp = 'S'; break;
         default:
            insist(rsm->type[k] != rsm->type[k]);
      }
      return tagp;
}

/*----------------------------------------------------------------------
-- store_basis - store basis information to the problem object.
--
-- This routine stores information about the final basis back to the
-- problem object. */

static void store_basis(RSM *rsm, LPI *lp)
{     int m = rsm->m, n = rsm->n, k;
      /* store statuses of auxiliary and structural variables */
      for (k = 1; k <= m+n; k++)
      {  int tagx;
         if (rsm->posx[k] > 0)
         {  /* x[k] is basic variable */
            tagx = 'B';
         }
         else
         {  /* x[k] is non-basic variable */
            tagx = rsm->tagn[-rsm->posx[k]];
         }
         if (k <= m)
         {  /* x[k] is auxiliary variable */
            glp_put_row_soln(lp, k, tagx, 0.0, 0.0);
         }
         else
         {  /* x[k] is structural variable */
            glp_put_col_soln(lp, k-m, tagx, 0.0, 0.0);
         }
      }
      /* store main solution information */
      glp_put_soln_info(lp, 'N', GLP_UNDEF, 0.0);
      return;
}

/*----------------------------------------------------------------------
-- glp_pivot_in - push auxiliary variables into the basis.
--
-- *Synopsis*
--
-- #include "glpk.h"
-- int glp_pivot_in(LPI *lp, int flag[], struct piv1 *parm);
--
-- *Description*
--
-- The routine glp_pivot_in() is a special version of the simplex
-- method. It performs necessary amount of simplex iterations in order
-- to enter specified auxiliary variables into the basis.
--
-- On entry the current basis should be specified in the problem object
-- lp. On exit the problem object will contain information about the new
-- basis constructed by the routine.
--
-- The array flag should have at least 1+m locations, where m is number
-- of rows (auxiliary variables). The location flag[0] is not used. If
-- flag[i] (1 <= i <= m) is non-zero, the routine tries to make the i-th
-- auxiliary variable be basic. Otherwise, the i-th auxiliary variable
-- is not considered.
--
-- The parameter parm is a pointer to the parameter block used by the
-- routine. This block may be initialized by the routine glp_init_piv1
-- by standard default values. This parameter may be NULL, in which case
-- standard default values are used.
--
-- *Returns*
--
--  0 - no errors;
-- -1 - all required auxiliary variables are basic, therefore no basis
--      transformations were performed;
-- +1 - invalid control parameter;
-- +2 - invalid current basis;
-- +3 - some required auxiliary variable can't be made basic;
-- +4 - numerical problems with the basis matrix.
--
-- If the return code is non-zero, the current basis specified in the
-- problem object is not changed. */

int glp_pivot_in(LPI *lp, int flag[], struct piv1 *parm)
{     struct piv1 _parm;
      RSM *rsm;
      int i, k, m, n, nz, nzmax, p, q, ret, tagx;
      double big, *aq;
      /* if parameter block is not specified, create the dummy one */
      if (parm == NULL)
      {  parm = &_parm;
         glp_init_piv1(parm);
      }
      /* check control parameters for correctness */
      if (check_parm("glp_pivot_in", parm)) return +1;
      /* determine problem dimension */
      m = glp_get_num_rows(lp);
      n = glp_get_num_cols(lp);
      if (m == 0) fault("glp_pivot_in: problem has no rows");
      if (n == 0) fault("glp_pivot_in: problem has no columns");
      /* check if all required auxiliary variables are basic */
      for (i = 1; i <= m; i++)
      {  if (flag[i])
         {  glp_get_row_soln(lp, i, &tagx, NULL, NULL);
            if (tagx != 'B') break;
         }
      }
      if (i > m) return -1;
      /* create RSM */
      rsm = create_rsm(lp);
      /* scale the constraint matrix (if required) */
      if (parm->scale) scale_matrix(rsm, lp);
      /* allocate auxiliary array */
      aq = ucalloc(1+m, sizeof(double));
      /* build the current basis as specified in the problem object */
      ret = build_basis(rsm, lp);
      if (ret != 0)
      {  ret = +2;
         goto done;
      }
      /* look through the list of auxiliary variables */
      for (k = 1; k <= m; k++)
      {  if (!flag[k]) continue;
         /* the k-th (auxiliary) variable is required to be basic */
         /* however if it is already basic, skip it */
         if (rsm->posx[k] > 0) continue;
         /* determine its position in the non-basic vector xN */
         q = - rsm->posx[k];
         insist(1 <= q && q <= n);
         /* thus, xN[q] should enter the basis; therefore we need to
            find an appropriate basic variable for interchange */
         /* compute q-th column of the current simplex table */
         eval_col(rsm, q, aq, 1);
         /* the q-th column of the simplex table looks like follows:
            xB[1] = ... + aq[1] * xN[q] + ...
            xB[2] = ... + aq[2] * xN[q] + ...
               .  .  .  .  .  .  .  .  .  .
            xB[m] = ... + aq[m] * xN[q] + ...
            therefore we can pull from the basis any basic variable
            xB[i], if the coefficient aq[i] is not so small */
         /* following Markowitz rule we choose the basic variable xB[p],
            coefficient aq[p] of which is not so small among other
            coefficients in the q-th column of the simplex table, and
            column of which in the constraint matrix has greatest number
            of non-zeros ("greatest" because this column will leave the
            basis matrix) */
         /* big := max|aq[i]| */
         big = 0.0;
         for (i = 1; i <= m; i++)
            if (big < fabs(aq[i])) big = fabs(aq[i]);
         /* look through the list of basic variables */
         p = 0, nzmax = 0;
         for (i = 1; i <= m; i++)
         {  /* if xB[i] is an auxiliary variable, which is required to
               be basic, skip it */
            if (rsm->indb[i] <= m && flag[rsm->indb[i]]) continue;
            /* check that aq[i] is no so small */
            if (aq[i] == 0.0 || fabs(aq[i]) < parm->tol * big) continue;
            /* count number of non-zeros in column of the constraint
               matrix, which corresponds to xB[i] */
            nz = count_nz(rsm->A, -rsm->indb[i]);
            /* apply Markowitz rule */
            if (p == 0 || nzmax < nz ||
                nzmax == nz && fabs(aq[p]) < fabs(aq[i]))
                  p = i, nzmax = nz;
         }
         /* if xB[p] has not been chosen, it is not possible to make
            xN[q] be basic */
         if (p == 0)
         {  ret = +3;
            goto done;
         }
         /* perform one simplex iteration in order to interchange the
            variables xB[p] and xN[q] */
         ret = change_b(rsm, p, assign_tagp(rsm, p), q);
         if (ret != 0)
         {  ret = +4;
            goto done;
         }
      }
      /* the basis has been transformed to the desired form; bring it
         back to the problem object */
      store_basis(rsm, lp);
done: /* free working arrays and returns to the calling program */
      delete_rsm(rsm);
      ufree(aq);
      return ret;
}

/*----------------------------------------------------------------------
-- glp_pivot_out - pull structural variables from the basis.
--
-- *Synopsis*
--
-- #include "glpk.h"
-- int glp_pivot_out(LPI *lp, int flag[], struct piv1 *parm);
--
-- *Description*
--
-- The routine glp_pivot_out() is a special version of the simplex
-- method. It performs necessary amount of simplex iterations in order
-- to pull specified structural variables from the basis.
--
-- On entry the current basis should be specified in the problem object
-- lp. On exit the problem object will contain information about the new
-- basis constructed by the routine.
--
-- The array flag should have at least 1+n locations, where n is number
-- of columns (structural variables). The location flag[0] is not used.
-- If flag[j] (1 <= j <= n) is non-zero, the routine tries to make j-th
-- structural variable be non-basic. Otherwise, the j-th structural
-- variable is not considered.
--
-- The parameter parm is a pointer to the parameter block used by the
-- routine. This block may be initialized by the routine glp_init_piv1
-- by standard default values. This parameter may be NULL, in which case
-- standard default values are used.
--
-- *Returns*
--
--  0 - no errors;
-- -1 - all required structural variables are non-basic, therefore no
--      basis transformations were performed;
-- +1 - invalid control parameter;
-- +2 - invalid current basis;
-- +3 - some required structural variables can't be made non-basic;
-- +4 - numerical problems with the basis matrix.
--
-- If the return code is non-zero, the current basis specified in the
-- problem object is not changed. */

int glp_pivot_out(LPI *lp, int flag[], struct piv1 parm[])
{     struct piv1 _parm;
      RSM *rsm;
      int j, k, m, n, nz, nzmin, p, q, ret, tagx;
      double big, *zeta, *ap;
      /* if parameter block is not specified, create the dummy one */
      if (parm == NULL)
      {  parm = &_parm;
         glp_init_piv1(parm);
      }
      /* check control parameters for correctness */
      if (check_parm("glp_pivot_out", parm)) return +1;
      /* determine problem dimension */
      m = glp_get_num_rows(lp);
      n = glp_get_num_cols(lp);
      if (m == 0) fault("glp_pivot_out: problem has no rows");
      if (n == 0) fault("glp_pivot_out: problem has no columns");
      /* check if all required structural variables are non-basic */
      for (j = 1; j <= n; j++)
      {  if (flag[j])
         {  glp_get_col_soln(lp, j, &tagx, NULL, NULL);
            if (tagx == 'B') break;
         }
      }
      if (j > n) return -1;
      /* create RSM */
      rsm = create_rsm(lp);
      /* scale the constraint matrix (if required) */
      if (parm->scale) scale_matrix(rsm, lp);
      /* allocate auxiliary arrays */
      zeta = ucalloc(1+m, sizeof(double));
      ap = ucalloc(1+n, sizeof(double));
      /* build the current basis as specified in the problem object */
      ret = build_basis(rsm, lp);
      if (ret != 0)
      {  ret = +2;
         goto done;
      }
      /* look through the list of structural variables */
      for (k = m+1; k <= m+n; k++)
      {  if (!flag[k-m]) continue;
         /* the k-th (structural) variable is req'd to be non-basic */
         /* however if it is already non-basic, skip it */
         if (rsm->posx[k] < 0) continue;
         /* determine its position if the basic vector xB */
         p = + rsm->posx[k];
         insist(1 <= p && p <= m);
         /* thus, xB[p] should leave the basis; therefore we need to
            find an appropriate non-basic variable for interchange */
         /* compute p-th row of the current simplex table */
         eval_zeta(rsm, p, zeta);
         eval_row(rsm, zeta, ap);
         /* the p-th row of the simplex table looks like follows:
            xB[p] = ap[1]*xN[1] + ap[2]*xN[2] + ... + ap[n]*xN[n]
            therefore we can push into the basis any non-basic variable
            xN[j], if the coefficient ap[j] is not so small */
         /* following Markowitz rule we choose the non-basic variable
            xN[q], coefficient ap[q] of which is not so small among
            other coefficients in the p-th row of the simplex table, and
            column of which in the constraint matrix has smallest number
            of non-zeros ("smallest" because this column will enter the
            basis matrix */
         /* big := max|ap[j]| */
         big = 0.0;
         for (j = 1; j <= n; j++)
            if (big < fabs(ap[j])) big = fabs(ap[j]);
         /* look through the list of non-basic variables */
         q = 0, nzmin = m+1;
         for (j = 1; j <= n; j++)
         {  /* if xN[j] is structural variable, which is required to be
               non-basic, skip it */
            if (rsm->indn[j] > m && flag[rsm->indn[j]-m]) continue;
            /* check that ap[j] is not so small */
            if (ap[j] == 0.0 || fabs(ap[j]) < parm->tol * big) continue;
            /* count number of non-zeros in column of the constraint
               matrix, which corresponds to xN[j] */
            nz = count_nz(rsm->A, -rsm->indn[j]);
            /* apply Markowitz rule */
            if (q == 0 || nzmin > nz ||
                nzmin == nz && fabs(ap[q]) < fabs(ap[j]))
                  q = j, nzmin = nz;
         }
         /* if xN[q] has not been chosen, it is not possible to make
            xB[p] be non-basic */
         if (q == 0)
         {  ret = +3;
            goto done;
         }
         /* compute q-th column of the current simplex table (this is
            needed to prepare column of xN[q] via ftran) */
         eval_col(rsm, q, zeta, 1);
         /* perform one simplex iteration in order to interchange the
            variables xB[p] and xN[q] */
         ret = change_b(rsm, p, assign_tagp(rsm, p), q);
         if (ret != 0)
         {  ret = +4;
            goto done;
         }
      }
      /* the basis has been transformed to the desired form; bring it
         back to the problem object */
      store_basis(rsm, lp);
done: /* free working arrays and returns to the calling program */
      delete_rsm(rsm);
      ufree(zeta);
      ufree(ap);
      return ret;
}

/* eof */
