00001
00002
00003
00004
00005
00006 #include "f2c.h"
00007
00008
00009
00010 static integer c__1 = 1;
00011 static logical c_true = TRUE_;
00012 static integer c__3 = 3;
00013 static integer c__5 = 5;
00014
00015 MAIN__(void)
00016 {
00017
00018 static char fmt_101[] = "(\002 output\002,i1,\002> \002$)";
00019 static char fmt_111[] = "(a)";
00020 static char fmt_1001[] = "(\002 Must enter at least one output column"
00021 "!\002)";
00022 static char fmt_1002[] = "(\002 Enter \002,a6,\002 filename :"
00023 " \002$)";
00024 static char fmt_1019[] = "(\002*** cannot read numbers from that file "
00025 "***\002)";
00026 static char fmt_1029[] = "(/\002 *** max column # in expressions =\002,i"
00027 "3/\002 *** in input file =\002,i3/\002 *** trailin"
00028 "g columns set to zero ***\002/)";
00029 static char fmt_1031[] = "(\002 OK, enter number of rows to run: \002$)";
00030 static char fmt_1051[] = "(\002 stopping expression (end < 0) : \002$)";
00031 static char fmt_1201[] = "(9(1x,1pg20.13))";
00032
00033
00034 integer i__1, i__2, i__3;
00035 olist o__1;
00036 cllist cl__1;
00037 alist al__1;
00038 static doublereal equiv_0[1];
00039
00040
00041 integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
00042 s_rsfe(cilist *), e_rsfe(void), s_cmp(char *, char *, ftnlen,
00043 ftnlen), f_open(olist *), f_rew(alist *), f_clos(cllist *),
00044 s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
00045 e_rsle(void);
00046
00047
00048 static integer ncol, ierr, num_code__[26], irow, nout, nrow;
00049 static doublereal rout[9], r8val[26];
00050 static integer i__, ncmax;
00051 extern integer inumc_(char *, ftnlen);
00052 #define c8 ((char *)equiv_0)
00053 #define r8 (equiv_0)
00054 static char c_code__[8*200*26];
00055 static integer ialpha;
00056 static char c_expr__[666];
00057 extern int parser_(char *, logical *, integer *, char *,
00058 ftnlen, ftnlen);
00059 static logical lstout;
00060 extern doublereal pareval_(integer *, char *, doublereal *, ftnlen);
00061 static char c_cstop__[8*200];
00062 static integer n_cstop__;
00063 static doublereal r_cstop__;
00064
00065
00066 static cilist io___8 = { 0, 6, 0, fmt_101, 0 };
00067 static cilist io___9 = { 1, 5, 1, fmt_111, 0 };
00068 static cilist io___13 = { 0, 6, 0, fmt_1001, 0 };
00069 static cilist io___15 = { 0, 6, 0, fmt_1002, 0 };
00070 static cilist io___16 = { 1, 5, 1, fmt_111, 0 };
00071 static cilist io___18 = { 0, 77, 0, fmt_111, 0 };
00072 static cilist io___19 = { 0, 6, 0, fmt_1019, 0 };
00073 static cilist io___20 = { 0, 6, 0, fmt_1029, 0 };
00074 static cilist io___21 = { 0, 6, 0, fmt_1031, 0 };
00075 static cilist io___22 = { 0, 5, 0, 0, 0 };
00076 static cilist io___24 = { 0, 6, 0, fmt_1002, 0 };
00077 static cilist io___25 = { 1, 5, 1, fmt_111, 0 };
00078 static cilist io___28 = { 0, 6, 0, fmt_1051, 0 };
00079 static cilist io___29 = { 1, 5, 1, fmt_111, 0 };
00080 static cilist io___32 = { 1, 77, 1, 0, 0 };
00081 static cilist io___35 = { 0, 6, 0, fmt_1201, 0 };
00082 static cilist io___36 = { 0, 78, 0, fmt_1201, 0 };
00083
00084
00085
00086
00087
00088
00089
00090 for (i__ = 1; i__ <= 26; ++i__) {
00091 r8val[i__ - 1] = 0.;
00092
00093 }
00094
00095 nout = 1;
00096 ncmax = 0;
00097 ialpha = 'A' - 1;
00098
00099
00100 L100:
00101 s_wsfe(&io___8);
00102 do_fio(&c__1, (char *)&nout, (ftnlen)sizeof(integer));
00103 e_wsfe();
00104 i__1 = s_rsfe(&io___9);
00105 if (i__1 != 0) {
00106 goto L1000;
00107 }
00108 i__1 = do_fio(&c__1, c_expr__, 666L);
00109 if (i__1 != 0) {
00110 goto L1000;
00111 }
00112 i__1 = e_rsfe();
00113 if (i__1 != 0) {
00114 goto L1000;
00115 }
00116 if (s_cmp(c_expr__, " ", 666L, 1L) == 0 || s_cmp(c_expr__, "end", 666L,
00117 3L) == 0 || s_cmp(c_expr__, "exit", 666L, 4L) == 0 || s_cmp(
00118 c_expr__, "quit", 666L, 4L) == 0) {
00119 goto L1000;
00120 }
00121
00122 parser_(c_expr__, &c_true, &num_code__[nout - 1], c_code__ + (nout * 200
00123 - 200 << 3), 666L, 8L);
00124
00125 if (num_code__[nout - 1] <= 0) {
00126 goto L100;
00127 }
00128
00129
00130
00131 i__1 = num_code__[nout - 1] - 1;
00132 for (i__ = 1; i__ <= i__1; ++i__) {
00133 if (s_cmp(c_code__ + (i__ + nout * 200 - 201 << 3), "PUSHSYM", 8L, 7L)
00134 == 0) {
00135
00136 i__2 = ncmax, i__3 = *(unsigned char *)&c_code__[(i__ + 1 + nout *
00137 200 - 201) * 8] - ialpha;
00138 ncmax = max(i__2,i__3);
00139 }
00140
00141 }
00142
00143 ++nout;
00144 if (nout <= 9) {
00145 goto L100;
00146 }
00147
00148
00149 L1000:
00150 --nout;
00151 if (nout <= 0) {
00152 s_wsfe(&io___13);
00153 e_wsfe();
00154 goto L9000;
00155 }
00156
00157 L1010:
00158 ncol = 0;
00159 s_wsfe(&io___15);
00160 do_fio(&c__1, "input", 5L);
00161 e_wsfe();
00162 i__1 = s_rsfe(&io___16);
00163 if (i__1 != 0) {
00164 goto L100001;
00165 }
00166 i__1 = do_fio(&c__1, c_expr__, 666L);
00167 if (i__1 != 0) {
00168 goto L100001;
00169 }
00170 i__1 = e_rsfe();
00171 L100001:
00172 if (i__1 < 0) {
00173 goto L9000;
00174 }
00175 if (i__1 > 0) {
00176 goto L1010;
00177 }
00178 if (*(unsigned char *)c_expr__ == ' ') {
00179 goto L1030;
00180 }
00181
00182 o__1.oerr = 1;
00183 o__1.ounit = 77;
00184 o__1.ofnmlen = 666;
00185 o__1.ofnm = c_expr__;
00186 o__1.orl = 0;
00187 o__1.osta = "OLD";
00188 o__1.oacc = 0;
00189 o__1.ofm = "FORMATTED";
00190 o__1.oblnk = 0;
00191 ierr = f_open(&o__1);
00192 if (ierr != 0) {
00193 goto L1010;
00194 }
00195
00196
00197
00198
00199 s_rsfe(&io___18);
00200 do_fio(&c__1, c_expr__, 666L);
00201 e_rsfe();
00202 al__1.aerr = 0;
00203 al__1.aunit = 77;
00204 f_rew(&al__1);
00205 ncol = inumc_(c_expr__, 666L);
00206
00207
00208 if (ncol <= 0) {
00209 s_wsfe(&io___19);
00210 e_wsfe();
00211 cl__1.cerr = 0;
00212 cl__1.cunit = 77;
00213 cl__1.csta = 0;
00214 f_clos(&cl__1);
00215 goto L1010;
00216 }
00217
00218 if (ncmax > ncol) {
00219 s_wsfe(&io___20);
00220 do_fio(&c__1, (char *)&ncmax, (ftnlen)sizeof(integer));
00221 do_fio(&c__1, (char *)&ncol, (ftnlen)sizeof(integer));
00222 e_wsfe();
00223 }
00224 ncol = min(ncol,ncmax);
00225
00226 L1030:
00227 if (ncol == 0) {
00228 s_wsfe(&io___21);
00229 e_wsfe();
00230 s_rsle(&io___22);
00231 do_lio(&c__3, &c__1, (char *)&nrow, (ftnlen)sizeof(integer));
00232 e_rsle();
00233 if (nrow <= 0) {
00234 goto L1030;
00235 }
00236 } else {
00237 nrow = 999999;
00238 }
00239
00240 s_wsfe(&io___24);
00241 do_fio(&c__1, "output", 6L);
00242 e_wsfe();
00243 i__1 = s_rsfe(&io___25);
00244 if (i__1 != 0) {
00245 goto L100002;
00246 }
00247 i__1 = do_fio(&c__1, c_expr__, 666L);
00248 if (i__1 != 0) {
00249 goto L100002;
00250 }
00251 i__1 = e_rsfe();
00252 L100002:
00253 if (i__1 < 0) {
00254 goto L9000;
00255 }
00256 if (i__1 > 0) {
00257 goto L1030;
00258 }
00259
00260 lstout = *(unsigned char *)c_expr__ == ' ';
00261
00262 if (! lstout) {
00263 o__1.oerr = 1;
00264 o__1.ounit = 78;
00265 o__1.ofnmlen = 666;
00266 o__1.ofnm = c_expr__;
00267 o__1.orl = 0;
00268 o__1.osta = "NEW";
00269 o__1.oacc = 0;
00270 o__1.ofm = "FORMATTED";
00271 o__1.oblnk = 0;
00272 ierr = f_open(&o__1);
00273 if (ierr != 0) {
00274 goto L1030;
00275 }
00276 }
00277
00278
00279 L1050:
00280 n_cstop__ = 0;
00281 s_wsfe(&io___28);
00282 e_wsfe();
00283 i__1 = s_rsfe(&io___29);
00284 if (i__1 != 0) {
00285 goto L1090;
00286 }
00287 i__1 = do_fio(&c__1, c_expr__, 666L);
00288 if (i__1 != 0) {
00289 goto L1090;
00290 }
00291 i__1 = e_rsfe();
00292 if (i__1 != 0) {
00293 goto L1090;
00294 }
00295 if (s_cmp(c_expr__, " ", 666L, 1L) == 0 || s_cmp(c_expr__, "1", 666L, 1L)
00296 == 0) {
00297 goto L1090;
00298 }
00299 parser_(c_expr__, &c_true, &n_cstop__, c_cstop__, 666L, 8L);
00300 if (n_cstop__ <= 0) {
00301 goto L1050;
00302 }
00303
00304
00305 L1090:
00306 irow = 0;
00307 L1100:
00308 ++irow;
00309 r8val[25] = (doublereal) irow;
00310 if (ncol > 0) {
00311 i__1 = s_rsle(&io___32);
00312 if (i__1 != 0) {
00313 goto L9000;
00314 }
00315 i__2 = ncol;
00316 for (i__ = 1; i__ <= i__2; ++i__) {
00317 i__1 = do_lio(&c__5, &c__1, (char *)&r8val[i__ - 1], (ftnlen)
00318 sizeof(doublereal));
00319 if (i__1 != 0) {
00320 goto L9000;
00321 }
00322 }
00323 i__1 = e_rsle();
00324 if (i__1 != 0) {
00325 goto L9000;
00326 }
00327 }
00328
00329 i__1 = nout;
00330 for (i__ = 1; i__ <= i__1; ++i__) {
00331 rout[i__ - 1] = pareval_(&num_code__[i__ - 1], c_code__ + (i__ * 200
00332 - 200 << 3), r8val, 8L);
00333
00334 }
00335 if (n_cstop__ > 0) {
00336 r_cstop__ = pareval_(&n_cstop__, c_cstop__, r8val, 8L);
00337 if (r_cstop__ < 0.) {
00338 goto L9000;
00339 }
00340 }
00341
00342 if (lstout) {
00343 s_wsfe(&io___35);
00344 i__1 = nout;
00345 for (i__ = 1; i__ <= i__1; ++i__) {
00346 do_fio(&c__1, (char *)&rout[i__ - 1], (ftnlen)sizeof(doublereal));
00347 }
00348 e_wsfe();
00349 } else {
00350 s_wsfe(&io___36);
00351 i__1 = nout;
00352 for (i__ = 1; i__ <= i__1; ++i__) {
00353 do_fio(&c__1, (char *)&rout[i__ - 1], (ftnlen)sizeof(doublereal));
00354 }
00355 e_wsfe();
00356 }
00357
00358 if (ncol > 0 || irow < nrow) {
00359 goto L1100;
00360 }
00361
00362
00363 L9000:
00364 return 0;
00365 }
00366
00367 #undef r8
00368 #undef c8
00369
00370
00371
00372
00373
00374 integer inumc_(char *cline, ftnlen cline_len)
00375 {
00376
00377 integer ret_val, i__1;
00378 doublereal d__1;
00379 icilist ici__1;
00380
00381
00382 integer s_rsli(icilist *), do_lio(integer *, integer *, char *, ftnlen),
00383 e_rsli(void);
00384
00385
00386 static integer ierr;
00387 static doublereal rval[26];
00388 static integer itry, i__;
00389
00390
00391
00392
00393
00394
00395
00396
00397
00398 for (itry = 1; itry <= 26; ++itry) {
00399 i__1 = itry;
00400 for (i__ = 1; i__ <= i__1; ++i__) {
00401 rval[i__ - 1] = -9.876543e26;
00402
00403 }
00404 ici__1.icierr = 1;
00405 ici__1.iciend = 1;
00406 ici__1.icirnum = 1;
00407 ici__1.icirlen = cline_len;
00408 ici__1.iciunit = cline;
00409 ici__1.icifmt = 0;
00410 ierr = s_rsli(&ici__1);
00411 if (ierr != 0) {
00412 goto L100003;
00413 }
00414 i__1 = itry;
00415 for (i__ = 1; i__ <= i__1; ++i__) {
00416 ierr = do_lio(&c__5, &c__1, (char *)&rval[i__ - 1], (ftnlen)
00417 sizeof(doublereal));
00418 if (ierr != 0) {
00419 goto L100003;
00420 }
00421 }
00422 ierr = e_rsli();
00423 L100003:
00424 if (ierr != 0) {
00425 goto L200;
00426 }
00427 if ((d__1 = rval[itry - 1] / -9.876543e26 - 1., abs(d__1)) <= 1e-11) {
00428 goto L200;
00429 }
00430
00431 }
00432 itry = 27;
00433
00434 L200:
00435 ret_val = itry - 1;
00436 return ret_val;
00437 }
00438
00439 int colcalc_ () { MAIN__ (); return 0; }