static int read_int_array(struct dsa *dsa, char *name, char *fmt,
int n, int val[])
{ int k, pos;
char str[80+1];
if (parse_fmt(dsa, fmt)) return 1;
if (!(dsa->fmt_f == 'I' && dsa->fmt_w <= 80 &&
dsa->fmt_k * dsa->fmt_w <= 80))
{ xprintf(
"%s:%d: can't read array '%s' - invalid format '%s'\n",
dsa->fname, dsa->seqn, name, fmt);
return 1;
}
for (k = 1, pos = INT_MAX; k <= n; k++, pos++)
{ if (pos >= dsa->fmt_k)
{ if (read_card(dsa)) return 1;
pos = 0;
}
memcpy(str, dsa->card + dsa->fmt_w * pos, dsa->fmt_w);
str[dsa->fmt_w] = '\0';
strspx(str);
if (str2int(str, &val[k]))
{ xprintf(
"%s:%d: can't read array '%s' - invalid value '%s'\n",
dsa->fname, dsa->seqn, name, str);
return 1;
}
}
return 0;
}
static int scan_int(struct dsa *dsa, char *fld, int pos, int width,
int *val)
{ char str[80+1];
xassert(1 <= width && width <= 80);
memcpy(str, dsa->card + pos, width), str[width] = '\0';
if (str2int(strspx(str), val))
{ xprintf("%s:%d: field '%s' contains invalid value '%s'\n",
dsa->fname, dsa->seqn, fld, str);
return 1;
}
return 0;
}
static int dbf_read_record(TABDCA *dca, struct dbf *dbf)
{ /* read next record from xBASE data file */
int b, j, k, ret = 0;
char buf[DBF_FDLEN_MAX+1];
xassert(dbf->mode == 'R');
if (setjmp(dbf->jump))
{ ret = 1;
goto done;
}
/* check record flag */
b = read_byte(dbf);
if (b == 0x1A)
{ /* end of data */
ret = -1;
goto done;
}
if (b != 0x20)
{ xprintf("%s:0x%X: invalid record flag\n", dbf->fname,
dbf->offset);
longjmp(dbf->jump, 0);
}
/* read dummy RECNO field */
if (dbf->ref[0] > 0)
mpl_tab_set_num(dca, dbf->ref[0], dbf->count+1);
/* read fields */
for (k = 1; k <= dbf->nf; k++)
{ /* read k-th field */
for (j = 0; j < dbf->len[k]; j++)
buf[j] = (char)read_byte(dbf);
buf[dbf->len[k]] = '\0';
/* set field value */
if (dbf->type[k] == 'C')
{ /* character field */
if (dbf->ref[k] > 0)
mpl_tab_set_str(dca, dbf->ref[k], strtrim(buf));
}
else if (dbf->type[k] == 'N')
{ /* numeric field */
if (dbf->ref[k] > 0)
{ double num;
strspx(buf);
xassert(str2num(buf, &num) == 0);
mpl_tab_set_num(dca, dbf->ref[k], num);
}
}
else
xassert(dbf != dbf);
}
/* increase record count */
dbf->count++;
done: return ret;
}
static int read_real_array(struct dsa *dsa, char *name, char *fmt,
int n, double val[])
{ int k, pos;
char str[80+1], *ptr;
if (parse_fmt(dsa, fmt)) return 1;
if (!(dsa->fmt_f != 'I' && dsa->fmt_w <= 80 &&
dsa->fmt_k * dsa->fmt_w <= 80))
{ xprintf(
"%s:%d: can't read array '%s' - invalid format '%s'\n",
dsa->fname, dsa->seqn, name, fmt);
return 1;
}
for (k = 1, pos = INT_MAX; k <= n; k++, pos++)
{ if (pos >= dsa->fmt_k)
{ if (read_card(dsa)) return 1;
pos = 0;
}
memcpy(str, dsa->card + dsa->fmt_w * pos, dsa->fmt_w);
str[dsa->fmt_w] = '\0';
strspx(str);
if (strchr(str, '.') == NULL && strcmp(str, "0"))
{ xprintf("%s(%d): can't read array '%s' - value '%s' has no "
"decimal point\n", dsa->fname, dsa->seqn, name, str);
return 1;
}
/* sometimes lower case letters appear */
for (ptr = str; *ptr; ptr++)
*ptr = (char)toupper((unsigned char)*ptr);
ptr = strchr(str, 'D');
if (ptr != NULL) *ptr = 'E';
/* value may appear with decimal exponent but without letters
E or D (for example, -123.456-012), so missing letter should
be inserted */
ptr = strchr(str+1, '+');
if (ptr == NULL) ptr = strchr(str+1, '-');
if (ptr != NULL && *(ptr-1) != 'E')
{ xassert(strlen(str) < 80);
memmove(ptr+1, ptr, strlen(ptr)+1);
*ptr = 'E';
}
if (str2num(str, &val[k]))
{ xprintf(
"%s:%d: can't read array '%s' - invalid value '%s'\n",
dsa->fname, dsa->seqn, name, str);
return 1;
}
}
return 0;
}
HBM *hbm_read_mat(const char *fname)
{ struct dsa _dsa, *dsa = &_dsa;
HBM *hbm = NULL;
dsa->fname = fname;
xprintf("hbm_read_mat: reading matrix from '%s'...\n",
dsa->fname);
dsa->fp = fopen(dsa->fname, "r");
if (dsa->fp == NULL)
{ xprintf("hbm_read_mat: unable to open '%s' - %s\n",
dsa->fname, strerror(errno));
goto fail;
}
dsa->seqn = 0;
hbm = xmalloc(sizeof(HBM));
memset(hbm, 0, sizeof(HBM));
/* read the first heading card */
if (read_card(dsa)) goto fail;
memcpy(hbm->title, dsa->card, 72), hbm->title[72] = '\0';
strtrim(hbm->title);
xprintf("%s\n", hbm->title);
memcpy(hbm->key, dsa->card+72, 8), hbm->key[8] = '\0';
strspx(hbm->key);
xprintf("key = %s\n", hbm->key);
/* read the second heading card */
if (read_card(dsa)) goto fail;
if (scan_int(dsa, "totcrd", 0, 14, &hbm->totcrd)) goto fail;
if (scan_int(dsa, "ptrcrd", 14, 14, &hbm->ptrcrd)) goto fail;
if (scan_int(dsa, "indcrd", 28, 14, &hbm->indcrd)) goto fail;
if (scan_int(dsa, "valcrd", 42, 14, &hbm->valcrd)) goto fail;
if (scan_int(dsa, "rhscrd", 56, 14, &hbm->rhscrd)) goto fail;
xprintf("totcrd = %d; ptrcrd = %d; indcrd = %d; valcrd = %d; rhsc"
"rd = %d\n", hbm->totcrd, hbm->ptrcrd, hbm->indcrd,
hbm->valcrd, hbm->rhscrd);
/* read the third heading card */
if (read_card(dsa)) goto fail;
memcpy(hbm->mxtype, dsa->card, 3), hbm->mxtype[3] = '\0';
if (strchr("RCP", hbm->mxtype[0]) == NULL ||
strchr("SUHZR", hbm->mxtype[1]) == NULL ||
strchr("AE", hbm->mxtype[2]) == NULL)
{ xprintf("%s:%d: matrix type '%s' not recognised\n",
dsa->fname, dsa->seqn, hbm->mxtype);
goto fail;
}
if (scan_int(dsa, "nrow", 14, 14, &hbm->nrow)) goto fail;
if (scan_int(dsa, "ncol", 28, 14, &hbm->ncol)) goto fail;
if (scan_int(dsa, "nnzero", 42, 14, &hbm->nnzero)) goto fail;
if (scan_int(dsa, "neltvl", 56, 14, &hbm->neltvl)) goto fail;
xprintf("mxtype = %s; nrow = %d; ncol = %d; nnzero = %d; neltvl ="
" %d\n", hbm->mxtype, hbm->nrow, hbm->ncol, hbm->nnzero,
hbm->neltvl);
/* read the fourth heading card */
if (read_card(dsa)) goto fail;
memcpy(hbm->ptrfmt, dsa->card, 16), hbm->ptrfmt[16] = '\0';
strspx(hbm->ptrfmt);
memcpy(hbm->indfmt, dsa->card+16, 16), hbm->indfmt[16] = '\0';
strspx(hbm->indfmt);
memcpy(hbm->valfmt, dsa->card+32, 20), hbm->valfmt[20] = '\0';
strspx(hbm->valfmt);
memcpy(hbm->rhsfmt, dsa->card+52, 20), hbm->rhsfmt[20] = '\0';
strspx(hbm->rhsfmt);
xprintf("ptrfmt = %s; indfmt = %s; valfmt = %s; rhsfmt = %s\n",
hbm->ptrfmt, hbm->indfmt, hbm->valfmt, hbm->rhsfmt);
/* read the fifth heading card (optional) */
if (hbm->rhscrd <= 0)
{ strcpy(hbm->rhstyp, "???");
hbm->nrhs = 0;
hbm->nrhsix = 0;
}
else
{ if (read_card(dsa)) goto fail;
memcpy(hbm->rhstyp, dsa->card, 3), hbm->rhstyp[3] = '\0';
if (scan_int(dsa, "nrhs", 14, 14, &hbm->nrhs)) goto fail;
if (scan_int(dsa, "nrhsix", 28, 14, &hbm->nrhsix)) goto fail;
xprintf("rhstyp = '%s'; nrhs = %d; nrhsix = %d\n",
hbm->rhstyp, hbm->nrhs, hbm->nrhsix);
}
/* read matrix structure */
hbm->colptr = xcalloc(1+hbm->ncol+1, sizeof(int));
if (read_int_array(dsa, "colptr", hbm->ptrfmt, hbm->ncol+1,
hbm->colptr)) goto fail;
hbm->rowind = xcalloc(1+hbm->nnzero, sizeof(int));
if (read_int_array(dsa, "rowind", hbm->indfmt, hbm->nnzero,
hbm->rowind)) goto fail;
/* read matrix values */
if (hbm->valcrd <= 0) goto done;
if (hbm->mxtype[2] == 'A')
{ /* assembled matrix */
hbm->values = xcalloc(1+hbm->nnzero, sizeof(double));
if (read_real_array(dsa, "values", hbm->valfmt, hbm->nnzero,
hbm->values)) goto fail;
}
else
{ /* elemental (unassembled) matrix */
hbm->values = xcalloc(1+hbm->neltvl, sizeof(double));
if (read_real_array(dsa, "values", hbm->valfmt, hbm->neltvl,
hbm->values)) goto fail;
}
/* read right-hand sides */
if (hbm->nrhs <= 0) goto done;
if (hbm->rhstyp[0] == 'F')
{ /* dense format */
hbm->nrhsvl = hbm->nrow * hbm->nrhs;
hbm->rhsval = xcalloc(1+hbm->nrhsvl, sizeof(double));
if (read_real_array(dsa, "rhsval", hbm->rhsfmt, hbm->nrhsvl,
hbm->rhsval)) goto fail;
}
else if (hbm->rhstyp[0] == 'M' && hbm->mxtype[2] == 'A')
{ /* sparse format */
/* read pointers */
hbm->rhsptr = xcalloc(1+hbm->nrhs+1, sizeof(int));
if (read_int_array(dsa, "rhsptr", hbm->ptrfmt, hbm->nrhs+1,
hbm->rhsptr)) goto fail;
/* read sparsity pattern */
hbm->rhsind = xcalloc(1+hbm->nrhsix, sizeof(int));
if (read_int_array(dsa, "rhsind", hbm->indfmt, hbm->nrhsix,
hbm->rhsind)) goto fail;
/* read values */
hbm->rhsval = xcalloc(1+hbm->nrhsix, sizeof(double));
if (read_real_array(dsa, "rhsval", hbm->rhsfmt, hbm->nrhsix,
hbm->rhsval)) goto fail;
}
else if (hbm->rhstyp[0] == 'M' && hbm->mxtype[2] == 'E')
{ /* elemental format */
hbm->rhsval = xcalloc(1+hbm->nrhsvl, sizeof(double));
if (read_real_array(dsa, "rhsval", hbm->rhsfmt, hbm->nrhsvl,
hbm->rhsval)) goto fail;
}
else
{ xprintf("%s:%d: right-hand side type '%c' not recognised\n",
dsa->fname, dsa->seqn, hbm->rhstyp[0]);
goto fail;
}
/* read starting guesses */
if (hbm->rhstyp[1] == 'G')
{ hbm->nguess = hbm->nrow * hbm->nrhs;
hbm->sguess = xcalloc(1+hbm->nguess, sizeof(double));
if (read_real_array(dsa, "sguess", hbm->rhsfmt, hbm->nguess,
hbm->sguess)) goto fail;
}
/* read solution vectors */
if (hbm->rhstyp[2] == 'X')
{ hbm->nexact = hbm->nrow * hbm->nrhs;
hbm->xexact = xcalloc(1+hbm->nexact, sizeof(double));
if (read_real_array(dsa, "xexact", hbm->rhsfmt, hbm->nexact,
hbm->xexact)) goto fail;
}
done: /* reading has been completed */
xprintf("hbm_read_mat: %d cards were read\n", dsa->seqn);
fclose(dsa->fp);
return hbm;
fail: /* something wrong in Danish kingdom */
if (hbm != NULL)
{ if (hbm->colptr != NULL) xfree(hbm->colptr);
if (hbm->rowind != NULL) xfree(hbm->rowind);
if (hbm->rhsptr != NULL) xfree(hbm->rhsptr);
if (hbm->rhsind != NULL) xfree(hbm->rhsind);
if (hbm->values != NULL) xfree(hbm->values);
if (hbm->rhsval != NULL) xfree(hbm->rhsval);
if (hbm->sguess != NULL) xfree(hbm->sguess);
if (hbm->xexact != NULL) xfree(hbm->xexact);
xfree(hbm);
}
if (dsa->fp != NULL) fclose(dsa->fp);
return NULL;
}
