alpar@1: /* glpmps.c (MPS format routines) */
alpar@1: 
alpar@1: /***********************************************************************
alpar@1: *  This code is part of GLPK (GNU Linear Programming Kit).
alpar@1: *
alpar@1: *  Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
alpar@1: *  2009, 2010 Andrew Makhorin, Department for Applied Informatics,
alpar@1: *  Moscow Aviation Institute, Moscow, Russia. All rights reserved.
alpar@1: *  E-mail: <mao@gnu.org>.
alpar@1: *
alpar@1: *  GLPK is free software: you can redistribute it and/or modify it
alpar@1: *  under the terms of the GNU General Public License as published by
alpar@1: *  the Free Software Foundation, either version 3 of the License, or
alpar@1: *  (at your option) any later version.
alpar@1: *
alpar@1: *  GLPK is distributed in the hope that it will be useful, but WITHOUT
alpar@1: *  ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
alpar@1: *  or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public
alpar@1: *  License for more details.
alpar@1: *
alpar@1: *  You should have received a copy of the GNU General Public License
alpar@1: *  along with GLPK. If not, see <http://www.gnu.org/licenses/>.
alpar@1: ***********************************************************************/
alpar@1: 
alpar@1: #include "glpapi.h"
alpar@1: 
alpar@1: /***********************************************************************
alpar@1: *  NAME
alpar@1: *
alpar@1: *  glp_init_mpscp - initialize MPS format control parameters
alpar@1: *
alpar@1: *  SYNOPSIS
alpar@1: *
alpar@1: *  void glp_init_mpscp(glp_mpscp *parm);
alpar@1: *
alpar@1: *  DESCRIPTION
alpar@1: *
alpar@1: *  The routine glp_init_mpscp initializes control parameters, which are
alpar@1: *  used by the MPS input/output routines glp_read_mps and glp_write_mps,
alpar@1: *  with default values.
alpar@1: *
alpar@1: *  Default values of the control parameters are stored in the glp_mpscp
alpar@1: *  structure, which the parameter parm points to. */
alpar@1: 
alpar@1: void glp_init_mpscp(glp_mpscp *parm)
alpar@1: {     parm->blank = '\0';
alpar@1:       parm->obj_name = NULL;
alpar@1:       parm->tol_mps = 1e-12;
alpar@1:       return;
alpar@1: }
alpar@1: 
alpar@1: static void check_parm(const char *func, const glp_mpscp *parm)
alpar@1: {     /* check control parameters */
alpar@1:       if (!(0x00 <= parm->blank && parm->blank <= 0xFF) ||
alpar@1:           !(parm->blank == '\0' || isprint(parm->blank)))
alpar@1:          xerror("%s: blank = 0x%02X; invalid parameter\n",
alpar@1:             func, parm->blank);
alpar@1:       if (!(parm->obj_name == NULL || strlen(parm->obj_name) <= 255))
alpar@1:          xerror("%s: obj_name = \"%.12s...\"; parameter too long\n",
alpar@1:             func, parm->obj_name);
alpar@1:       if (!(0.0 <= parm->tol_mps && parm->tol_mps < 1.0))
alpar@1:          xerror("%s: tol_mps = %g; invalid parameter\n",
alpar@1:             func, parm->tol_mps);
alpar@1:       return;
alpar@1: }
alpar@1: 
alpar@1: /***********************************************************************
alpar@1: *  NAME
alpar@1: *
alpar@1: *  glp_read_mps - read problem data in MPS format
alpar@1: *
alpar@1: *  SYNOPSIS
alpar@1: *
alpar@1: *  int glp_read_mps(glp_prob *P, int fmt, const glp_mpscp *parm,
alpar@1: *     const char *fname);
alpar@1: *
alpar@1: *  DESCRIPTION
alpar@1: *
alpar@1: *  The routine glp_read_mps reads problem data in MPS format from a
alpar@1: *  text file.
alpar@1: *
alpar@1: *  The parameter fmt specifies the version of MPS format:
alpar@1: *
alpar@1: *  GLP_MPS_DECK - fixed (ancient) MPS format;
alpar@1: *  GLP_MPS_FILE - free (modern) MPS format.
alpar@1: *
alpar@1: *  The parameter parm is a pointer to the structure glp_mpscp, which
alpar@1: *  specifies control parameters used by the routine. If parm is NULL,
alpar@1: *  the routine uses default settings.
alpar@1: *
alpar@1: *  The character string fname specifies a name of the text file to be
alpar@1: *  read.
alpar@1: *
alpar@1: *  Note that before reading data the current content of the problem
alpar@1: *  object is completely erased with the routine glp_erase_prob.
alpar@1: *
alpar@1: *  RETURNS
alpar@1: *
alpar@1: *  If the operation was successful, the routine glp_read_mps returns
alpar@1: *  zero. Otherwise, it prints an error message and returns non-zero. */
alpar@1: 
alpar@1: struct csa
alpar@1: {     /* common storage area */
alpar@1:       glp_prob *P;
alpar@1:       /* pointer to problem object */
alpar@1:       int deck;
alpar@1:       /* MPS format (0 - free, 1 - fixed) */
alpar@1:       const glp_mpscp *parm;
alpar@1:       /* pointer to control parameters */
alpar@1:       const char *fname;
alpar@1:       /* name of input MPS file */
alpar@1:       XFILE *fp;
alpar@1:       /* stream assigned to input MPS file */
alpar@1:       jmp_buf jump;
alpar@1:       /* label for go to in case of error */
alpar@1:       int recno;
alpar@1:       /* current record (card) number */
alpar@1:       int recpos;
alpar@1:       /* current record (card) position */
alpar@1:       int c;
alpar@1:       /* current character */
alpar@1:       int fldno;
alpar@1:       /* current field number */
alpar@1:       char field[255+1];
alpar@1:       /* current field content */
alpar@1:       int w80;
alpar@1:       /* warning 'record must not be longer than 80 chars' issued */
alpar@1:       int wef;
alpar@1:       /* warning 'extra fields detected beyond field 6' issued */
alpar@1:       int obj_row;
alpar@1:       /* objective row number */
alpar@1:       void *work1, *work2, *work3;
alpar@1:       /* working arrays */
alpar@1: };
alpar@1: 
alpar@1: static void error(struct csa *csa, const char *fmt, ...)
alpar@1: {     /* print error message and terminate processing */
alpar@1:       va_list arg;
alpar@1:       xprintf("%s:%d: ", csa->fname, csa->recno);
alpar@1:       va_start(arg, fmt);
alpar@1:       xvprintf(fmt, arg);
alpar@1:       va_end(arg);
alpar@1:       longjmp(csa->jump, 1);
alpar@1:       /* no return */
alpar@1: }
alpar@1: 
alpar@1: static void warning(struct csa *csa, const char *fmt, ...)
alpar@1: {     /* print warning message and continue processing */
alpar@1:       va_list arg;
alpar@1:       xprintf("%s:%d: warning: ", csa->fname, csa->recno);
alpar@1:       va_start(arg, fmt);
alpar@1:       xvprintf(fmt, arg);
alpar@1:       va_end(arg);
alpar@1:       return;
alpar@1: }
alpar@1: 
alpar@1: static void read_char(struct csa *csa)
alpar@1: {     /* read next character */
alpar@1:       int c;
alpar@1:       if (csa->c == '\n')
alpar@1:          csa->recno++, csa->recpos = 0;
alpar@1:       csa->recpos++;
alpar@1: read: c = xfgetc(csa->fp);
alpar@1:       if (c < 0)
alpar@1:       {  if (xferror(csa->fp))
alpar@1:             error(csa, "read error - %s\n", xerrmsg());
alpar@1:          else if (csa->c == '\n')
alpar@1:             error(csa, "unexpected end of file\n");
alpar@1:          else
alpar@1:          {  warning(csa, "missing final end of line\n");
alpar@1:             c = '\n';
alpar@1:          }
alpar@1:       }
alpar@1:       else if (c == '\n')
alpar@1:          ;
alpar@1:       else if (csa->c == '\r')
alpar@1:       {  c = '\r';
alpar@1:          goto badc;
alpar@1:       }
alpar@1:       else if (csa->deck && c == '\r')
alpar@1:       {  csa->c = '\r';
alpar@1:          goto read;
alpar@1:       }
alpar@1:       else if (c == ' ')
alpar@1:          ;
alpar@1:       else if (isspace(c))
alpar@1:       {  if (csa->deck)
alpar@1: badc:       error(csa, "in fixed MPS format white-space character 0x%02"
alpar@1:                "X is not allowed\n", c);
alpar@1:          c = ' ';
alpar@1:       }
alpar@1:       else if (iscntrl(c))
alpar@1:          error(csa, "invalid control character 0x%02X\n", c);
alpar@1:       if (csa->deck && csa->recpos == 81 && c != '\n' && csa->w80 < 1)
alpar@1:       {  warning(csa, "in fixed MPS format record must not be longer th"
alpar@1:             "an 80 characters\n");
alpar@1:          csa->w80++;
alpar@1:       }
alpar@1:       csa->c = c;
alpar@1:       return;
alpar@1: }
alpar@1: 
alpar@1: static int indicator(struct csa *csa, int name)
alpar@1: {     /* skip comment records and read possible indicator record */
alpar@1:       int ret;
alpar@1:       /* reset current field number */
alpar@1:       csa->fldno = 0;
alpar@1: loop: /* read the very first character of the next record */
alpar@1:       xassert(csa->c == '\n');
alpar@1:       read_char(csa);
alpar@1:       if (csa->c == ' ' || csa->c == '\n')
alpar@1:       {  /* data record */
alpar@1:          ret = 0;
alpar@1:       }
alpar@1:       else if (csa->c == '*')
alpar@1:       {  /* comment record */
alpar@1:          while (csa->c != '\n')
alpar@1:             read_char(csa);
alpar@1:          goto loop;
alpar@1:       }
alpar@1:       else
alpar@1:       {  /* indicator record */
alpar@1:          int len = 0;
alpar@1:          while (csa->c != ' ' && csa->c != '\n' && len < 12)
alpar@1:          {  csa->field[len++] = (char)csa->c;
alpar@1:             read_char(csa);
alpar@1:          }
alpar@1:          csa->field[len] = '\0';
alpar@1:          if (!(strcmp(csa->field, "NAME")    == 0 ||
alpar@1:                strcmp(csa->field, "ROWS")    == 0 ||
alpar@1:                strcmp(csa->field, "COLUMNS") == 0 ||
alpar@1:                strcmp(csa->field, "RHS")     == 0 ||
alpar@1:                strcmp(csa->field, "RANGES")  == 0 ||
alpar@1:                strcmp(csa->field, "BOUNDS")  == 0 ||
alpar@1:                strcmp(csa->field, "ENDATA")  == 0))
alpar@1:             error(csa, "invalid indicator record\n");
alpar@1:          if (!name)
alpar@1:          {  while (csa->c != '\n')
alpar@1:                read_char(csa);
alpar@1:          }
alpar@1:          ret = 1;
alpar@1:       }
alpar@1:       return ret;
alpar@1: }
alpar@1: 
alpar@1: static void read_field(struct csa *csa)
alpar@1: {     /* read next field of the current data record */
alpar@1:       csa->fldno++;
alpar@1:       if (csa->deck)
alpar@1:       {  /* fixed MPS format */
alpar@1:          int beg, end, pos;
alpar@1:          /* determine predefined field positions */
alpar@1:          if (csa->fldno == 1)
alpar@1:             beg = 2, end = 3;
alpar@1:          else if (csa->fldno == 2)
alpar@1:             beg = 5, end = 12;
alpar@1:          else if (csa->fldno == 3)
alpar@1:             beg = 15, end = 22;
alpar@1:          else if (csa->fldno == 4)
alpar@1:             beg = 25, end = 36;
alpar@1:          else if (csa->fldno == 5)
alpar@1:             beg = 40, end = 47;
alpar@1:          else if (csa->fldno == 6)
alpar@1:             beg = 50, end = 61;
alpar@1:          else
alpar@1:             xassert(csa != csa);
alpar@1:          /* skip blanks preceding the current field */
alpar@1:          if (csa->c != '\n')
alpar@1:          {  pos = csa->recpos;
alpar@1:             while (csa->recpos < beg)
alpar@1:             {  if (csa->c == ' ')
alpar@1:                   ;
alpar@1:                else if (csa->c == '\n')
alpar@1:                   break;
alpar@1:                else
alpar@1:                   error(csa, "in fixed MPS format positions %d-%d must "
alpar@1:                      "be blank\n", pos, beg-1);
alpar@1:                read_char(csa);
alpar@1:             }
alpar@1:          }
alpar@1:          /* skip possible comment beginning in the field 3 or 5 */
alpar@1:          if ((csa->fldno == 3 || csa->fldno == 5) && csa->c == '$')
alpar@1:          {  while (csa->c != '\n')
alpar@1:                read_char(csa);
alpar@1:          }
alpar@1:          /* read the current field */
alpar@1:          for (pos = beg; pos <= end; pos++)
alpar@1:          {  if (csa->c == '\n') break;
alpar@1:             csa->field[pos-beg] = (char)csa->c;
alpar@1:             read_char(csa);
alpar@1:          }
alpar@1:          csa->field[pos-beg] = '\0';
alpar@1:          strtrim(csa->field);
alpar@1:          /* skip blanks following the last field */
alpar@1:          if (csa->fldno == 6 && csa->c != '\n')
alpar@1:          {  while (csa->recpos <= 72)
alpar@1:             {  if (csa->c == ' ')
alpar@1:                   ;
alpar@1:                else if (csa->c == '\n')
alpar@1:                   break;
alpar@1:                else
alpar@1:                   error(csa, "in fixed MPS format positions 62-72 must "
alpar@1:                      "be blank\n");
alpar@1:                read_char(csa);
alpar@1:             }
alpar@1:             while (csa->c != '\n')
alpar@1:                read_char(csa);
alpar@1:          }
alpar@1:       }
alpar@1:       else
alpar@1:       {  /* free MPS format */
alpar@1:          int len;
alpar@1:          /* skip blanks preceding the current field */
alpar@1:          while (csa->c == ' ')
alpar@1:             read_char(csa);
alpar@1:          /* skip possible comment */
alpar@1:          if (csa->c == '$')
alpar@1:          {  while (csa->c != '\n')
alpar@1:                read_char(csa);
alpar@1:          }
alpar@1:          /* read the current field */
alpar@1:          len = 0;
alpar@1:          while (!(csa->c == ' ' || csa->c == '\n'))
alpar@1:          {  if (len == 255)
alpar@1:                error(csa, "length of field %d exceeds 255 characters\n",
alpar@1:                   csa->fldno++);
alpar@1:             csa->field[len++] = (char)csa->c;
alpar@1:             read_char(csa);
alpar@1:          }
alpar@1:          csa->field[len] = '\0';
alpar@1:          /* skip anything following the last field (any extra fields
alpar@1:             are considered to be comments) */
alpar@1:          if (csa->fldno == 6)
alpar@1:          {  while (csa->c == ' ')
alpar@1:                read_char(csa);
alpar@1:             if (csa->c != '$' && csa->c != '\n' && csa->wef < 1)
alpar@1:             {  warning(csa, "some extra field(s) detected beyond field "
alpar@1:                   "6; field(s) ignored\n");
alpar@1:                csa->wef++;
alpar@1:             }
alpar@1:             while (csa->c != '\n')
alpar@1:                read_char(csa);
alpar@1:          }
alpar@1:       }
alpar@1:       return;
alpar@1: }
alpar@1: 
alpar@1: static void patch_name(struct csa *csa, char *name)
alpar@1: {     /* process embedded blanks in symbolic name */
alpar@1:       int blank = csa->parm->blank;
alpar@1:       if (blank == '\0')
alpar@1:       {  /* remove emedded blanks */
alpar@1:          strspx(name);
alpar@1:       }
alpar@1:       else
alpar@1:       {  /* replace embedded blanks by specified character */
alpar@1:          for (; *name != '\0'; name++)
alpar@1:             if (*name == ' ') *name = (char)blank;
alpar@1:       }
alpar@1:       return;
alpar@1: }
alpar@1: 
alpar@1: static double read_number(struct csa *csa)
alpar@1: {     /* read next field and convert it to floating-point number */
alpar@1:       double x;
alpar@1:       char *s;
alpar@1:       /* read next field */
alpar@1:       read_field(csa);
alpar@1:       xassert(csa->fldno == 4 || csa->fldno == 6);
alpar@1:       if (csa->field[0] == '\0')
alpar@1:          error(csa, "missing numeric value in field %d\n", csa->fldno);
alpar@1:       /* skip initial spaces of the field */
alpar@1:       for (s = csa->field; *s == ' '; s++);
alpar@1:       /* perform conversion */
alpar@1:       if (str2num(s, &x) != 0)
alpar@1:          error(csa, "cannot convert `%s' to floating-point number\n",
alpar@1:             s);
alpar@1:       return x;
alpar@1: }
alpar@1: 
alpar@1: static void skip_field(struct csa *csa)
alpar@1: {     /* read and skip next field (assumed to be blank) */
alpar@1:       read_field(csa);
alpar@1:       if (csa->field[0] != '\0')
alpar@1:          error(csa, "field %d must be blank\n", csa->fldno);
alpar@1:       return;
alpar@1: }
alpar@1: 
alpar@1: static void read_name(struct csa *csa)
alpar@1: {     /* read NAME indicator record */
alpar@1:       if (!(indicator(csa, 1) && strcmp(csa->field, "NAME") == 0))
alpar@1:          error(csa, "missing NAME indicator record\n");
alpar@1:       /* this indicator record looks like a data record; simulate that
alpar@1:          fields 1 and 2 were read */
alpar@1:       csa->fldno = 2;
alpar@1:       /* field 3: model name */
alpar@1:       read_field(csa), patch_name(csa, csa->field);
alpar@1:       if (csa->field[0] == '\0')
alpar@1:          warning(csa, "missing model name in field 3\n");
alpar@1:       else
alpar@1:          glp_set_prob_name(csa->P, csa->field);
alpar@1:       /* skip anything following field 3 */
alpar@1:       while (csa->c != '\n')
alpar@1:          read_char(csa);
alpar@1:       return;
alpar@1: }
alpar@1: 
alpar@1: static void read_rows(struct csa *csa)
alpar@1: {     /* read ROWS section */
alpar@1:       int i, type;
alpar@1: loop: if (indicator(csa, 0)) goto done;
alpar@1:       /* field 1: row type */
alpar@1:       read_field(csa), strspx(csa->field);
alpar@1:       if (strcmp(csa->field, "N") == 0)
alpar@1:          type = GLP_FR;
alpar@1:       else if (strcmp(csa->field, "G") == 0)
alpar@1:          type = GLP_LO;
alpar@1:       else if (strcmp(csa->field, "L") == 0)
alpar@1:          type = GLP_UP;
alpar@1:       else if (strcmp(csa->field, "E") == 0)
alpar@1:          type = GLP_FX;
alpar@1:       else if (csa->field[0] == '\0')
alpar@1:          error(csa, "missing row type in field 1\n");
alpar@1:       else
alpar@1:          error(csa, "invalid row type in field 1\n");
alpar@1:       /* field 2: row name */
alpar@1:       read_field(csa), patch_name(csa, csa->field);
alpar@1:       if (csa->field[0] == '\0')
alpar@1:          error(csa, "missing row name in field 2\n");
alpar@1:       if (glp_find_row(csa->P, csa->field) != 0)
alpar@1:          error(csa, "row `%s' multiply specified\n", csa->field);
alpar@1:       i = glp_add_rows(csa->P, 1);
alpar@1:       glp_set_row_name(csa->P, i, csa->field);
alpar@1:       glp_set_row_bnds(csa->P, i, type, 0.0, 0.0);
alpar@1:       /* fields 3, 4, 5, and 6 must be blank */
alpar@1:       skip_field(csa);
alpar@1:       skip_field(csa);
alpar@1:       skip_field(csa);
alpar@1:       skip_field(csa);
alpar@1:       goto loop;
alpar@1: done: return;
alpar@1: }
alpar@1: 
alpar@1: static void read_columns(struct csa *csa)
alpar@1: {     /* read COLUMNS section */
alpar@1:       int i, j, f, len, kind = GLP_CV, *ind;
alpar@1:       double aij, *val;
alpar@1:       char name[255+1], *flag;
alpar@1:       /* allocate working arrays */
alpar@1:       csa->work1 = ind = xcalloc(1+csa->P->m, sizeof(int));
alpar@1:       csa->work2 = val = xcalloc(1+csa->P->m, sizeof(double));
alpar@1:       csa->work3 = flag = xcalloc(1+csa->P->m, sizeof(char));
alpar@1:       memset(&flag[1], 0, csa->P->m);
alpar@1:       /* no current column exists */
alpar@1:       j = 0, len = 0;
alpar@1: loop: if (indicator(csa, 0)) goto done;
alpar@1:       /* field 1 must be blank */
alpar@1:       if (csa->deck)
alpar@1:       {  read_field(csa);
alpar@1:          if (csa->field[0] != '\0')
alpar@1:             error(csa, "field 1 must be blank\n");
alpar@1:       }
alpar@1:       else
alpar@1:          csa->fldno++;
alpar@1:       /* field 2: column or kind name */
alpar@1:       read_field(csa), patch_name(csa, csa->field);
alpar@1:       strcpy(name, csa->field);
alpar@1:       /* field 3: row name or keyword 'MARKER' */
alpar@1:       read_field(csa), patch_name(csa, csa->field);
alpar@1:       if (strcmp(csa->field, "'MARKER'") == 0)
alpar@1:       {  /* process kind data record */
alpar@1:          /* field 4 must be blank */
alpar@1:          if (csa->deck)
alpar@1:          {  read_field(csa);
alpar@1:             if (csa->field[0] != '\0')
alpar@1:                error(csa, "field 4 must be blank\n");
alpar@1:          }
alpar@1:          else
alpar@1:             csa->fldno++;
alpar@1:          /* field 5: keyword 'INTORG' or 'INTEND' */
alpar@1:          read_field(csa), patch_name(csa, csa->field);
alpar@1:          if (strcmp(csa->field, "'INTORG'") == 0)
alpar@1:             kind = GLP_IV;
alpar@1:          else if (strcmp(csa->field, "'INTEND'") == 0)
alpar@1:             kind = GLP_CV;
alpar@1:          else if (csa->field[0] == '\0')
alpar@1:             error(csa, "missing keyword in field 5\n");
alpar@1:          else
alpar@1:             error(csa, "invalid keyword in field 5\n");
alpar@1:          /* field 6 must be blank */
alpar@1:          skip_field(csa);
alpar@1:          goto loop;
alpar@1:       }
alpar@1:       /* process column name specified in field 2 */
alpar@1:       if (name[0] == '\0')
alpar@1:       {  /* the same column as in previous data record */
alpar@1:          if (j == 0)
alpar@1:             error(csa, "missing column name in field 2\n");
alpar@1:       }
alpar@1:       else if (j != 0 && strcmp(name, csa->P->col[j]->name) == 0)
alpar@1:       {  /* the same column as in previous data record */
alpar@1:          xassert(j != 0);
alpar@1:       }
alpar@1:       else
alpar@1:       {  /* store the current column */
alpar@1:          if (j != 0)
alpar@1:          {  glp_set_mat_col(csa->P, j, len, ind, val);
alpar@1:             while (len > 0) flag[ind[len--]] = 0;
alpar@1:          }
alpar@1:          /* create new column */
alpar@1:          if (glp_find_col(csa->P, name) != 0)
alpar@1:             error(csa, "column `%s' multiply specified\n", name);
alpar@1:          j = glp_add_cols(csa->P, 1);
alpar@1:          glp_set_col_name(csa->P, j, name);
alpar@1:          glp_set_col_kind(csa->P, j, kind);
alpar@1:          if (kind == GLP_CV)
alpar@1:             glp_set_col_bnds(csa->P, j, GLP_LO, 0.0, 0.0);
alpar@1:          else if (kind == GLP_IV)
alpar@1:             glp_set_col_bnds(csa->P, j, GLP_DB, 0.0, 1.0);
alpar@1:          else
alpar@1:             xassert(kind != kind);
alpar@1:       }
alpar@1:       /* process fields 3-4 and 5-6 */
alpar@1:       for (f = 3; f <= 5; f += 2)
alpar@1:       {  /* field 3 or 5: row name */
alpar@1:          if (f == 3)
alpar@1:          {  if (csa->field[0] == '\0')
alpar@1:                error(csa, "missing row name in field 3\n");
alpar@1:          }
alpar@1:          else
alpar@1:          {  read_field(csa), patch_name(csa, csa->field);
alpar@1:             if (csa->field[0] == '\0')
alpar@1:             {  /* if field 5 is blank, field 6 also must be blank */
alpar@1:                skip_field(csa);
alpar@1:                continue;
alpar@1:             }
alpar@1:          }
alpar@1:          i = glp_find_row(csa->P, csa->field);
alpar@1:          if (i == 0)
alpar@1:             error(csa, "row `%s' not found\n", csa->field);
alpar@1:          if (flag[i])
alpar@1:             error(csa, "duplicate coefficient in row `%s'\n",
alpar@1:                csa->field);
alpar@1:          /* field 4 or 6: coefficient value */
alpar@1:          aij = read_number(csa);
alpar@1:          if (fabs(aij) < csa->parm->tol_mps) aij = 0.0;
alpar@1:          len++, ind[len] = i, val[len] = aij, flag[i] = 1;
alpar@1:       }
alpar@1:       goto loop;
alpar@1: done: /* store the last column */
alpar@1:       if (j != 0)
alpar@1:          glp_set_mat_col(csa->P, j, len, ind, val);
alpar@1:       /* free working arrays */
alpar@1:       xfree(ind);
alpar@1:       xfree(val);
alpar@1:       xfree(flag);
alpar@1:       csa->work1 = csa->work2 = csa->work3 = NULL;
alpar@1:       return;
alpar@1: }
alpar@1: 
alpar@1: static void read_rhs(struct csa *csa)
alpar@1: {     /* read RHS section */
alpar@1:       int i, f, v, type;
alpar@1:       double rhs;
alpar@1:       char name[255+1], *flag;
alpar@1:       /* allocate working array */
alpar@1:       csa->work3 = flag = xcalloc(1+csa->P->m, sizeof(char));
alpar@1:       memset(&flag[1], 0, csa->P->m);
alpar@1:       /* no current RHS vector exists */
alpar@1:       v = 0;
alpar@1: loop: if (indicator(csa, 0)) goto done;
alpar@1:       /* field 1 must be blank */
alpar@1:       if (csa->deck)
alpar@1:       {  read_field(csa);
alpar@1:          if (csa->field[0] != '\0')
alpar@1:             error(csa, "field 1 must be blank\n");
alpar@1:       }
alpar@1:       else
alpar@1:          csa->fldno++;
alpar@1:       /* field 2: RHS vector name */
alpar@1:       read_field(csa), patch_name(csa, csa->field);
alpar@1:       if (csa->field[0] == '\0')
alpar@1:       {  /* the same RHS vector as in previous data record */
alpar@1:          if (v == 0)
alpar@1:          {  warning(csa, "missing RHS vector name in field 2\n");
alpar@1:             goto blnk;
alpar@1:          }
alpar@1:       }
alpar@1:       else if (v != 0 && strcmp(csa->field, name) == 0)
alpar@1:       {  /* the same RHS vector as in previous data record */
alpar@1:          xassert(v != 0);
alpar@1:       }
alpar@1:       else
alpar@1: blnk: {  /* new RHS vector */
alpar@1:          if (v != 0)
alpar@1:             error(csa, "multiple RHS vectors not supported\n");
alpar@1:          v++;
alpar@1:          strcpy(name, csa->field);
alpar@1:       }
alpar@1:       /* process fields 3-4 and 5-6 */
alpar@1:       for (f = 3; f <= 5; f += 2)
alpar@1:       {  /* field 3 or 5: row name */
alpar@1:          read_field(csa), patch_name(csa, csa->field);
alpar@1:          if (csa->field[0] == '\0')
alpar@1:          {  if (f == 3)
alpar@1:                error(csa, "missing row name in field 3\n");
alpar@1:             else
alpar@1:             {  /* if field 5 is blank, field 6 also must be blank */
alpar@1:                skip_field(csa);
alpar@1:                continue;
alpar@1:             }
alpar@1:          }
alpar@1:          i = glp_find_row(csa->P, csa->field);
alpar@1:          if (i == 0)
alpar@1:             error(csa, "row `%s' not found\n", csa->field);
alpar@1:          if (flag[i])
alpar@1:             error(csa, "duplicate right-hand side for row `%s'\n",
alpar@1:                csa->field);
alpar@1:          /* field 4 or 6: right-hand side value */
alpar@1:          rhs = read_number(csa);
alpar@1:          if (fabs(rhs) < csa->parm->tol_mps) rhs = 0.0;
alpar@1:          type = csa->P->row[i]->type;
alpar@1:          if (type == GLP_FR)
alpar@1:          {  if (i == csa->obj_row)
alpar@1:                glp_set_obj_coef(csa->P, 0, rhs);
alpar@1:             else if (rhs != 0.0)
alpar@1:                warning(csa, "non-zero right-hand side for free row `%s'"
alpar@1:                   " ignored\n", csa->P->row[i]->name);
alpar@1:          }
alpar@1:          else
alpar@1:             glp_set_row_bnds(csa->P, i, type, rhs, rhs);
alpar@1:          flag[i] = 1;
alpar@1:       }
alpar@1:       goto loop;
alpar@1: done: /* free working array */
alpar@1:       xfree(flag);
alpar@1:       csa->work3 = NULL;
alpar@1:       return;
alpar@1: }
alpar@1: 
alpar@1: static void read_ranges(struct csa *csa)
alpar@1: {     /* read RANGES section */
alpar@1:       int i, f, v, type;
alpar@1:       double rhs, rng;
alpar@1:       char name[255+1], *flag;
alpar@1:       /* allocate working array */
alpar@1:       csa->work3 = flag = xcalloc(1+csa->P->m, sizeof(char));
alpar@1:       memset(&flag[1], 0, csa->P->m);
alpar@1:       /* no current RANGES vector exists */
alpar@1:       v = 0;
alpar@1: loop: if (indicator(csa, 0)) goto done;
alpar@1:       /* field 1 must be blank */
alpar@1:       if (csa->deck)
alpar@1:       {  read_field(csa);
alpar@1:          if (csa->field[0] != '\0')
alpar@1:             error(csa, "field 1 must be blank\n");
alpar@1:       }
alpar@1:       else
alpar@1:          csa->fldno++;
alpar@1:       /* field 2: RANGES vector name */
alpar@1:       read_field(csa), patch_name(csa, csa->field);
alpar@1:       if (csa->field[0] == '\0')
alpar@1:       {  /* the same RANGES vector as in previous data record */
alpar@1:          if (v == 0)
alpar@1:          {  warning(csa, "missing RANGES vector name in field 2\n");
alpar@1:             goto blnk;
alpar@1:          }
alpar@1:       }
alpar@1:       else if (v != 0 && strcmp(csa->field, name) == 0)
alpar@1:       {  /* the same RANGES vector as in previous data record */
alpar@1:          xassert(v != 0);
alpar@1:       }
alpar@1:       else
alpar@1: blnk: {  /* new RANGES vector */
alpar@1:          if (v != 0)
alpar@1:             error(csa, "multiple RANGES vectors not supported\n");
alpar@1:          v++;
alpar@1:          strcpy(name, csa->field);
alpar@1:       }
alpar@1:       /* process fields 3-4 and 5-6 */
alpar@1:       for (f = 3; f <= 5; f += 2)
alpar@1:       {  /* field 3 or 5: row name */
alpar@1:          read_field(csa), patch_name(csa, csa->field);
alpar@1:          if (csa->field[0] == '\0')
alpar@1:          {  if (f == 3)
alpar@1:                error(csa, "missing row name in field 3\n");
alpar@1:             else
alpar@1:             {  /* if field 5 is blank, field 6 also must be blank */
alpar@1:                skip_field(csa);
alpar@1:                continue;
alpar@1:             }
alpar@1:          }
alpar@1:          i = glp_find_row(csa->P, csa->field);
alpar@1:          if (i == 0)
alpar@1:             error(csa, "row `%s' not found\n", csa->field);
alpar@1:          if (flag[i])
alpar@1:             error(csa, "duplicate range for row `%s'\n", csa->field);
alpar@1:          /* field 4 or 6: range value */
alpar@1:          rng = read_number(csa);
alpar@1:          if (fabs(rng) < csa->parm->tol_mps) rng = 0.0;
alpar@1:          type = csa->P->row[i]->type;
alpar@1:          if (type == GLP_FR)
alpar@1:             warning(csa, "range for free row `%s' ignored\n",
alpar@1:                csa->P->row[i]->name);
alpar@1:          else if (type == GLP_LO)
alpar@1:          {  rhs = csa->P->row[i]->lb;
alpar@1:             glp_set_row_bnds(csa->P, i, rhs == 0.0 ? GLP_FX : GLP_DB,
alpar@1:                rhs, rhs + fabs(rng));
alpar@1:          }
alpar@1:          else if (type == GLP_UP)
alpar@1:          {  rhs = csa->P->row[i]->ub;
alpar@1:             glp_set_row_bnds(csa->P, i, rhs == 0.0 ? GLP_FX : GLP_DB,
alpar@1:                rhs - fabs(rng), rhs);
alpar@1:          }
alpar@1:          else if (type == GLP_FX)
alpar@1:          {  rhs = csa->P->row[i]->lb;
alpar@1:             if (rng > 0.0)
alpar@1:                glp_set_row_bnds(csa->P, i, GLP_DB, rhs, rhs + rng);
alpar@1:             else if (rng < 0.0)
alpar@1:                glp_set_row_bnds(csa->P, i, GLP_DB, rhs + rng, rhs);
alpar@1:          }
alpar@1:          else
alpar@1:             xassert(type != type);
alpar@1:          flag[i] = 1;
alpar@1:       }
alpar@1:       goto loop;
alpar@1: done: /* free working array */
alpar@1:       xfree(flag);
alpar@1:       csa->work3 = NULL;
alpar@1:       return;
alpar@1: }
alpar@1: 
alpar@1: static void read_bounds(struct csa *csa)
alpar@1: {     /* read BOUNDS section */
alpar@1:       GLPCOL *col;
alpar@1:       int j, v, mask, data;
alpar@1:       double bnd, lb, ub;
alpar@1:       char type[2+1], name[255+1], *flag;
alpar@1:       /* allocate working array */
alpar@1:       csa->work3 = flag = xcalloc(1+csa->P->n, sizeof(char));
alpar@1:       memset(&flag[1], 0, csa->P->n);
alpar@1:       /* no current BOUNDS vector exists */
alpar@1:       v = 0;
alpar@1: loop: if (indicator(csa, 0)) goto done;
alpar@1:       /* field 1: bound type */
alpar@1:       read_field(csa);
alpar@1:       if (strcmp(csa->field, "LO") == 0)
alpar@1:          mask = 0x01, data = 1;
alpar@1:       else if (strcmp(csa->field, "UP") == 0)
alpar@1:          mask = 0x10, data = 1;
alpar@1:       else if (strcmp(csa->field, "FX") == 0)
alpar@1:          mask = 0x11, data = 1;
alpar@1:       else if (strcmp(csa->field, "FR") == 0)
alpar@1:          mask = 0x11, data = 0;
alpar@1:       else if (strcmp(csa->field, "MI") == 0)
alpar@1:          mask = 0x01, data = 0;
alpar@1:       else if (strcmp(csa->field, "PL") == 0)
alpar@1:          mask = 0x10, data = 0;
alpar@1:       else if (strcmp(csa->field, "LI") == 0)
alpar@1:          mask = 0x01, data = 1;
alpar@1:       else if (strcmp(csa->field, "UI") == 0)
alpar@1:          mask = 0x10, data = 1;
alpar@1:       else if (strcmp(csa->field, "BV") == 0)
alpar@1:          mask = 0x11, data = 0;
alpar@1:       else if (csa->field[0] == '\0')
alpar@1:          error(csa, "missing bound type in field 1\n");
alpar@1:       else
alpar@1:          error(csa, "invalid bound type in field 1\n");
alpar@1:       strcpy(type, csa->field);
alpar@1:       /* field 2: BOUNDS vector name */
alpar@1:       read_field(csa), patch_name(csa, csa->field);
alpar@1:       if (csa->field[0] == '\0')
alpar@1:       {  /* the same BOUNDS vector as in previous data record */
alpar@1:          if (v == 0)
alpar@1:          {  warning(csa, "missing BOUNDS vector name in field 2\n");
alpar@1:             goto blnk;
alpar@1:          }
alpar@1:       }
alpar@1:       else if (v != 0 && strcmp(csa->field, name) == 0)
alpar@1:       {  /* the same BOUNDS vector as in previous data record */
alpar@1:          xassert(v != 0);
alpar@1:       }
alpar@1:       else
alpar@1: blnk: {  /* new BOUNDS vector */
alpar@1:          if (v != 0)
alpar@1:             error(csa, "multiple BOUNDS vectors not supported\n");
alpar@1:          v++;
alpar@1:          strcpy(name, csa->field);
alpar@1:       }
alpar@1:       /* field 3: column name */
alpar@1:       read_field(csa), patch_name(csa, csa->field);
alpar@1:       if (csa->field[0] == '\0')
alpar@1:          error(csa, "missing column name in field 3\n");
alpar@1:       j = glp_find_col(csa->P, csa->field);
alpar@1:       if (j == 0)
alpar@1:          error(csa, "column `%s' not found\n", csa->field);
alpar@1:       if ((flag[j] & mask) == 0x01)
alpar@1:          error(csa, "duplicate lower bound for column `%s'\n",
alpar@1:             csa->field);
alpar@1:       if ((flag[j] & mask) == 0x10)
alpar@1:          error(csa, "duplicate upper bound for column `%s'\n",
alpar@1:             csa->field);
alpar@1:       xassert((flag[j] & mask) == 0x00);
alpar@1:       /* field 4: bound value */
alpar@1:       if (data)
alpar@1:       {  bnd = read_number(csa);
alpar@1:          if (fabs(bnd) < csa->parm->tol_mps) bnd = 0.0;
alpar@1:       }
alpar@1:       else
alpar@1:          read_field(csa), bnd = 0.0;
alpar@1:       /* get current column bounds */
alpar@1:       col = csa->P->col[j];
alpar@1:       if (col->type == GLP_FR)
alpar@1:          lb = -DBL_MAX, ub = +DBL_MAX;
alpar@1:       else if (col->type == GLP_LO)
alpar@1:          lb = col->lb, ub = +DBL_MAX;
alpar@1:       else if (col->type == GLP_UP)
alpar@1:          lb = -DBL_MAX, ub = col->ub;
alpar@1:       else if (col->type == GLP_DB)
alpar@1:          lb = col->lb, ub = col->ub;
alpar@1:       else if (col->type == GLP_FX)
alpar@1:          lb = ub = col->lb;
alpar@1:       else
alpar@1:          xassert(col != col);
alpar@1:       /* change column bounds */
alpar@1:       if (strcmp(type, "LO") == 0)
alpar@1:          lb = bnd;
alpar@1:       else if (strcmp(type, "UP") == 0)
alpar@1:          ub = bnd;
alpar@1:       else if (strcmp(type, "FX") == 0)
alpar@1:          lb = ub = bnd;
alpar@1:       else if (strcmp(type, "FR") == 0)
alpar@1:          lb = -DBL_MAX, ub = +DBL_MAX;
alpar@1:       else if (strcmp(type, "MI") == 0)
alpar@1:          lb = -DBL_MAX;
alpar@1:       else if (strcmp(type, "PL") == 0)
alpar@1:          ub = +DBL_MAX;
alpar@1:       else if (strcmp(type, "LI") == 0)
alpar@1:       {  glp_set_col_kind(csa->P, j, GLP_IV);
alpar@1:          lb = ceil(bnd);
alpar@1:       }
alpar@1:       else if (strcmp(type, "UI") == 0)
alpar@1:       {  glp_set_col_kind(csa->P, j, GLP_IV);
alpar@1:          ub = floor(bnd);
alpar@1:       }
alpar@1:       else if (strcmp(type, "BV") == 0)
alpar@1:       {  glp_set_col_kind(csa->P, j, GLP_IV);
alpar@1:          lb = 0.0, ub = 1.0;
alpar@1:       }
alpar@1:       else
alpar@1:          xassert(type != type);
alpar@1:       /* set new column bounds */
alpar@1:       if (lb == -DBL_MAX && ub == +DBL_MAX)
alpar@1:          glp_set_col_bnds(csa->P, j, GLP_FR, lb, ub);
alpar@1:       else if (ub == +DBL_MAX)
alpar@1:          glp_set_col_bnds(csa->P, j, GLP_LO, lb, ub);
alpar@1:       else if (lb == -DBL_MAX)
alpar@1:          glp_set_col_bnds(csa->P, j, GLP_UP, lb, ub);
alpar@1:       else if (lb != ub)
alpar@1:          glp_set_col_bnds(csa->P, j, GLP_DB, lb, ub);
alpar@1:       else
alpar@1:          glp_set_col_bnds(csa->P, j, GLP_FX, lb, ub);
alpar@1:       flag[j] |= (char)mask;
alpar@1:       /* fields 5 and 6 must be blank */
alpar@1:       skip_field(csa);
alpar@1:       skip_field(csa);
alpar@1:       goto loop;
alpar@1: done: /* free working array */
alpar@1:       xfree(flag);
alpar@1:       csa->work3 = NULL;
alpar@1:       return;
alpar@1: }
alpar@1: 
alpar@1: int glp_read_mps(glp_prob *P, int fmt, const glp_mpscp *parm,
alpar@1:       const char *fname)
alpar@1: {     /* read problem data in MPS format */
alpar@1:       glp_mpscp _parm;
alpar@1:       struct csa _csa, *csa = &_csa;
alpar@1:       int ret;
alpar@1:       xprintf("Reading problem data from `%s'...\n", fname);
alpar@1:       if (!(fmt == GLP_MPS_DECK || fmt == GLP_MPS_FILE))
alpar@1:          xerror("glp_read_mps: fmt = %d; invalid parameter\n", fmt);
alpar@1:       if (parm == NULL)
alpar@1:          glp_init_mpscp(&_parm), parm = &_parm;
alpar@1:       /* check control parameters */
alpar@1:       check_parm("glp_read_mps", parm);
alpar@1:       /* initialize common storage area */
alpar@1:       csa->P = P;
alpar@1:       csa->deck = (fmt == GLP_MPS_DECK);
alpar@1:       csa->parm = parm;
alpar@1:       csa->fname = fname;
alpar@1:       csa->fp = NULL;
alpar@1:       if (setjmp(csa->jump))
alpar@1:       {  ret = 1;
alpar@1:          goto done;
alpar@1:       }
alpar@1:       csa->recno = csa->recpos = 0;
alpar@1:       csa->c = '\n';
alpar@1:       csa->fldno = 0;
alpar@1:       csa->field[0] = '\0';
alpar@1:       csa->w80 = csa->wef = 0;
alpar@1:       csa->obj_row = 0;
alpar@1:       csa->work1 = csa->work2 = csa->work3 = NULL;
alpar@1:       /* erase problem object */
alpar@1:       glp_erase_prob(P);
alpar@1:       glp_create_index(P);
alpar@1:       /* open input MPS file */
alpar@1:       csa->fp = xfopen(fname, "r");
alpar@1:       if (csa->fp == NULL)
alpar@1:       {  xprintf("Unable to open `%s' - %s\n", fname, xerrmsg());
alpar@1:          ret = 1;
alpar@1:          goto done;
alpar@1:       }
alpar@1:       /* read NAME indicator record */
alpar@1:       read_name(csa);
alpar@1:       if (P->name != NULL)
alpar@1:          xprintf("Problem: %s\n", P->name);
alpar@1:       /* read ROWS section */
alpar@1:       if (!(indicator(csa, 0) && strcmp(csa->field, "ROWS") == 0))
alpar@1:          error(csa, "missing ROWS indicator record\n");
alpar@1:       read_rows(csa);
alpar@1:       /* determine objective row */
alpar@1:       if (parm->obj_name == NULL || parm->obj_name[0] == '\0')
alpar@1:       {  /* use the first row of N type */
alpar@1:          int i;
alpar@1:          for (i = 1; i <= P->m; i++)
alpar@1:          {  if (P->row[i]->type == GLP_FR)
alpar@1:             {  csa->obj_row = i;
alpar@1:                break;
alpar@1:             }
alpar@1:          }
alpar@1:          if (csa->obj_row == 0)
alpar@1:             warning(csa, "unable to determine objective row\n");
alpar@1:       }
alpar@1:       else
alpar@1:       {  /* use a row with specified name */
alpar@1:          int i;
alpar@1:          for (i = 1; i <= P->m; i++)
alpar@1:          {  xassert(P->row[i]->name != NULL);
alpar@1:             if (strcmp(parm->obj_name, P->row[i]->name) == 0)
alpar@1:             {  csa->obj_row = i;
alpar@1:                break;
alpar@1:             }
alpar@1:          }
alpar@1:          if (csa->obj_row == 0)
alpar@1:             error(csa, "objective row `%s' not found\n",
alpar@1:                parm->obj_name);
alpar@1:       }
alpar@1:       if (csa->obj_row != 0)
alpar@1:       {  glp_set_obj_name(P, P->row[csa->obj_row]->name);
alpar@1:          xprintf("Objective: %s\n", P->obj);
alpar@1:       }
alpar@1:       /* read COLUMNS section */
alpar@1:       if (strcmp(csa->field, "COLUMNS") != 0)
alpar@1:          error(csa, "missing COLUMNS indicator record\n");
alpar@1:       read_columns(csa);
alpar@1:       /* set objective coefficients */
alpar@1:       if (csa->obj_row != 0)
alpar@1:       {  GLPAIJ *aij;
alpar@1:          for (aij = P->row[csa->obj_row]->ptr; aij != NULL; aij =
alpar@1:             aij->r_next) glp_set_obj_coef(P, aij->col->j, aij->val);
alpar@1:       }
alpar@1:       /* read optional RHS section */
alpar@1:       if (strcmp(csa->field, "RHS") == 0)
alpar@1:          read_rhs(csa);
alpar@1:       /* read optional RANGES section */
alpar@1:       if (strcmp(csa->field, "RANGES") == 0)
alpar@1:          read_ranges(csa);
alpar@1:       /* read optional BOUNDS section */
alpar@1:       if (strcmp(csa->field, "BOUNDS") == 0)
alpar@1:          read_bounds(csa);
alpar@1:       /* read ENDATA indicator record */
alpar@1:       if (strcmp(csa->field, "ENDATA") != 0)
alpar@1:          error(csa, "invalid use of %s indicator record\n",
alpar@1:             csa->field);
alpar@1:       /* print some statistics */
alpar@1:       xprintf("%d row%s, %d column%s, %d non-zero%s\n",
alpar@1:          P->m, P->m == 1 ? "" : "s", P->n, P->n == 1 ? "" : "s",
alpar@1:          P->nnz, P->nnz == 1 ? "" : "s");
alpar@1:       if (glp_get_num_int(P) > 0)
alpar@1:       {  int ni = glp_get_num_int(P);
alpar@1:          int nb = glp_get_num_bin(P);
alpar@1:          if (ni == 1)
alpar@1:          {  if (nb == 0)
alpar@1:                xprintf("One variable is integer\n");
alpar@1:             else
alpar@1:                xprintf("One variable is binary\n");
alpar@1:          }
alpar@1:          else
alpar@1:          {  xprintf("%d integer variables, ", ni);
alpar@1:             if (nb == 0)
alpar@1:                xprintf("none");
alpar@1:             else if (nb == 1)
alpar@1:                xprintf("one");
alpar@1:             else if (nb == ni)
alpar@1:                xprintf("all");
alpar@1:             else
alpar@1:                xprintf("%d", nb);
alpar@1:             xprintf(" of which %s binary\n", nb == 1 ? "is" : "are");
alpar@1:          }
alpar@1:       }
alpar@1:       xprintf("%d records were read\n", csa->recno);
alpar@1:       /* problem data has been successfully read */
alpar@1:       glp_delete_index(P);
alpar@1:       glp_sort_matrix(P);
alpar@1:       ret = 0;
alpar@1: done: if (csa->fp != NULL) xfclose(csa->fp);
alpar@1:       if (csa->work1 != NULL) xfree(csa->work1);
alpar@1:       if (csa->work2 != NULL) xfree(csa->work2);
alpar@1:       if (csa->work3 != NULL) xfree(csa->work3);
alpar@1:       if (ret != 0) glp_erase_prob(P);
alpar@1:       return ret;
alpar@1: }
alpar@1: 
alpar@1: /***********************************************************************
alpar@1: *  NAME
alpar@1: *
alpar@1: *  glp_write_mps - write problem data in MPS format
alpar@1: *
alpar@1: *  SYNOPSIS
alpar@1: *
alpar@1: *  int glp_write_mps(glp_prob *P, int fmt, const glp_mpscp *parm,
alpar@1: *     const char *fname);
alpar@1: *
alpar@1: *  DESCRIPTION
alpar@1: *
alpar@1: *  The routine glp_write_mps writes problem data in MPS format to a
alpar@1: *  text file.
alpar@1: *
alpar@1: *  The parameter fmt specifies the version of MPS format:
alpar@1: *
alpar@1: *  GLP_MPS_DECK - fixed (ancient) MPS format;
alpar@1: *  GLP_MPS_FILE - free (modern) MPS format.
alpar@1: *
alpar@1: *  The parameter parm is a pointer to the structure glp_mpscp, which
alpar@1: *  specifies control parameters used by the routine. If parm is NULL,
alpar@1: *  the routine uses default settings.
alpar@1: *
alpar@1: *  The character string fname specifies a name of the text file to be
alpar@1: *  written.
alpar@1: *
alpar@1: *  RETURNS
alpar@1: *
alpar@1: *  If the operation was successful, the routine glp_read_mps returns
alpar@1: *  zero. Otherwise, it prints an error message and returns non-zero. */
alpar@1: 
alpar@1: #define csa csa1
alpar@1: 
alpar@1: struct csa
alpar@1: {     /* common storage area */
alpar@1:       glp_prob *P;
alpar@1:       /* pointer to problem object */
alpar@1:       int deck;
alpar@1:       /* MPS format (0 - free, 1 - fixed) */
alpar@1:       const glp_mpscp *parm;
alpar@1:       /* pointer to control parameters */
alpar@1:       char field[255+1];
alpar@1:       /* field buffer */
alpar@1: };
alpar@1: 
alpar@1: static char *mps_name(struct csa *csa)
alpar@1: {     /* make problem name */
alpar@1:       char *f;
alpar@1:       if (csa->P->name == NULL)
alpar@1:          csa->field[0] = '\0';
alpar@1:       else if (csa->deck)
alpar@1:       {  strncpy(csa->field, csa->P->name, 8);
alpar@1:          csa->field[8] = '\0';
alpar@1:       }
alpar@1:       else
alpar@1:          strcpy(csa->field, csa->P->name);
alpar@1:       for (f = csa->field; *f != '\0'; f++)
alpar@1:          if (*f == ' ') *f = '_';
alpar@1:       return csa->field;
alpar@1: }
alpar@1: 
alpar@1: static char *row_name(struct csa *csa, int i)
alpar@1: {     /* make i-th row name */
alpar@1:       char *f;
alpar@1:       xassert(0 <= i && i <= csa->P->m);
alpar@1:       if (i == 0 || csa->P->row[i]->name == NULL ||
alpar@1:           csa->deck && strlen(csa->P->row[i]->name) > 8)
alpar@1:          sprintf(csa->field, "R%07d", i);
alpar@1:       else
alpar@1:       {  strcpy(csa->field, csa->P->row[i]->name);
alpar@1:          for (f = csa->field; *f != '\0'; f++)
alpar@1:             if (*f == ' ') *f = '_';
alpar@1:       }
alpar@1:       return csa->field;
alpar@1: }
alpar@1: 
alpar@1: static char *col_name(struct csa *csa, int j)
alpar@1: {     /* make j-th column name */
alpar@1:       char *f;
alpar@1:       xassert(1 <= j && j <= csa->P->n);
alpar@1:       if (csa->P->col[j]->name == NULL ||
alpar@1:           csa->deck && strlen(csa->P->col[j]->name) > 8)
alpar@1:          sprintf(csa->field, "C%07d", j);
alpar@1:       else
alpar@1:       {  strcpy(csa->field, csa->P->col[j]->name);
alpar@1:          for (f = csa->field; *f != '\0'; f++)
alpar@1:             if (*f == ' ') *f = '_';
alpar@1:       }
alpar@1:       return csa->field;
alpar@1: }
alpar@1: 
alpar@1: static char *mps_numb(struct csa *csa, double val)
alpar@1: {     /* format floating-point number */
alpar@1:       int dig;
alpar@1:       char *exp;
alpar@1:       for (dig = 12; dig >= 6; dig--)
alpar@1:       {  if (val != 0.0 && fabs(val) < 0.002)
alpar@1:             sprintf(csa->field, "%.*E", dig-1, val);
alpar@1:          else
alpar@1:             sprintf(csa->field, "%.*G", dig, val);
alpar@1:          exp = strchr(csa->field, 'E');
alpar@1:          if (exp != NULL)
alpar@1:             sprintf(exp+1, "%d", atoi(exp+1));
alpar@1:          if (strlen(csa->field) <= 12) break;
alpar@1:       }
alpar@1:       xassert(strlen(csa->field) <= 12);
alpar@1:       return csa->field;
alpar@1: }
alpar@1: 
alpar@1: int glp_write_mps(glp_prob *P, int fmt, const glp_mpscp *parm,
alpar@1:       const char *fname)
alpar@1: {     /* write problem data in MPS format */
alpar@1:       glp_mpscp _parm;
alpar@1:       struct csa _csa, *csa = &_csa;
alpar@1:       XFILE *fp;
alpar@1:       int out_obj, one_col = 0, empty = 0;
alpar@1:       int i, j, recno, marker, count, gap, ret;
alpar@1:       xprintf("Writing problem data to `%s'...\n", fname);
alpar@1:       if (!(fmt == GLP_MPS_DECK || fmt == GLP_MPS_FILE))
alpar@1:          xerror("glp_write_mps: fmt = %d; invalid parameter\n", fmt);
alpar@1:       if (parm == NULL)
alpar@1:          glp_init_mpscp(&_parm), parm = &_parm;
alpar@1:       /* check control parameters */
alpar@1:       check_parm("glp_write_mps", parm);
alpar@1:       /* initialize common storage area */
alpar@1:       csa->P = P;
alpar@1:       csa->deck = (fmt == GLP_MPS_DECK);
alpar@1:       csa->parm = parm;
alpar@1:       /* create output MPS file */
alpar@1:       fp = xfopen(fname, "w"), recno = 0;
alpar@1:       if (fp == NULL)
alpar@1:       {  xprintf("Unable to create `%s' - %s\n", fname, xerrmsg());
alpar@1:          ret = 1;
alpar@1:          goto done;
alpar@1:       }
alpar@1:       /* write comment records */
alpar@1:       xfprintf(fp, "* %-*s%s\n", P->name == NULL ? 1 : 12, "Problem:",
alpar@1:          P->name == NULL ? "" : P->name), recno++;
alpar@1:       xfprintf(fp, "* %-12s%s\n", "Class:", glp_get_num_int(P) == 0 ?
alpar@1:          "LP" : "MIP"), recno++;
alpar@1:       xfprintf(fp, "* %-12s%d\n", "Rows:", P->m), recno++;
alpar@1:       if (glp_get_num_int(P) == 0)
alpar@1:          xfprintf(fp, "* %-12s%d\n", "Columns:", P->n), recno++;
alpar@1:       else
alpar@1:          xfprintf(fp, "* %-12s%d (%d integer, %d binary)\n",
alpar@1:             "Columns:", P->n, glp_get_num_int(P), glp_get_num_bin(P)),
alpar@1:             recno++;
alpar@1:       xfprintf(fp, "* %-12s%d\n", "Non-zeros:", P->nnz), recno++;
alpar@1:       xfprintf(fp, "* %-12s%s\n", "Format:", csa->deck ? "Fixed MPS" :
alpar@1:          "Free MPS"), recno++;
alpar@1:       xfprintf(fp, "*\n", recno++);
alpar@1:       /* write NAME indicator record */
alpar@1:       xfprintf(fp, "NAME%*s%s\n",
alpar@1:          P->name == NULL ? 0 : csa->deck ? 10 : 1, "", mps_name(csa)),
alpar@1:          recno++;
alpar@1: #if 1
alpar@1:       /* determine whether to write the objective row */
alpar@1:       out_obj = 1;
alpar@1:       for (i = 1; i <= P->m; i++)
alpar@1:       {  if (P->row[i]->type == GLP_FR)
alpar@1:          {  out_obj = 0;
alpar@1:             break;
alpar@1:          }
alpar@1:       }
alpar@1: #endif
alpar@1:       /* write ROWS section */
alpar@1:       xfprintf(fp, "ROWS\n"), recno++;
alpar@1:       for (i = (out_obj ? 0 : 1); i <= P->m; i++)
alpar@1:       {  int type;
alpar@1:          type = (i == 0 ? GLP_FR : P->row[i]->type);
alpar@1:          if (type == GLP_FR)
alpar@1:             type = 'N';
alpar@1:          else if (type == GLP_LO)
alpar@1:             type = 'G';
alpar@1:          else if (type == GLP_UP)
alpar@1:             type = 'L';
alpar@1:          else if (type == GLP_DB || type == GLP_FX)
alpar@1:             type = 'E';
alpar@1:          else
alpar@1:             xassert(type != type);
alpar@1:          xfprintf(fp, " %c%*s%s\n", type, csa->deck ? 2 : 1, "",
alpar@1:             row_name(csa, i)), recno++;
alpar@1:       }
alpar@1:       /* write COLUMNS section */
alpar@1:       xfprintf(fp, "COLUMNS\n"), recno++;
alpar@1:       marker = 0;
alpar@1:       for (j = 1; j <= P->n; j++)
alpar@1:       {  GLPAIJ cj, *aij;
alpar@1:          int kind;
alpar@1:          kind = P->col[j]->kind;
alpar@1:          if (kind == GLP_CV)
alpar@1:          {  if (marker % 2 == 1)
alpar@1:             {  /* close current integer block */
alpar@1:                marker++;
alpar@1:                xfprintf(fp, "%*sM%07d%*s'MARKER'%*s'INTEND'\n",
alpar@1:                   csa->deck ? 4 : 1, "", marker, csa->deck ? 2 : 1, "",
alpar@1:                   csa->deck ? 17 : 1, ""), recno++;
alpar@1:             }
alpar@1:          }
alpar@1:          else if (kind == GLP_IV)
alpar@1:          {  if (marker % 2 == 0)
alpar@1:             {  /* open new integer block */
alpar@1:                marker++;
alpar@1:                xfprintf(fp, "%*sM%07d%*s'MARKER'%*s'INTORG'\n",
alpar@1:                   csa->deck ? 4 : 1, "", marker, csa->deck ? 2 : 1, "",
alpar@1:                   csa->deck ? 17 : 1, ""), recno++;
alpar@1:             }
alpar@1:          }
alpar@1:          else
alpar@1:             xassert(kind != kind);
alpar@1:          if (out_obj && P->col[j]->coef != 0.0)
alpar@1:          {  /* make fake objective coefficient */
alpar@1:             aij = &cj;
alpar@1:             aij->row = NULL;
alpar@1:             aij->val = P->col[j]->coef;
alpar@1:             aij->c_next = P->col[j]->ptr;
alpar@1:          }
alpar@1:          else
alpar@1:             aij = P->col[j]->ptr;
alpar@1: #if 1 /* FIXME */
alpar@1:          if (aij == NULL)
alpar@1:          {  /* empty column */
alpar@1:             empty++;
alpar@1:             xfprintf(fp, "%*s%-*s", csa->deck ? 4 : 1, "",
alpar@1:                csa->deck ? 8 : 1, col_name(csa, j));
alpar@1:             /* we need a row */
alpar@1:             xassert(P->m > 0);
alpar@1:             xfprintf(fp, "%*s%-*s",
alpar@1:                csa->deck ? 2 : 1, "", csa->deck ? 8 : 1,
alpar@1:                row_name(csa, 1));
alpar@1:             xfprintf(fp, "%*s0%*s$ empty column\n",
alpar@1:                csa->deck ? 13 : 1, "", csa->deck ? 3 : 1, ""), recno++;
alpar@1:          }
alpar@1: #endif
alpar@1:          count = 0;
alpar@1:          for (aij = aij; aij != NULL; aij = aij->c_next)
alpar@1:          {  if (one_col || count % 2 == 0)
alpar@1:                xfprintf(fp, "%*s%-*s", csa->deck ? 4 : 1, "",
alpar@1:                   csa->deck ? 8 : 1, col_name(csa, j));
alpar@1:             gap = (one_col || count % 2 == 0 ? 2 : 3);
alpar@1:             xfprintf(fp, "%*s%-*s",
alpar@1:                csa->deck ? gap : 1, "", csa->deck ? 8 : 1,
alpar@1:                row_name(csa, aij->row == NULL ? 0 : aij->row->i));
alpar@1:             xfprintf(fp, "%*s%*s",
alpar@1:                csa->deck ? 2 : 1, "", csa->deck ? 12 : 1,
alpar@1:                mps_numb(csa, aij->val)), count++;
alpar@1:             if (one_col || count % 2 == 0)
alpar@1:                xfprintf(fp, "\n"), recno++;
alpar@1:          }
alpar@1:          if (!(one_col || count % 2 == 0))
alpar@1:             xfprintf(fp, "\n"), recno++;
alpar@1:       }
alpar@1:       if (marker % 2 == 1)
alpar@1:       {  /* close last integer block */
alpar@1:          marker++;
alpar@1:          xfprintf(fp, "%*sM%07d%*s'MARKER'%*s'INTEND'\n",
alpar@1:             csa->deck ? 4 : 1, "", marker, csa->deck ? 2 : 1, "",
alpar@1:             csa->deck ? 17 : 1, ""), recno++;
alpar@1:       }
alpar@1: #if 1
alpar@1:       if (empty > 0)
alpar@1:          xprintf("Warning: problem has %d empty column(s)\n", empty);
alpar@1: #endif
alpar@1:       /* write RHS section */
alpar@1:       xfprintf(fp, "RHS\n"), recno++;
alpar@1:       count = 0;
alpar@1:       for (i = (out_obj ? 0 : 1); i <= P->m; i++)
alpar@1:       {  int type;
alpar@1:          double rhs;
alpar@1:          if (i == 0)
alpar@1:             rhs = P->c0;
alpar@1:          else
alpar@1:          {  type = P->row[i]->type;
alpar@1:             if (type == GLP_FR)
alpar@1:                rhs = 0.0;
alpar@1:             else if (type == GLP_LO)
alpar@1:                rhs = P->row[i]->lb;
alpar@1:             else if (type == GLP_UP)
alpar@1:                rhs = P->row[i]->ub;
alpar@1:             else if (type == GLP_DB || type == GLP_FX)
alpar@1:                rhs = P->row[i]->lb;
alpar@1:             else
alpar@1:                xassert(type != type);
alpar@1:          }
alpar@1:          if (rhs != 0.0)
alpar@1:          {  if (one_col || count % 2 == 0)
alpar@1:                xfprintf(fp, "%*s%-*s", csa->deck ? 4 : 1, "",
alpar@1:                   csa->deck ? 8 : 1, "RHS1");
alpar@1:             gap = (one_col || count % 2 == 0 ? 2 : 3);
alpar@1:             xfprintf(fp, "%*s%-*s",
alpar@1:                csa->deck ? gap : 1, "", csa->deck ? 8 : 1,
alpar@1:                row_name(csa, i));
alpar@1:             xfprintf(fp, "%*s%*s",
alpar@1:                csa->deck ? 2 : 1, "", csa->deck ? 12 : 1,
alpar@1:                mps_numb(csa, rhs)), count++;
alpar@1:             if (one_col || count % 2 == 0)
alpar@1:                xfprintf(fp, "\n"), recno++;
alpar@1:          }
alpar@1:       }
alpar@1:       if (!(one_col || count % 2 == 0))
alpar@1:          xfprintf(fp, "\n"), recno++;
alpar@1:       /* write RANGES section */
alpar@1:       for (i = P->m; i >= 1; i--)
alpar@1:          if (P->row[i]->type == GLP_DB) break;
alpar@1:       if (i == 0) goto bnds;
alpar@1:       xfprintf(fp, "RANGES\n"), recno++;
alpar@1:       count = 0;
alpar@1:       for (i = 1; i <= P->m; i++)
alpar@1:       {  if (P->row[i]->type == GLP_DB)
alpar@1:          {  if (one_col || count % 2 == 0)
alpar@1:                xfprintf(fp, "%*s%-*s", csa->deck ? 4 : 1, "",
alpar@1:                   csa->deck ? 8 : 1, "RNG1");
alpar@1:             gap = (one_col || count % 2 == 0 ? 2 : 3);
alpar@1:             xfprintf(fp, "%*s%-*s",
alpar@1:                csa->deck ? gap : 1, "", csa->deck ? 8 : 1,
alpar@1:                row_name(csa, i));
alpar@1:             xfprintf(fp, "%*s%*s",
alpar@1:                csa->deck ? 2 : 1, "", csa->deck ? 12 : 1,
alpar@1:                mps_numb(csa, P->row[i]->ub - P->row[i]->lb)), count++;
alpar@1:             if (one_col || count % 2 == 0)
alpar@1:                xfprintf(fp, "\n"), recno++;
alpar@1:          }
alpar@1:       }
alpar@1:       if (!(one_col || count % 2 == 0))
alpar@1:          xfprintf(fp, "\n"), recno++;
alpar@1: bnds: /* write BOUNDS section */
alpar@1:       for (j = P->n; j >= 1; j--)
alpar@1:          if (!(P->col[j]->type == GLP_LO && P->col[j]->lb == 0.0))
alpar@1:             break;
alpar@1:       if (j == 0) goto endt;
alpar@1:       xfprintf(fp, "BOUNDS\n"), recno++;
alpar@1:       for (j = 1; j <= P->n; j++)
alpar@1:       {  int type, data[2];
alpar@1:          double bnd[2];
alpar@1:          char *spec[2];
alpar@1:          spec[0] = spec[1] = NULL;
alpar@1:          type = P->col[j]->type;
alpar@1:          if (type == GLP_FR)
alpar@1:             spec[0] = "FR", data[0] = 0;
alpar@1:          else if (type == GLP_LO)
alpar@1:          {  if (P->col[j]->lb != 0.0)
alpar@1:                spec[0] = "LO", data[0] = 1, bnd[0] = P->col[j]->lb;
alpar@1:             if (P->col[j]->kind == GLP_IV)
alpar@1:                spec[1] = "PL", data[1] = 0;
alpar@1:          }
alpar@1:          else if (type == GLP_UP)
alpar@1:          {  spec[0] = "MI", data[0] = 0;
alpar@1:             spec[1] = "UP", data[1] = 1, bnd[1] = P->col[j]->ub;
alpar@1:          }
alpar@1:          else if (type == GLP_DB)
alpar@1:          {  if (P->col[j]->lb != 0.0)
alpar@1:                spec[0] = "LO", data[0] = 1, bnd[0] = P->col[j]->lb;
alpar@1:             spec[1] = "UP", data[1] = 1, bnd[1] = P->col[j]->ub;
alpar@1:          }
alpar@1:          else if (type == GLP_FX)
alpar@1:             spec[0] = "FX", data[0] = 1, bnd[0] = P->col[j]->lb;
alpar@1:          else
alpar@1:             xassert(type != type);
alpar@1:          for (i = 0; i <= 1; i++)
alpar@1:          {  if (spec[i] != NULL)
alpar@1:             {  xfprintf(fp, " %s %-*s%*s%-*s", spec[i],
alpar@1:                   csa->deck ? 8 : 1, "BND1", csa->deck ? 2 : 1, "",
alpar@1:                   csa->deck ? 8 : 1, col_name(csa, j));
alpar@1:                if (data[i])
alpar@1:                   xfprintf(fp, "%*s%*s", csa->deck ? 2 : 1, "",
alpar@1:                      csa->deck ? 12 : 1, mps_numb(csa, bnd[i]));
alpar@1:                xfprintf(fp, "\n"), recno++;
alpar@1:             }
alpar@1:          }
alpar@1:       }
alpar@1: endt: /* write ENDATA indicator record */
alpar@1:       xfprintf(fp, "ENDATA\n"), recno++;
alpar@1:       xfflush(fp);
alpar@1:       if (xferror(fp))
alpar@1:       {  xprintf("Write error on `%s' - %s\n", fname, xerrmsg());
alpar@1:          ret = 1;
alpar@1:          goto done;
alpar@1:       }
alpar@1:       /* problem data has been successfully written */
alpar@1:       xprintf("%d records were written\n", recno);
alpar@1:       ret = 0;
alpar@1: done: if (fp != NULL) xfclose(fp);
alpar@1:       return ret;
alpar@1: }
alpar@1: 
alpar@1: /* eof */