/* colcalc.f -- translated by f2c (version 19961017).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
#include "f2c.h"
/* Table of constant values */
static integer c__1 = 1;
static logical c_true = TRUE_;
static integer c__3 = 3;
static integer c__5 = 5;
/* Main program */ MAIN__(void)
{
/* Format strings */
static char fmt_101[] = "(\002 output\002,i1,\002> \002$)";
static char fmt_111[] = "(a)";
static char fmt_1001[] = "(\002 Must enter at least one output column"
"!\002)";
static char fmt_1002[] = "(\002 Enter \002,a6,\002 filename :"
" \002$)";
static char fmt_1019[] = "(\002*** cannot read numbers from that file "
"***\002)";
static char fmt_1029[] = "(/\002 *** max column # in expressions =\002,i"
"3/\002 *** in input file =\002,i3/\002 *** trailin"
"g columns set to zero ***\002/)";
static char fmt_1031[] = "(\002 OK, enter number of rows to run: \002$)";
static char fmt_1051[] = "(\002 stopping expression (end < 0) : \002$)";
static char fmt_1201[] = "(9(1x,1pg20.13))";
/* System generated locals */
integer i__1, i__2, i__3;
olist o__1;
cllist cl__1;
alist al__1;
static doublereal equiv_0[1];
/* Builtin functions */
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
s_rsfe(cilist *), e_rsfe(void), s_cmp(char *, char *, ftnlen,
ftnlen), f_open(olist *), f_rew(alist *), f_clos(cllist *),
s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_rsle(void);
/* Local variables */
static integer ncol, ierr, num_code__[26], irow, nout, nrow;
static doublereal rout[9], r8val[26];
static integer i__, ncmax;
extern integer inumc_(char *, ftnlen);
#define c8 ((char *)equiv_0)
#define r8 (equiv_0)
static char c_code__[8*200*26];
static integer ialpha;
static char c_expr__[666];
extern /* Subroutine */ int parser_(char *, logical *, integer *, char *,
ftnlen, ftnlen);
static logical lstout;
extern doublereal pareval_(integer *, char *, doublereal *, ftnlen);
static char c_cstop__[8*200];
static integer n_cstop__;
static doublereal r_cstop__;
/* Fortran I/O blocks */
static cilist io___8 = { 0, 6, 0, fmt_101, 0 };
static cilist io___9 = { 1, 5, 1, fmt_111, 0 };
static cilist io___13 = { 0, 6, 0, fmt_1001, 0 };
static cilist io___15 = { 0, 6, 0, fmt_1002, 0 };
static cilist io___16 = { 1, 5, 1, fmt_111, 0 };
static cilist io___18 = { 0, 77, 0, fmt_111, 0 };
static cilist io___19 = { 0, 6, 0, fmt_1019, 0 };
static cilist io___20 = { 0, 6, 0, fmt_1029, 0 };
static cilist io___21 = { 0, 6, 0, fmt_1031, 0 };
static cilist io___22 = { 0, 5, 0, 0, 0 };
static cilist io___24 = { 0, 6, 0, fmt_1002, 0 };
static cilist io___25 = { 1, 5, 1, fmt_111, 0 };
static cilist io___28 = { 0, 6, 0, fmt_1051, 0 };
static cilist io___29 = { 1, 5, 1, fmt_111, 0 };
static cilist io___32 = { 1, 77, 1, 0, 0 };
static cilist io___35 = { 0, 6, 0, fmt_1201, 0 };
static cilist io___36 = { 0, 78, 0, fmt_1201, 0 };
/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
*/
for (i__ = 1; i__ <= 26; ++i__) {
r8val[i__ - 1] = 0.;
/* L90: */
}
nout = 1;
ncmax = 0;
ialpha = 'A' - 1;
/* .......................................................................
*/
L100:
s_wsfe(&io___8);
do_fio(&c__1, (char *)&nout, (ftnlen)sizeof(integer));
e_wsfe();
i__1 = s_rsfe(&io___9);
if (i__1 != 0) {
goto L1000;
}
i__1 = do_fio(&c__1, c_expr__, 666L);
if (i__1 != 0) {
goto L1000;
}
i__1 = e_rsfe();
if (i__1 != 0) {
goto L1000;
}
if (s_cmp(c_expr__, " ", 666L, 1L) == 0 || s_cmp(c_expr__, "end", 666L,
3L) == 0 || s_cmp(c_expr__, "exit", 666L, 4L) == 0 || s_cmp(
c_expr__, "quit", 666L, 4L) == 0) {
goto L1000;
}
parser_(c_expr__, &c_true, &num_code__[nout - 1], c_code__ + (nout * 200
- 200 << 3), 666L, 8L);
if (num_code__[nout - 1] <= 0) {
goto L100;
}
/* find maximum symbol (column) reference */
i__1 = num_code__[nout - 1] - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
if (s_cmp(c_code__ + (i__ + nout * 200 - 201 << 3), "PUSHSYM", 8L, 7L)
== 0) {
/* Computing MAX */
i__2 = ncmax, i__3 = *(unsigned char *)&c_code__[(i__ + 1 + nout *
200 - 201) * 8] - ialpha;
ncmax = max(i__2,i__3);
}
/* L200: */
}
++nout;
if (nout <= 9) {
goto L100;
}
/* ----------------------------------------------------------------------
*/
L1000:
--nout;
if (nout <= 0) {
s_wsfe(&io___13);
e_wsfe();
goto L9000;
}
L1010:
ncol = 0;
s_wsfe(&io___15);
do_fio(&c__1, "input", 5L);
e_wsfe();
i__1 = s_rsfe(&io___16);
if (i__1 != 0) {
goto L100001;
}
i__1 = do_fio(&c__1, c_expr__, 666L);
if (i__1 != 0) {
goto L100001;
}
i__1 = e_rsfe();
L100001:
if (i__1 < 0) {
goto L9000;
}
if (i__1 > 0) {
goto L1010;
}
if (*(unsigned char *)c_expr__ == ' ') {
goto L1030;
}
o__1.oerr = 1;
o__1.ounit = 77;
o__1.ofnmlen = 666;
o__1.ofnm = c_expr__;
o__1.orl = 0;
o__1.osta = "OLD";
o__1.oacc = 0;
o__1.ofm = "FORMATTED";
o__1.oblnk = 0;
ierr = f_open(&o__1);
if (ierr != 0) {
goto L1010;
}
/* Find out how many columns of numbers are in this file by */
/* reading the first line */
s_rsfe(&io___18);
do_fio(&c__1, c_expr__, 666L);
e_rsfe();
al__1.aerr = 0;
al__1.aunit = 77;
f_rew(&al__1);
ncol = inumc_(c_expr__, 666L);
/* cc write(*,7707) ncol */
/* cc7707 format('inumc returns ',I5) */
if (ncol <= 0) {
s_wsfe(&io___19);
e_wsfe();
cl__1.cerr = 0;
cl__1.cunit = 77;
cl__1.csta = 0;
f_clos(&cl__1);
goto L1010;
}
if (ncmax > ncol) {
s_wsfe(&io___20);
do_fio(&c__1, (char *)&ncmax, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&ncol, (ftnlen)sizeof(integer));
e_wsfe();
}
ncol = min(ncol,ncmax);
L1030:
if (ncol == 0) {
s_wsfe(&io___21);
e_wsfe();
s_rsle(&io___22);
do_lio(&c__3, &c__1, (char *)&nrow, (ftnlen)sizeof(integer));
e_rsle();
if (nrow <= 0) {
goto L1030;
}
} else {
nrow = 999999;
}
s_wsfe(&io___24);
do_fio(&c__1, "output", 6L);
e_wsfe();
i__1 = s_rsfe(&io___25);
if (i__1 != 0) {
goto L100002;
}
i__1 = do_fio(&c__1, c_expr__, 666L);
if (i__1 != 0) {
goto L100002;
}
i__1 = e_rsfe();
L100002:
if (i__1 < 0) {
goto L9000;
}
if (i__1 > 0) {
goto L1030;
}
lstout = *(unsigned char *)c_expr__ == ' ';
if (! lstout) {
o__1.oerr = 1;
o__1.ounit = 78;
o__1.ofnmlen = 666;
o__1.ofnm = c_expr__;
o__1.orl = 0;
o__1.osta = "NEW";
o__1.oacc = 0;
o__1.ofm = "FORMATTED";
o__1.oblnk = 0;
ierr = f_open(&o__1);
if (ierr != 0) {
goto L1030;
}
}
/* .....................................................................
*/
L1050:
n_cstop__ = 0;
s_wsfe(&io___28);
e_wsfe();
i__1 = s_rsfe(&io___29);
if (i__1 != 0) {
goto L1090;
}
i__1 = do_fio(&c__1, c_expr__, 666L);
if (i__1 != 0) {
goto L1090;
}
i__1 = e_rsfe();
if (i__1 != 0) {
goto L1090;
}
if (s_cmp(c_expr__, " ", 666L, 1L) == 0 || s_cmp(c_expr__, "1", 666L, 1L)
== 0) {
goto L1090;
}
parser_(c_expr__, &c_true, &n_cstop__, c_cstop__, 666L, 8L);
if (n_cstop__ <= 0) {
goto L1050;
}
/* .....................................................................
*/
L1090:
irow = 0;
L1100:
++irow;
r8val[25] = (doublereal) irow;
if (ncol > 0) {
i__1 = s_rsle(&io___32);
if (i__1 != 0) {
goto L9000;
}
i__2 = ncol;
for (i__ = 1; i__ <= i__2; ++i__) {
i__1 = do_lio(&c__5, &c__1, (char *)&r8val[i__ - 1], (ftnlen)
sizeof(doublereal));
if (i__1 != 0) {
goto L9000;
}
}
i__1 = e_rsle();
if (i__1 != 0) {
goto L9000;
}
}
i__1 = nout;
for (i__ = 1; i__ <= i__1; ++i__) {
rout[i__ - 1] = pareval_(&num_code__[i__ - 1], c_code__ + (i__ * 200
- 200 << 3), r8val, 8L);
/* L1200: */
}
if (n_cstop__ > 0) {
r_cstop__ = pareval_(&n_cstop__, c_cstop__, r8val, 8L);
if (r_cstop__ < 0.) {
goto L9000;
}
}
if (lstout) {
s_wsfe(&io___35);
i__1 = nout;
for (i__ = 1; i__ <= i__1; ++i__) {
do_fio(&c__1, (char *)&rout[i__ - 1], (ftnlen)sizeof(doublereal));
}
e_wsfe();
} else {
s_wsfe(&io___36);
i__1 = nout;
for (i__ = 1; i__ <= i__1; ++i__) {
do_fio(&c__1, (char *)&rout[i__ - 1], (ftnlen)sizeof(doublereal));
}
e_wsfe();
}
if (ncol > 0 || irow < nrow) {
goto L1100;
}
/* .......................................................................
*/
L9000:
return 0;
} /* MAIN__ */
#undef r8
#undef c8
integer inumc_(char *cline, ftnlen cline_len)
{
/* System generated locals */
integer ret_val, i__1;
doublereal d__1;
icilist ici__1;
/* Builtin functions */
integer s_rsli(icilist *), do_lio(integer *, integer *, char *, ftnlen),
e_rsli(void);
/* Local variables */
static integer ierr;
static doublereal rval[26];
static integer itry, i__;
/* Find how many columns there are in the string CLINE */
/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
*/
for (itry = 1; itry <= 26; ++itry) {
i__1 = itry;
for (i__ = 1; i__ <= i__1; ++i__) {
rval[i__ - 1] = -9.876543e26;
/* L50: */
}
ici__1.icierr = 1;
ici__1.iciend = 1;
ici__1.icirnum = 1;
ici__1.icirlen = cline_len;
ici__1.iciunit = cline;
ici__1.icifmt = 0;
ierr = s_rsli(&ici__1);
if (ierr != 0) {
goto L100003;
}
i__1 = itry;
for (i__ = 1; i__ <= i__1; ++i__) {
ierr = do_lio(&c__5, &c__1, (char *)&rval[i__ - 1], (ftnlen)
sizeof(doublereal));
if (ierr != 0) {
goto L100003;
}
}
ierr = e_rsli();
L100003:
if (ierr != 0) {
goto L200;
}
if ((d__1 = rval[itry - 1] / -9.876543e26 - 1., abs(d__1)) <= 1e-11) {
goto L200;
}
/* L100: */
}
itry = 27;
L200:
ret_val = itry - 1;
return ret_val;
} /* inumc_ */
/* Main program alias */ int colcalc_ () { MAIN__ (); return 0; }
syntax highlighted by Code2HTML, v. 0.9.1