alpar@1: /* glphbm.c */
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: #define _GLPSTD_ERRNO
alpar@1: #define _GLPSTD_STDIO
alpar@1: #include "glphbm.h"
alpar@1: #include "glpenv.h"
alpar@1: 
alpar@1: /***********************************************************************
alpar@1: *  NAME
alpar@1: *
alpar@1: *  hbm_read_mat - read sparse matrix in Harwell-Boeing format
alpar@1: *
alpar@1: *  SYNOPSIS
alpar@1: *
alpar@1: *  #include "glphbm.h"
alpar@1: *  HBM *hbm_read_mat(const char *fname);
alpar@1: *
alpar@1: *  DESCRIPTION
alpar@1: *
alpar@1: *  The routine hbm_read_mat reads a sparse matrix in the Harwell-Boeing
alpar@1: *  format from a text file whose name is the character string fname.
alpar@1: *
alpar@1: *  Detailed description of the Harwell-Boeing format recognised by this
alpar@1: *  routine is given in the following report:
alpar@1: *
alpar@1: *  I.S.Duff, R.G.Grimes, J.G.Lewis. User's Guide for the Harwell-Boeing
alpar@1: *  Sparse Matrix Collection (Release I), TR/PA/92/86, October 1992.
alpar@1: *
alpar@1: *  RETURNS
alpar@1: *
alpar@1: *  If no error occured, the routine hbm_read_mat returns a pointer to
alpar@1: *  a data structure containing the matrix. In case of error the routine
alpar@1: *  prints an appropriate error message and returns NULL. */
alpar@1: 
alpar@1: struct dsa
alpar@1: {     /* working area used by routine hbm_read_mat */
alpar@1:       const char *fname;
alpar@1:       /* name of input text file */
alpar@1:       FILE *fp;
alpar@1:       /* stream assigned to input text file */
alpar@1:       int seqn;
alpar@1:       /* card sequential number */
alpar@1:       char card[80+1];
alpar@1:       /* card image buffer */
alpar@1:       int fmt_p;
alpar@1:       /* scale factor */
alpar@1:       int fmt_k;
alpar@1:       /* iterator */
alpar@1:       int fmt_f;
alpar@1:       /* format code */
alpar@1:       int fmt_w;
alpar@1:       /* field width */
alpar@1:       int fmt_d;
alpar@1:       /* number of decimal places after point */
alpar@1: };
alpar@1: 
alpar@1: /***********************************************************************
alpar@1: *  read_card - read next data card
alpar@1: *
alpar@1: *  This routine reads the next 80-column card from the input text file
alpar@1: *  and stores its image into the character string card. If the card was
alpar@1: *  read successfully, the routine returns zero, otherwise non-zero. */
alpar@1: 
alpar@1: static int read_card(struct dsa *dsa)
alpar@1: {     int k, c;
alpar@1:       dsa->seqn++;
alpar@1:       memset(dsa->card, ' ', 80), dsa->card[80] = '\0';
alpar@1:       k = 0;
alpar@1:       for (;;)
alpar@1:       {  c = fgetc(dsa->fp);
alpar@1:          if (ferror(dsa->fp))
alpar@1:          {  xprintf("%s:%d: read error - %s\n", dsa->fname, dsa->seqn,
alpar@1:                strerror(errno));
alpar@1:             return 1;
alpar@1:          }
alpar@1:          if (feof(dsa->fp))
alpar@1:          {  if (k == 0)
alpar@1:                xprintf("%s:%d: unexpected EOF\n", dsa->fname,
alpar@1:                   dsa->seqn);
alpar@1:             else
alpar@1:                xprintf("%s:%d: missing final LF\n", dsa->fname,
alpar@1:                   dsa->seqn);
alpar@1:             return 1;
alpar@1:          }
alpar@1:          if (c == '\r') continue;
alpar@1:          if (c == '\n') break;
alpar@1:          if (iscntrl(c))
alpar@1:          {  xprintf("%s:%d: invalid control character 0x%02X\n",
alpar@1:                dsa->fname, dsa->seqn, c);
alpar@1:             return 1;
alpar@1:          }
alpar@1:          if (k == 80)
alpar@1:          {  xprintf("%s:%d: card image too long\n", dsa->fname,
alpar@1:                dsa->seqn);
alpar@1:             return 1;
alpar@1:          }
alpar@1:          dsa->card[k++] = (char)c;
alpar@1:       }
alpar@1:       return 0;
alpar@1: }
alpar@1: 
alpar@1: /***********************************************************************
alpar@1: *  scan_int - scan integer value from the current card
alpar@1: *
alpar@1: *  This routine scans an integer value from the current card, where fld
alpar@1: *  is the name of the field, pos is the position of the field, width is
alpar@1: *  the width of the field, val points to a location to which the scanned
alpar@1: *  value should be stored. If the value was scanned successfully, the
alpar@1: *  routine returns zero, otherwise non-zero. */
alpar@1: 
alpar@1: static int scan_int(struct dsa *dsa, char *fld, int pos, int width,
alpar@1:       int *val)
alpar@1: {     char str[80+1];
alpar@1:       xassert(1 <= width && width <= 80);
alpar@1:       memcpy(str, dsa->card + pos, width), str[width] = '\0';
alpar@1:       if (str2int(strspx(str), val))
alpar@1:       {  xprintf("%s:%d: field `%s' contains invalid value `%s'\n",
alpar@1:             dsa->fname, dsa->seqn, fld, str);
alpar@1:          return 1;
alpar@1:       }
alpar@1:       return 0;
alpar@1: }
alpar@1: 
alpar@1: /***********************************************************************
alpar@1: *  parse_fmt - parse Fortran format specification
alpar@1: *
alpar@1: *  This routine parses the Fortran format specification represented as
alpar@1: *  character string which fmt points to and stores format elements into
alpar@1: *  appropriate static locations. Should note that not all valid Fortran
alpar@1: *  format specifications may be recognised. If the format specification
alpar@1: *  was recognised, the routine returns zero, otherwise non-zero. */
alpar@1: 
alpar@1: static int parse_fmt(struct dsa *dsa, char *fmt)
alpar@1: {     int k, s, val;
alpar@1:       char str[80+1];
alpar@1:       /* first character should be left parenthesis */
alpar@1:       if (fmt[0] != '(')
alpar@1: fail: {  xprintf("hbm_read_mat: format `%s' not recognised\n", fmt);
alpar@1:          return 1;
alpar@1:       }
alpar@1:       k = 1;
alpar@1:       /* optional scale factor */
alpar@1:       dsa->fmt_p = 0;
alpar@1:       if (isdigit((unsigned char)fmt[k]))
alpar@1:       {  s = 0;
alpar@1:          while (isdigit((unsigned char)fmt[k]))
alpar@1:          {  if (s == 80) goto fail;
alpar@1:             str[s++] = fmt[k++];
alpar@1:          }
alpar@1:          str[s] = '\0';
alpar@1:          if (str2int(str, &val)) goto fail;
alpar@1:          if (toupper((unsigned char)fmt[k]) != 'P') goto iter;
alpar@1:          dsa->fmt_p = val, k++;
alpar@1:          if (!(0 <= dsa->fmt_p && dsa->fmt_p <= 255)) goto fail;
alpar@1:          /* optional comma may follow scale factor */
alpar@1:          if (fmt[k] == ',') k++;
alpar@1:       }
alpar@1:       /* optional iterator */
alpar@1:       dsa->fmt_k = 1;
alpar@1:       if (isdigit((unsigned char)fmt[k]))
alpar@1:       {  s = 0;
alpar@1:          while (isdigit((unsigned char)fmt[k]))
alpar@1:          {  if (s == 80) goto fail;
alpar@1:             str[s++] = fmt[k++];
alpar@1:          }
alpar@1:          str[s] = '\0';
alpar@1:          if (str2int(str, &val)) goto fail;
alpar@1: iter:    dsa->fmt_k = val;
alpar@1:          if (!(1 <= dsa->fmt_k && dsa->fmt_k <= 255)) goto fail;
alpar@1:       }
alpar@1:       /* format code */
alpar@1:       dsa->fmt_f = toupper((unsigned char)fmt[k++]);
alpar@1:       if (!(dsa->fmt_f == 'D' || dsa->fmt_f == 'E' ||
alpar@1:             dsa->fmt_f == 'F' || dsa->fmt_f == 'G' ||
alpar@1:             dsa->fmt_f == 'I')) goto fail;
alpar@1:       /* field width */
alpar@1:       if (!isdigit((unsigned char)fmt[k])) goto fail;
alpar@1:       s = 0;
alpar@1:       while (isdigit((unsigned char)fmt[k]))
alpar@1:       {  if (s == 80) goto fail;
alpar@1:          str[s++] = fmt[k++];
alpar@1:       }
alpar@1:       str[s] = '\0';
alpar@1:       if (str2int(str, &dsa->fmt_w)) goto fail;
alpar@1:       if (!(1 <= dsa->fmt_w && dsa->fmt_w <= 255)) goto fail;
alpar@1:       /* optional number of decimal places after point */
alpar@1:       dsa->fmt_d = 0;
alpar@1:       if (fmt[k] == '.')
alpar@1:       {  k++;
alpar@1:          if (!isdigit((unsigned char)fmt[k])) goto fail;
alpar@1:          s = 0;
alpar@1:          while (isdigit((unsigned char)fmt[k]))
alpar@1:          {  if (s == 80) goto fail;
alpar@1:             str[s++] = fmt[k++];
alpar@1:          }
alpar@1:          str[s] = '\0';
alpar@1:          if (str2int(str, &dsa->fmt_d)) goto fail;
alpar@1:          if (!(0 <= dsa->fmt_d && dsa->fmt_d <= 255)) goto fail;
alpar@1:       }
alpar@1:       /* last character should be right parenthesis */
alpar@1:       if (!(fmt[k] == ')' && fmt[k+1] == '\0')) goto fail;
alpar@1:       return 0;
alpar@1: }
alpar@1: 
alpar@1: /***********************************************************************
alpar@1: *  read_int_array - read array of integer type
alpar@1: *
alpar@1: *  This routine reads an integer array from the input text file, where
alpar@1: *  name is array name, fmt is Fortran format specification that controls
alpar@1: *  reading, n is number of array elements, val is array of integer type.
alpar@1: *  If the array was read successful, the routine returns zero, otherwise
alpar@1: *  non-zero. */
alpar@1: 
alpar@1: static int read_int_array(struct dsa *dsa, char *name, char *fmt,
alpar@1:       int n, int val[])
alpar@1: {     int k, pos;
alpar@1:       char str[80+1];
alpar@1:       if (parse_fmt(dsa, fmt)) return 1;
alpar@1:       if (!(dsa->fmt_f == 'I' && dsa->fmt_w <= 80 &&
alpar@1:             dsa->fmt_k * dsa->fmt_w <= 80))
alpar@1:       {  xprintf(
alpar@1:             "%s:%d: can't read array `%s' - invalid format `%s'\n",
alpar@1:             dsa->fname, dsa->seqn, name, fmt);
alpar@1:          return 1;
alpar@1:       }
alpar@1:       for (k = 1, pos = INT_MAX; k <= n; k++, pos++)
alpar@1:       {  if (pos >= dsa->fmt_k)
alpar@1:          {  if (read_card(dsa)) return 1;
alpar@1:             pos = 0;
alpar@1:          }
alpar@1:          memcpy(str, dsa->card + dsa->fmt_w * pos, dsa->fmt_w);
alpar@1:          str[dsa->fmt_w] = '\0';
alpar@1:          strspx(str);
alpar@1:          if (str2int(str, &val[k]))
alpar@1:          {  xprintf(
alpar@1:                "%s:%d: can't read array `%s' - invalid value `%s'\n",
alpar@1:                dsa->fname, dsa->seqn, name, str);
alpar@1:             return 1;
alpar@1:          }
alpar@1:       }
alpar@1:       return 0;
alpar@1: }
alpar@1: 
alpar@1: /***********************************************************************
alpar@1: *  read_real_array - read array of real type
alpar@1: *
alpar@1: *  This routine reads a real array from the input text file, where name
alpar@1: *  is array name, fmt is Fortran format specification that controls
alpar@1: *  reading, n is number of array elements, val is array of real type.
alpar@1: *  If the array was read successful, the routine returns zero, otherwise
alpar@1: *  non-zero. */
alpar@1: 
alpar@1: static int read_real_array(struct dsa *dsa, char *name, char *fmt,
alpar@1:       int n, double val[])
alpar@1: {     int k, pos;
alpar@1:       char str[80+1], *ptr;
alpar@1:       if (parse_fmt(dsa, fmt)) return 1;
alpar@1:       if (!(dsa->fmt_f != 'I' && dsa->fmt_w <= 80 &&
alpar@1:             dsa->fmt_k * dsa->fmt_w <= 80))
alpar@1:       {  xprintf(
alpar@1:             "%s:%d: can't read array `%s' - invalid format `%s'\n",
alpar@1:             dsa->fname, dsa->seqn, name, fmt);
alpar@1:          return 1;
alpar@1:       }
alpar@1:       for (k = 1, pos = INT_MAX; k <= n; k++, pos++)
alpar@1:       {  if (pos >= dsa->fmt_k)
alpar@1:          {  if (read_card(dsa)) return 1;
alpar@1:             pos = 0;
alpar@1:          }
alpar@1:          memcpy(str, dsa->card + dsa->fmt_w * pos, dsa->fmt_w);
alpar@1:          str[dsa->fmt_w] = '\0';
alpar@1:          strspx(str);
alpar@1:          if (strchr(str, '.') == NULL && strcmp(str, "0"))
alpar@1:          {  xprintf("%s(%d): can't read array `%s' - value `%s' has no "
alpar@1:                "decimal point\n", dsa->fname, dsa->seqn, name, str);
alpar@1:             return 1;
alpar@1:          }
alpar@1:          /* sometimes lower case letters appear */
alpar@1:          for (ptr = str; *ptr; ptr++)
alpar@1:             *ptr = (char)toupper((unsigned char)*ptr);
alpar@1:          ptr = strchr(str, 'D');
alpar@1:          if (ptr != NULL) *ptr = 'E';
alpar@1:          /* value may appear with decimal exponent but without letters
alpar@1:             E or D (for example, -123.456-012), so missing letter should
alpar@1:             be inserted */
alpar@1:          ptr = strchr(str+1, '+');
alpar@1:          if (ptr == NULL) ptr = strchr(str+1, '-');
alpar@1:          if (ptr != NULL && *(ptr-1) != 'E')
alpar@1:          {  xassert(strlen(str) < 80);
alpar@1:             memmove(ptr+1, ptr, strlen(ptr)+1);
alpar@1:             *ptr = 'E';
alpar@1:          }
alpar@1:          if (str2num(str, &val[k]))
alpar@1:          {  xprintf(
alpar@1:                "%s:%d: can't read array `%s' - invalid value `%s'\n",
alpar@1:                dsa->fname, dsa->seqn, name, str);
alpar@1:             return 1;
alpar@1:          }
alpar@1:       }
alpar@1:       return 0;
alpar@1: }
alpar@1: 
alpar@1: HBM *hbm_read_mat(const char *fname)
alpar@1: {     struct dsa _dsa, *dsa = &_dsa;
alpar@1:       HBM *hbm = NULL;
alpar@1:       dsa->fname = fname;
alpar@1:       xprintf("hbm_read_mat: reading matrix from `%s'...\n",
alpar@1:          dsa->fname);
alpar@1:       dsa->fp = fopen(dsa->fname, "r");
alpar@1:       if (dsa->fp == NULL)
alpar@1:       {  xprintf("hbm_read_mat: unable to open `%s' - %s\n",
alpar@1:             dsa->fname, strerror(errno));
alpar@1:          goto fail;
alpar@1:       }
alpar@1:       dsa->seqn = 0;
alpar@1:       hbm = xmalloc(sizeof(HBM));
alpar@1:       memset(hbm, 0, sizeof(HBM));
alpar@1:       /* read the first heading card */
alpar@1:       if (read_card(dsa)) goto fail;
alpar@1:       memcpy(hbm->title, dsa->card, 72), hbm->title[72] = '\0';
alpar@1:       strtrim(hbm->title);
alpar@1:       xprintf("%s\n", hbm->title);
alpar@1:       memcpy(hbm->key, dsa->card+72, 8), hbm->key[8] = '\0';
alpar@1:       strspx(hbm->key);
alpar@1:       xprintf("key = %s\n", hbm->key);
alpar@1:       /* read the second heading card */
alpar@1:       if (read_card(dsa)) goto fail;
alpar@1:       if (scan_int(dsa, "totcrd",  0, 14, &hbm->totcrd)) goto fail;
alpar@1:       if (scan_int(dsa, "ptrcrd", 14, 14, &hbm->ptrcrd)) goto fail;
alpar@1:       if (scan_int(dsa, "indcrd", 28, 14, &hbm->indcrd)) goto fail;
alpar@1:       if (scan_int(dsa, "valcrd", 42, 14, &hbm->valcrd)) goto fail;
alpar@1:       if (scan_int(dsa, "rhscrd", 56, 14, &hbm->rhscrd)) goto fail;
alpar@1:       xprintf("totcrd = %d; ptrcrd = %d; indcrd = %d; valcrd = %d; rhsc"
alpar@1:          "rd = %d\n", hbm->totcrd, hbm->ptrcrd, hbm->indcrd,
alpar@1:          hbm->valcrd, hbm->rhscrd);
alpar@1:       /* read the third heading card */
alpar@1:       if (read_card(dsa)) goto fail;
alpar@1:       memcpy(hbm->mxtype, dsa->card, 3), hbm->mxtype[3] = '\0';
alpar@1:       if (strchr("RCP",   hbm->mxtype[0]) == NULL ||
alpar@1:           strchr("SUHZR", hbm->mxtype[1]) == NULL ||
alpar@1:           strchr("AE",    hbm->mxtype[2]) == NULL)
alpar@1:       {  xprintf("%s:%d: matrix type `%s' not recognised\n",
alpar@1:             dsa->fname, dsa->seqn, hbm->mxtype);
alpar@1:          goto fail;
alpar@1:       }
alpar@1:       if (scan_int(dsa, "nrow", 14, 14, &hbm->nrow)) goto fail;
alpar@1:       if (scan_int(dsa, "ncol", 28, 14, &hbm->ncol)) goto fail;
alpar@1:       if (scan_int(dsa, "nnzero", 42, 14, &hbm->nnzero)) goto fail;
alpar@1:       if (scan_int(dsa, "neltvl", 56, 14, &hbm->neltvl)) goto fail;
alpar@1:       xprintf("mxtype = %s; nrow = %d; ncol = %d; nnzero = %d; neltvl ="
alpar@1:          " %d\n", hbm->mxtype, hbm->nrow, hbm->ncol, hbm->nnzero,
alpar@1:          hbm->neltvl);
alpar@1:       /* read the fourth heading card */
alpar@1:       if (read_card(dsa)) goto fail;
alpar@1:       memcpy(hbm->ptrfmt, dsa->card, 16), hbm->ptrfmt[16] = '\0';
alpar@1:       strspx(hbm->ptrfmt);
alpar@1:       memcpy(hbm->indfmt, dsa->card+16, 16), hbm->indfmt[16] = '\0';
alpar@1:       strspx(hbm->indfmt);
alpar@1:       memcpy(hbm->valfmt, dsa->card+32, 20), hbm->valfmt[20] = '\0';
alpar@1:       strspx(hbm->valfmt);
alpar@1:       memcpy(hbm->rhsfmt, dsa->card+52, 20), hbm->rhsfmt[20] = '\0';
alpar@1:       strspx(hbm->rhsfmt);
alpar@1:       xprintf("ptrfmt = %s; indfmt = %s; valfmt = %s; rhsfmt = %s\n",
alpar@1:          hbm->ptrfmt, hbm->indfmt, hbm->valfmt, hbm->rhsfmt);
alpar@1:       /* read the fifth heading card (optional) */
alpar@1:       if (hbm->rhscrd <= 0)
alpar@1:       {  strcpy(hbm->rhstyp, "???");
alpar@1:          hbm->nrhs = 0;
alpar@1:          hbm->nrhsix = 0;
alpar@1:       }
alpar@1:       else
alpar@1:       {  if (read_card(dsa)) goto fail;
alpar@1:          memcpy(hbm->rhstyp, dsa->card, 3), hbm->rhstyp[3] = '\0';
alpar@1:          if (scan_int(dsa, "nrhs", 14, 14, &hbm->nrhs)) goto fail;
alpar@1:          if (scan_int(dsa, "nrhsix", 28, 14, &hbm->nrhsix)) goto fail;
alpar@1:          xprintf("rhstyp = `%s'; nrhs = %d; nrhsix = %d\n",
alpar@1:             hbm->rhstyp, hbm->nrhs, hbm->nrhsix);
alpar@1:       }
alpar@1:       /* read matrix structure */
alpar@1:       hbm->colptr = xcalloc(1+hbm->ncol+1, sizeof(int));
alpar@1:       if (read_int_array(dsa, "colptr", hbm->ptrfmt, hbm->ncol+1,
alpar@1:          hbm->colptr)) goto fail;
alpar@1:       hbm->rowind = xcalloc(1+hbm->nnzero, sizeof(int));
alpar@1:       if (read_int_array(dsa, "rowind", hbm->indfmt, hbm->nnzero,
alpar@1:          hbm->rowind)) goto fail;
alpar@1:       /* read matrix values */
alpar@1:       if (hbm->valcrd <= 0) goto done;
alpar@1:       if (hbm->mxtype[2] == 'A')
alpar@1:       {  /* assembled matrix */
alpar@1:          hbm->values = xcalloc(1+hbm->nnzero, sizeof(double));
alpar@1:          if (read_real_array(dsa, "values", hbm->valfmt, hbm->nnzero,
alpar@1:             hbm->values)) goto fail;
alpar@1:       }
alpar@1:       else
alpar@1:       {  /* elemental (unassembled) matrix */
alpar@1:          hbm->values = xcalloc(1+hbm->neltvl, sizeof(double));
alpar@1:          if (read_real_array(dsa, "values", hbm->valfmt, hbm->neltvl,
alpar@1:             hbm->values)) goto fail;
alpar@1:       }
alpar@1:       /* read right-hand sides */
alpar@1:       if (hbm->nrhs <= 0) goto done;
alpar@1:       if (hbm->rhstyp[0] == 'F')
alpar@1:       {  /* dense format */
alpar@1:          hbm->nrhsvl = hbm->nrow * hbm->nrhs;
alpar@1:          hbm->rhsval = xcalloc(1+hbm->nrhsvl, sizeof(double));
alpar@1:          if (read_real_array(dsa, "rhsval", hbm->rhsfmt, hbm->nrhsvl,
alpar@1:             hbm->rhsval)) goto fail;
alpar@1:       }
alpar@1:       else if (hbm->rhstyp[0] == 'M' && hbm->mxtype[2] == 'A')
alpar@1:       {  /* sparse format */
alpar@1:          /* read pointers */
alpar@1:          hbm->rhsptr = xcalloc(1+hbm->nrhs+1, sizeof(int));
alpar@1:          if (read_int_array(dsa, "rhsptr", hbm->ptrfmt, hbm->nrhs+1,
alpar@1:             hbm->rhsptr)) goto fail;
alpar@1:          /* read sparsity pattern */
alpar@1:          hbm->rhsind = xcalloc(1+hbm->nrhsix, sizeof(int));
alpar@1:          if (read_int_array(dsa, "rhsind", hbm->indfmt, hbm->nrhsix,
alpar@1:             hbm->rhsind)) goto fail;
alpar@1:          /* read values */
alpar@1:          hbm->rhsval = xcalloc(1+hbm->nrhsix, sizeof(double));
alpar@1:          if (read_real_array(dsa, "rhsval", hbm->rhsfmt, hbm->nrhsix,
alpar@1:             hbm->rhsval)) goto fail;
alpar@1:       }
alpar@1:       else if (hbm->rhstyp[0] == 'M' && hbm->mxtype[2] == 'E')
alpar@1:       {  /* elemental format */
alpar@1:          hbm->rhsval = xcalloc(1+hbm->nrhsvl, sizeof(double));
alpar@1:          if (read_real_array(dsa, "rhsval", hbm->rhsfmt, hbm->nrhsvl,
alpar@1:             hbm->rhsval)) goto fail;
alpar@1:       }
alpar@1:       else
alpar@1:       {  xprintf("%s:%d: right-hand side type `%c' not recognised\n",
alpar@1:             dsa->fname, dsa->seqn, hbm->rhstyp[0]);
alpar@1:          goto fail;
alpar@1:       }
alpar@1:       /* read starting guesses */
alpar@1:       if (hbm->rhstyp[1] == 'G')
alpar@1:       {  hbm->nguess = hbm->nrow * hbm->nrhs;
alpar@1:          hbm->sguess = xcalloc(1+hbm->nguess, sizeof(double));
alpar@1:          if (read_real_array(dsa, "sguess", hbm->rhsfmt, hbm->nguess,
alpar@1:             hbm->sguess)) goto fail;
alpar@1:       }
alpar@1:       /* read solution vectors */
alpar@1:       if (hbm->rhstyp[2] == 'X')
alpar@1:       {  hbm->nexact = hbm->nrow * hbm->nrhs;
alpar@1:          hbm->xexact = xcalloc(1+hbm->nexact, sizeof(double));
alpar@1:          if (read_real_array(dsa, "xexact", hbm->rhsfmt, hbm->nexact,
alpar@1:             hbm->xexact)) goto fail;
alpar@1:       }
alpar@1: done: /* reading has been completed */
alpar@1:       xprintf("hbm_read_mat: %d cards were read\n", dsa->seqn);
alpar@1:       fclose(dsa->fp);
alpar@1:       return hbm;
alpar@1: fail: /* something wrong in Danish kingdom */
alpar@1:       if (hbm != NULL)
alpar@1:       {  if (hbm->colptr != NULL) xfree(hbm->colptr);
alpar@1:          if (hbm->rowind != NULL) xfree(hbm->rowind);
alpar@1:          if (hbm->rhsptr != NULL) xfree(hbm->rhsptr);
alpar@1:          if (hbm->rhsind != NULL) xfree(hbm->rhsind);
alpar@1:          if (hbm->values != NULL) xfree(hbm->values);
alpar@1:          if (hbm->rhsval != NULL) xfree(hbm->rhsval);
alpar@1:          if (hbm->sguess != NULL) xfree(hbm->sguess);
alpar@1:          if (hbm->xexact != NULL) xfree(hbm->xexact);
alpar@1:          xfree(hbm);
alpar@1:       }
alpar@1:       if (dsa->fp != NULL) fclose(dsa->fp);
alpar@1:       return NULL;
alpar@1: }
alpar@1: 
alpar@1: /***********************************************************************
alpar@1: *  NAME
alpar@1: *
alpar@1: *  hbm_free_mat - free sparse matrix in Harwell-Boeing format
alpar@1: *
alpar@1: *  SYNOPSIS
alpar@1: *
alpar@1: *  #include "glphbm.h"
alpar@1: *  void hbm_free_mat(HBM *hbm);
alpar@1: *
alpar@1: *  DESCRIPTION
alpar@1: *
alpar@1: *  The hbm_free_mat routine frees all the memory allocated to the data
alpar@1: *  structure containing a sparse matrix in the Harwell-Boeing format. */
alpar@1: 
alpar@1: void hbm_free_mat(HBM *hbm)
alpar@1: {     if (hbm->colptr != NULL) xfree(hbm->colptr);
alpar@1:       if (hbm->rowind != NULL) xfree(hbm->rowind);
alpar@1:       if (hbm->rhsptr != NULL) xfree(hbm->rhsptr);
alpar@1:       if (hbm->rhsind != NULL) xfree(hbm->rhsind);
alpar@1:       if (hbm->values != NULL) xfree(hbm->values);
alpar@1:       if (hbm->rhsval != NULL) xfree(hbm->rhsval);
alpar@1:       if (hbm->sguess != NULL) xfree(hbm->sguess);
alpar@1:       if (hbm->xexact != NULL) xfree(hbm->xexact);
alpar@1:       xfree(hbm);
alpar@1:       return;
alpar@1: }
alpar@1: 
alpar@1: /* eof */