00001 /* parser.f -- translated by f2c (version 19961017).
00002    You must link the resulting object file with the libraries:
00003         -lf2c -lm   (in that order)
00004 */
00005 
00006 #include "f2c.h"
00007 
00008 /* Table of constant values */
00009 
00010 static integer c__3 = 3;
00011 static integer c__1 = 1;
00012 static doublereal c_b384 = 0.;
00013 static doublereal c_b398 = 1.;
00014 static doublereal c_b399 = 2.;
00015 static doublereal c_b400 = 3.;
00016 static doublereal c_b401 = 4.;
00017 static doublereal c_b402 = 5.;
00018 static doublereal c_b403 = 6.;
00019 static doublereal c_b404 = 7.;
00020 static doublereal c_b405 = 8.;
00021 static doublereal c_b406 = 9.;
00022 static doublereal c_b407 = 10.;
00023 static doublereal c_b408 = 11.;
00024 static doublereal c_b409 = 12.;
00025 
00026 /* Subroutine */ int parser_(char *c_expr__, logical *l_print__, integer *
00027         num_code__, char *c_code__, ftnlen c_expr_len, ftnlen c_code_len)
00028 {
00029     /* Initialized data */
00030 
00031     static integer n_funcargs__[99] = { 1,1,1,1,1,1,2,1,1,1,1,1,1,1,1,1,1,1,1,
00032             2,2,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,-1,-1,-1,2,1,1,1,-1,
00033             4,4,4,2,2,2,3,3,3,1,1,1,2,2,2,3,3,3,3,3,3,3,3,3,2,2,2,1,-1,-1,2,1,
00034             1,1,1,-1,1,-1,-1,-1,1,1,2,1,1,-1,-1,-1,2 };
00035 
00036     /* Format strings */
00037     static char fmt_9001[] = "(\002 PARSER error\002,i4,\002: \002,a/1x,a/80"
00038             "a1)";
00039 
00040     /* System generated locals */
00041     address a__1[3];
00042     integer i__1, i__2[3], i__3;
00043     static doublereal equiv_0[1];
00044 
00045     /* Builtin functions */
00046     /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen), s_cat(char *,
00047              char **, integer *, integer *, ftnlen);
00048     integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
00049 
00050     /* Local variables */
00051 #define r8_token__ (equiv_0)
00052     static integer narg, nlen, nerr, ipos, npos, nextcode, ncode;
00053     static char c_message__[30];
00054     static integer nfunc, nused;
00055     extern /* Subroutine */ int get_token__(char *, integer *, doublereal *, 
00056             integer *, ftnlen);
00057     static doublereal val_token__;
00058     extern integer last_nonblank__(char *, ftnlen);
00059     static integer nf, n_code__[2048], n_func__[40], ntoken;
00060     static char c_local__[10000];
00061     extern /* Subroutine */ int execute_(integer *, char *, ftnlen);
00062 #define c8_token__ ((char *)equiv_0)
00063     static char c_ch__[1];
00064 
00065     /* Fortran I/O blocks */
00066     static cilist io___22 = { 0, 6, 0, fmt_9001, 0 };
00067 
00068 
00069 
00070 /*  Parse the arithmetic expression in C_EXPR.  The code required to */
00071 /*  evaluate the expression is returned in the first NUM_CODE entries */
00072 /*  of the CHARACTER*8 array C_CODE. If NUM_CODE is returned as zero, */
00073 /*  an error occurred. On input, L_PRINT determines whether or not to */
00074 /*  print error messages. */
00075 
00076 /*  Modified 02/17/89 by RWCox from APEVAL subroutine in APFORT, for PC. 
00077 */
00078 /*  Modified 06/29/89 by RWCox for Sun Fortran. */
00079 /*  Modified 04/04/91 by RWCox to fix problem with -x**2 type operations. 
00080 */
00081 /*  Modified 11/20/96 by RWCox to try to control errors in evaluation. */
00082 /* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
00083  */
00084 
00085 
00086 /*  Compilation, evaluation, and function stacks. */
00087 
00088 
00089 
00090 /*  Random local stuff */
00091 
00092 
00093 
00094 
00095 /* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
00096  */
00097 
00098 /* -----------------------------------------------------------------------
00099  */
00100 /*  Include file for PARSER.  This file must be kept with PARSER.FOR. */
00101 /*  It defines some symbolic constants that PARSER and its subsidiary */
00102 /*  routines use. */
00103 /* .......................................................................
00104  */
00105 /* Define Token types and values */
00106 
00107 
00108 
00109 /* .......................................................................
00110  */
00111 /*  Define the Nonterminals */
00112 
00113 
00114 /* .......................................................................
00115  */
00116 /*  Define the Opcodes */
00117 
00118 
00119 /* .......................................................................
00120  */
00121 /*  Define Function names, etc. */
00122 
00123 
00124 
00125     /* Parameter adjustments */
00126     c_code__ -= 8;
00127 
00128     /* Function Body */
00129 
00130 /* -----------------------------------------------------------------------
00131  */
00132     nlen = last_nonblank__(c_expr__, c_expr_len);
00133     if (nlen <= 0 || nlen > 9999) {
00134 /* !no input, or too much */
00135         *num_code__ = 0;
00136         goto L8000;
00137     }
00138 
00139 /*  Copy input string to local, deleting blanks and converting case. */
00140 
00141     npos = 0;
00142     i__1 = nlen;
00143     for (ipos = 1; ipos <= i__1; ++ipos) {
00144         *(unsigned char *)c_ch__ = *(unsigned char *)&c_expr__[ipos - 1];
00145         if (*(unsigned char *)c_ch__ != ' ') {
00146             if (*(unsigned char *)c_ch__ >= 'a' && *(unsigned char *)c_ch__ <=
00147                      'z') {
00148                 *(unsigned char *)c_ch__ = (char) (*(unsigned char *)c_ch__ + 
00149                         ('A' - 'a'));
00150             }
00151 /* !convert case */
00152             ++npos;
00153             *(unsigned char *)&c_local__[npos - 1] = *(unsigned char *)c_ch__;
00154         }
00155 /* L10: */
00156     }
00157 /* !tack 1 blank at the end */
00158     nlen = npos + 1;
00159     *(unsigned char *)&c_local__[nlen - 1] = ' ';
00160 /* .......................................................................
00161  */
00162 /*  This routine parses expressions according to the grammar: */
00163 
00164 /*   EXPR  == E9 E8 E6 E4 $ */
00165 
00166 /*   E4    == <addop> E9 E8 E6 E4 | <null> */
00167 
00168 /*   E6    == <mulop> E9 E8 E6 | <null> */
00169 
00170 /*   E8    == <expop> E9 E8 | <null> */
00171 
00172 /*   E9    == <number> | <function> ( E9 E8 E6 E4 ARGTL ) */
00173 /*            | ( E9 E8 E6 E4 ) | <addop> E9 */
00174 
00175 /*   ARGTL == , E9 E8 E6 E4 ARGTL | <null> */
00176 
00177 /*   <addop>    is + or - */
00178 /*   <mulop>    is * or / */
00179 /*   <expop>    is ** */
00180 /*   <number>   is a literal number or a DCL variable */
00181 /*   <function> is in the list C_FUNCNAME */
00182 
00183 /*  The predictive parser described in Aho and Ullman, "Principles of */
00184 /*  Compiler Design" on pages 185-191 for LL(1) grammars is used here, */
00185 /*  with additions to perform the evaluation as the parsing proceeds. */
00186 /*  These consist of adding code (NC_) to the compilation stack when an */
00187 /*  expansion is made.  When the code is popped off the stack, it is */
00188 /*  executed. */
00189 
00190 /*  02/17/89:  Now, when code is popped off the stack, it is just */
00191 /*             added to the output code list. */
00192 /* .......................................................................
00193  */
00194 /*  Prepare to process input string.  Initialize the stacks, etc. */
00195 
00196 /* !start scan at 1st character */
00197     npos = 1;
00198 /* !no function calls yet */
00199     nfunc = 0;
00200 /* !initial compile stack is E9 E8 E6 E4 $ */
00201     n_code__[0] = 2000;
00202     n_code__[1] = 2001;
00203     n_code__[2] = 2002;
00204     n_code__[3] = 2003;
00205     n_code__[4] = 2004;
00206     ncode = 5;
00207     *num_code__ = 0;
00208 /* .......................................................................
00209  */
00210 /*  1000 is the loop back point to process the next token in the input */
00211 /*  string. */
00212 
00213 L1000:
00214     get_token__(c_local__ + (npos - 1), &ntoken, &val_token__, &nused, nlen - 
00215             (npos - 1));
00216 
00217     if (ntoken == 1999) {
00218         nerr = 1;
00219         s_copy(c_message__, "Can't interpret symbol", 30L, 22L);
00220         goto L9000;
00221 /* !error exit */
00222     }
00223 
00224 /*  At 2000, process the next compile code until the token is used up. */
00225 
00226 L2000:
00227     nextcode = n_code__[ncode - 1];
00228 
00229 /*  If next entry on the compile stack is an opcode, then apply it to */
00230 /*  the evaluation stack. */
00231 /*  02/17/89:  just add it to the output */
00232 
00233     if (nextcode >= 3000 && nextcode <= 4999) {
00234         ++(*num_code__);
00235         execute_(&nextcode, c_code__ + (*num_code__ << 3), 8L);
00236         --ncode;
00237 /* !remove opcode from compile stack */
00238         goto L2000;
00239 /* !loop back for next compile stack entry */
00240     }
00241 
00242 /*  If next compile stack entry is a token itself, it must match the */
00243 /*  new token from the input. */
00244 
00245     if (nextcode >= 1000 && nextcode <= 1999) {
00246         if (nextcode == ntoken) {
00247 /* !a match */
00248             --ncode;
00249 /* !pop token from compile stack */
00250             goto L5000;
00251 /* !loop back for next token */
00252         }
00253         nerr = 2;
00254         if (nextcode == 1004) {
00255             *(unsigned char *)c_ch__ = '(';
00256         } else if (nextcode == 1005) {
00257             *(unsigned char *)c_ch__ = ')';
00258         } else if (nextcode == 1006) {
00259             *(unsigned char *)c_ch__ = ',';
00260         } else {
00261             *(unsigned char *)c_ch__ = '?';
00262         }
00263 /* Writing concatenation */
00264         i__2[0] = 12, a__1[0] = "Expected a \"";
00265         i__2[1] = 1, a__1[1] = c_ch__;
00266         i__2[2] = 1, a__1[2] = "\"";
00267         s_cat(c_message__, a__1, i__2, &c__3, 30L);
00268         goto L9000;
00269 /* !error exit */
00270     }
00271 
00272 /*  Should have a nonterminal (NN) here. */
00273 
00274     if (nextcode < 2000 || nextcode > 2999) {
00275         nerr = 3;
00276         s_copy(c_message__, "Internal parser error", 30L, 21L);
00277         goto L9000;
00278 /* !error exit */
00279     }
00280 
00281 /*  Expand the nonterminal appropriately, depending on the token. */
00282 /*  If no legal expansion, then stop with an error. */
00283 
00284 /*  TOKEN = end of string */
00285 
00286     if (ntoken == 1000) {
00287         if (nextcode == 2000) {
00288 /* !end of string = end of expr ==> compilation done */
00289             goto L8000;
00290 
00291         } else if (nextcode == 2003 || nextcode == 2002 || nextcode == 2001) {
00292             --ncode;
00293 /* !expand this to nothing */
00294             goto L2000;
00295 /* !and try this token again */
00296         }
00297         nerr = 4;
00298         s_copy(c_message__, "Unexpected end of input", 30L, 23L);
00299         goto L9000;
00300 /* !error exit */
00301     }
00302 
00303 /*  Check if end of input was expected but not encountered. */
00304 
00305     if (nextcode == 2000) {
00306         nerr = 15;
00307         s_copy(c_message__, "Expected end of input", 30L, 21L);
00308         goto L9000;
00309 /* !error exit */
00310     }
00311 
00312 /*  TOKEN = number or symbol */
00313 /*  02/17/89:  added NT_SYMBOL token type;  now, the code for */
00314 /*             pushing the number or symbol onto the stack is */
00315 /*             added to the output. */
00316 
00317     if (ntoken == 1007 || ntoken == 1009) {
00318         if (nextcode == 2004) {
00319 /* !only legal time for a number */
00320             if (ntoken == 1007) {
00321                 s_copy(c_code__ + (*num_code__ + 1 << 3), "PUSHNUM", 8L, 7L);
00322             } else {
00323                 s_copy(c_code__ + (*num_code__ + 1 << 3), "PUSHSYM", 8L, 7L);
00324             }
00325             *r8_token__ = val_token__;
00326             s_copy(c_code__ + (*num_code__ + 2 << 3), c8_token__, 8L, 8L);
00327             *num_code__ += 2;
00328             --ncode;
00329 /* !pop E9 from compile stack */
00330             goto L5000;
00331 /* !go to next token */
00332         }
00333         nerr = 5;
00334         s_copy(c_message__, "Expected an operator", 30L, 20L);
00335         goto L9000;
00336 /* !error exit */
00337     }
00338 
00339 /*  TOKEN = function call */
00340 
00341     if (ntoken == 1008) {
00342         if (nextcode == 2004) {
00343 /* !only legal time for a function */
00344 
00345             n_code__[ncode + 6] = 1004;
00346 /* !expand E9 into ( E9 E8 E6 E4 ARGTL ) <func> */
00347             n_code__[ncode + 5] = 2004;
00348             n_code__[ncode + 4] = 2003;
00349             n_code__[ncode + 3] = 2002;
00350             n_code__[ncode + 2] = 2001;
00351             n_code__[ncode + 1] = 2005;
00352             n_code__[ncode] = 1005;
00353             n_code__[ncode - 1] = (integer) val_token__ + 4000;
00354             ncode += 7;
00355 
00356             nfunc += 2;
00357 /* !setup function stack to check # arguments */
00358             n_func__[nfunc - 2] = (integer) val_token__;
00359             n_func__[nfunc - 1] = 0;
00360             goto L5000;
00361 /* !process next token */
00362         }
00363         nerr = 6;
00364         s_copy(c_message__, "Expected an operator", 30L, 20L);
00365         goto L9000;
00366 /* !error exit */
00367     }
00368 
00369 /*  TOKEN = addition operator */
00370 
00371     if (ntoken == 1001) {
00372         if (nextcode == 2001) {
00373 /* !expand E4 into E9 E8 E6 <binary addop> E4 */
00374             n_code__[ncode + 3] = 2004;
00375             n_code__[ncode + 2] = 2003;
00376             n_code__[ncode + 1] = 2002;
00377             if (val_token__ == 1.) {
00378                 n_code__[ncode] = 3001;
00379             } else {
00380                 n_code__[ncode] = 3002;
00381             }
00382             n_code__[ncode - 1] = 2001;
00383             ncode += 4;
00384             goto L5000;
00385 /* !process next token */
00386 
00387         } else if (nextcode == 2002 || nextcode == 2003) {
00388             --ncode;
00389 /* !expand E6 or E8 to null and try again */
00390             goto L2000;
00391 
00392         } else if (nextcode == 2004) {
00393 /* !unary + or - */
00394             if (val_token__ == 2.) {
00395 /*!expand E9 into E9 E8 <unary minus> if addop is - otherwise 
00396 leave E9 alone*/
00397 /* [04/04/91 change: */
00398 /*  used to expand to E9 <unary minus>, which makes -x**2 beco
00399 me (-x)**2] */
00400                 n_code__[ncode + 1] = 2004;
00401                 n_code__[ncode] = 2003;
00402                 n_code__[ncode - 1] = 3006;
00403                 ncode += 2;
00404             }
00405             goto L5000;
00406 /* !process next token */
00407         }
00408         nerr = 7;
00409         s_copy(c_message__, "Illegal arithmetic syntax", 30L, 25L);
00410         goto L9000;
00411 /* !error exit */
00412     }
00413 
00414 /*  TOKEN = multiplying operator */
00415 
00416     if (ntoken == 1002) {
00417         if (nextcode == 2002) {
00418 /* !expand E6 into E9 E8 <operator> E6 */
00419             n_code__[ncode + 2] = 2004;
00420             n_code__[ncode + 1] = 2003;
00421             if (val_token__ == 1.) {
00422                 n_code__[ncode] = 3003;
00423             } else {
00424                 n_code__[ncode] = 3004;
00425             }
00426             n_code__[ncode - 1] = 2002;
00427             ncode += 3;
00428             goto L5000;
00429 /* !next token */
00430 
00431         } else if (nextcode == 2003) {
00432 /* !expand E8 to null and try this token again */
00433             --ncode;
00434             goto L2000;
00435         }
00436         nerr = 8;
00437         s_copy(c_message__, "Illegal arithmetic syntax", 30L, 25L);
00438         goto L9000;
00439 /* !error exit */
00440     }
00441 
00442 /*  TOKEN = exponentiation operator */
00443 
00444     if (ntoken == 1003) {
00445         if (nextcode == 2003) {
00446 /* !expand E8 into E9 E8 <**> */
00447             n_code__[ncode + 1] = 2004;
00448             n_code__[ncode] = 2003;
00449             n_code__[ncode - 1] = 3005;
00450             ncode += 2;
00451             goto L5000;
00452 /* !process next token */
00453         }
00454         nerr = 9;
00455         s_copy(c_message__, "Illegal arithmetic syntax", 30L, 25L);
00456         goto L9000;
00457 /* !error exit */
00458     }
00459 
00460 /*  TOKEN = comma */
00461 
00462     if (ntoken == 1006) {
00463         if (nextcode == 2001 || nextcode == 2002 || nextcode == 2003) {
00464 
00465             --ncode;
00466 /* !pop this nonterminal and try this token again */
00467             goto L2000;
00468 
00469         } else if (nextcode == 2005) {
00470 /* !expand ARGTL into E9 E8 E6 E4 ARGTL */
00471             n_code__[ncode + 3] = 2004;
00472             n_code__[ncode + 2] = 2003;
00473             n_code__[ncode + 1] = 2002;
00474             n_code__[ncode] = 2001;
00475             n_code__[ncode - 1] = 2005;
00476             ncode += 4;
00477 /* !add 1 to no. of args. encountered, and check if there are too 
00478 many */
00479             ++n_func__[nfunc - 1];
00480             nf = n_func__[nfunc - 2];
00481             if (n_funcargs__[nf - 1] <= n_func__[nfunc - 1] && n_funcargs__[
00482                     nf - 1] > 0) {
00483                 nerr = 12;
00484                 s_copy(c_message__, "Wrong number of arguments", 30L, 25L);
00485                 goto L9000;
00486 /* !error exit */
00487             }
00488             goto L5000;
00489 /* !process next token */
00490         }
00491         nerr = 10;
00492         s_copy(c_message__, "Expected an expression", 30L, 22L);
00493         goto L9000;
00494 /* !error exit */
00495     }
00496 
00497 /*  TOKEN = open parenthesis */
00498 
00499     if (ntoken == 1004) {
00500         if (nextcode == 2004) {
00501 /* !expand E9 into E9 E8 E6 E4 ) */
00502             n_code__[ncode + 3] = 2004;
00503             n_code__[ncode + 2] = 2003;
00504             n_code__[ncode + 1] = 2002;
00505             n_code__[ncode] = 2001;
00506             n_code__[ncode - 1] = 1005;
00507             ncode += 4;
00508             goto L5000;
00509 /* !process next token */
00510         }
00511         nerr = 11;
00512         s_copy(c_message__, "Expected an operator", 30L, 20L);
00513         goto L9000;
00514 /* !error exit */
00515     }
00516 
00517 /*  TOKEN = close parenthesis */
00518 
00519     if (ntoken == 1005) {
00520         if (nextcode == 2001 || nextcode == 2002 || nextcode == 2003) {
00521 
00522             --ncode;
00523 /* !pop this nonterminal and try this token out on the next one */
00524             goto L2000;
00525 
00526         } else if (nextcode == 2005) {
00527 /* !end of function call */
00528 
00529             narg = n_func__[nfunc - 1] + 1;
00530 /* !check # arguments */
00531             nf = n_func__[nfunc - 2];
00532             nfunc += -2;
00533             if (n_funcargs__[nf - 1] <= 0) {
00534 /* !variable # of args ==> push number of args on stack (Feb 1
00535 997) */
00536                 s_copy(c_code__ + (*num_code__ + 1 << 3), "PUSHNUM", 8L, 7L);
00537                 *r8_token__ = (doublereal) narg;
00538                 s_copy(c_code__ + (*num_code__ + 2 << 3), c8_token__, 8L, 8L);
00539                 *num_code__ += 2;
00540             } else if (n_funcargs__[nf - 1] != narg) {
00541 /* !illegal # of args */
00542                 nerr = 12;
00543                 s_copy(c_message__, "Wrong number of arguments", 30L, 25L);
00544                 goto L9000;
00545 /* !error exit */
00546             }
00547 
00548             --ncode;
00549 /*!pop this nonterminal and try to match the ) with the next compi
00550 le stack entry*/
00551             goto L2000;
00552         }
00553         nerr = 13;
00554         s_copy(c_message__, "Expected an expression", 30L, 22L);
00555         goto L9000;
00556 /* !error exit */
00557     }
00558     nerr = 14;
00559     s_copy(c_message__, "Internal parser error", 30L, 21L);
00560     goto L9000;
00561 /* !error exit */
00562 /* .......................................................................
00563  */
00564 /*  At 5000, advance to the next token and loop back */
00565 
00566 L5000:
00567     npos += nused;
00568     goto L1000;
00569 /* .......................................................................
00570  */
00571 /*  At 8000, exit */
00572 
00573 L8000:
00574     return 0;
00575 /* .......................................................................
00576  */
00577 /*  At 9000, error exit */
00578 
00579 L9000:
00580     if (*l_print__) {
00581         if (nused < 1) {
00582             nused = 1;
00583         }
00584         s_wsfe(&io___22);
00585         do_fio(&c__1, (char *)&nerr, (ftnlen)sizeof(integer));
00586         do_fio(&c__1, c_message__, 30L);
00587         do_fio(&c__1, c_local__, nlen);
00588         i__1 = npos;
00589         for (nf = 1; nf <= i__1; ++nf) {
00590             do_fio(&c__1, " ", 1L);
00591         }
00592         i__3 = nused;
00593         for (nf = 1; nf <= i__3; ++nf) {
00594             do_fio(&c__1, "#", 1L);
00595         }
00596         e_wsfe();
00597 
00598 /* CC         WRITE(*,9002) (N_CODE(NF),NF=NCODE,1,-1) */
00599 /* CC9002     FORMAT(' Compile stack is (top down)' / 10(1X,I6) ) */
00600     }
00601 
00602     *num_code__ = 0;
00603     return 0;
00604 } /* parser_ */
00605 
00606 #undef c8_token__
00607 #undef r8_token__
00608 
00609 
00610 
00611 
00612 
00613 /* Subroutine */ int execute_(integer *n_opcode__, char *c_code__, ftnlen 
00614         c_code_len)
00615 {
00616     /* Initialized data */
00617 
00618     static char c_funcname__[32*100] = "SIN                             " 
00619             "COS                             " "TAN                         "
00620             "    " "ASIN                            " "ACOS                  "
00621             "          " "ATAN                            " "ATAN2           "
00622             "                " "SINH                            " "COSH      "
00623             "                      " "TANH                            " "ASIN"
00624             "H                           " "ACOSH                           " 
00625             "ATANH                           " "EXP                         "
00626             "    " "LOG                             " "LOG10                 "
00627             "          " "ABS                             " "INT             "
00628             "                " "SQRT                            " "MAX       "
00629             "                      " "MIN                             " "AI  "
00630             "                            " "DAI                             " 
00631             "I0                              " "I1                          "
00632             "    " "J0                              " "J1                    "
00633             "          " "K0                              " "K1              "
00634             "                " "Y0                              " "Y1        "
00635             "                      " "BI                              " "DBI "
00636             "                            " "ERF                             " 
00637             "ERFC                            " "GAMMA                       "
00638             "    " "QG                              " "QGINV                 "
00639             "          " "BELL2                           " "RECT            "
00640             "                " "STEP                            " "BOOL      "
00641             "                      " "AND                             " "OR  "
00642             "                            " "MOFN                            " 
00643             "ASTEP                           " "SIND                        "
00644             "    " "COSD                            " "TAND                  "
00645             "          " "MEDIAN                          " "FICO_T2P        "
00646             "                " "FICO_P2T                        " "FICO_T2Z  "
00647             "                      " "FITT_T2P                        " "FITT"
00648             "_P2T                        " "FITT_T2Z                        " 
00649             "FIFT_T2P                        " "FIFT_P2T                    "
00650             "    " "FIFT_T2Z                        " "FIZT_T2P              "
00651             "          " "FIZT_P2T                        " "FIZT_T2Z        "
00652             "                " "FICT_T2P                        " "FICT_P2T  "
00653             "                      " "FICT_T2Z                        " "FIBT"
00654             "_T2P                        " "FIBT_P2T                        " 
00655             "FIBT_T2Z                        " "FIBN_T2P                    "
00656             "    " "FIBN_P2T                        " "FIBN_T2Z              "
00657             "          " "FIGT_T2P                        " "FIGT_P2T        "
00658             "                " "FIGT_T2Z                        " "FIPT_T2P  "
00659             "                      " "FIPT_P2T                        " "FIPT"
00660             "_T2Z                        " "ZTONE                           " 
00661             "LMODE                           " "HMODE                       "
00662             "    " "GRAN                            " "URAN                  "
00663             "          " "IRAN                            " "ERAN            "
00664             "                " "LRAN                            " "ORSTAT    "
00665             "                      " "TENT                            " "MAD "
00666             "                            " "ARGMAX                          " 
00667             "ARGNUM                          " "NOTZERO                     "
00668             "    " "ISZERO                          " "EQUALS                "
00669             "          " "ISPOSITIVE                      " "ISNEGATIVE      "
00670             "                " "MEAN                            " "STDEV     "
00671             "                      " "SEM                             " "PLEG"
00672             "                            " "DUMMY                           ";
00673 
00674     /* Builtin functions */
00675     /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
00676 
00677 
00678 /*  Execute the opcode on the evaluation stack.  Note that no attempt is 
00679 */
00680 /*  made to intercept errors, such as divide by zero, ACOS(2), etc. */
00681 
00682 
00683 /* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
00684  */
00685 
00686 /*  Branch to special code for function evaluations */
00687 
00688 /* -----------------------------------------------------------------------
00689  */
00690 /*  Include file for PARSER.  This file must be kept with PARSER.FOR. */
00691 /*  It defines some symbolic constants that PARSER and its subsidiary */
00692 /*  routines use. */
00693 /* .......................................................................
00694  */
00695 /* Define Token types and values */
00696 
00697 
00698 
00699 /* .......................................................................
00700  */
00701 /*  Define the Nonterminals */
00702 
00703 
00704 /* .......................................................................
00705  */
00706 /*  Define the Opcodes */
00707 
00708 
00709 /* .......................................................................
00710  */
00711 /*  Define Function names, etc. */
00712 
00713 
00714 
00715 
00716 /* -----------------------------------------------------------------------
00717  */
00718     if (*n_opcode__ >= 4000) {
00719         goto L5000;
00720     }
00721 /* .......................................................................
00722  */
00723     if (*n_opcode__ == 3006) {
00724 /* !unary minus, the only unary op. */
00725         s_copy(c_code__, "--", 8L, 2L);
00726 
00727     } else {
00728 /* !a binary operation */
00729         if (*n_opcode__ == 3001) {
00730 /* !add */
00731             s_copy(c_code__, "+", 8L, 1L);
00732         } else if (*n_opcode__ == 3002) {
00733 /* !subtract */
00734             s_copy(c_code__, "-", 8L, 1L);
00735         } else if (*n_opcode__ == 3003) {
00736 /* !multiply */
00737             s_copy(c_code__, "*", 8L, 1L);
00738         } else if (*n_opcode__ == 3004) {
00739 /* !divide */
00740             s_copy(c_code__, "/", 8L, 1L);
00741         } else if (*n_opcode__ == 3005) {
00742 /* !** */
00743             s_copy(c_code__, "**", 8L, 2L);
00744         }
00745     }
00746     goto L8000;
00747 /* .......................................................................
00748  */
00749 /*  Function evaluation */
00750 
00751 L5000:
00752     s_copy(c_code__, c_funcname__ + (*n_opcode__ - 4001 << 5), 8L, 32L);
00753 /* .......................................................................
00754  */
00755 L8000:
00756     return 0;
00757 } /* execute_ */
00758 
00759 
00760 
00761 
00762 /* Subroutine */ int get_token__(char *c_input__, integer *ntype, doublereal *
00763         value, integer *nused, ftnlen c_input_len)
00764 {
00765     /* Initialized data */
00766 
00767     static char c_funcname__[32*100] = "SIN                             " 
00768             "COS                             " "TAN                         "
00769             "    " "ASIN                            " "ACOS                  "
00770             "          " "ATAN                            " "ATAN2           "
00771             "                " "SINH                            " "COSH      "
00772             "                      " "TANH                            " "ASIN"
00773             "H                           " "ACOSH                           " 
00774             "ATANH                           " "EXP                         "
00775             "    " "LOG                             " "LOG10                 "
00776             "          " "ABS                             " "INT             "
00777             "                " "SQRT                            " "MAX       "
00778             "                      " "MIN                             " "AI  "
00779             "                            " "DAI                             " 
00780             "I0                              " "I1                          "
00781             "    " "J0                              " "J1                    "
00782             "          " "K0                              " "K1              "
00783             "                " "Y0                              " "Y1        "
00784             "                      " "BI                              " "DBI "
00785             "                            " "ERF                             " 
00786             "ERFC                            " "GAMMA                       "
00787             "    " "QG                              " "QGINV                 "
00788             "          " "BELL2                           " "RECT            "
00789             "                " "STEP                            " "BOOL      "
00790             "                      " "AND                             " "OR  "
00791             "                            " "MOFN                            " 
00792             "ASTEP                           " "SIND                        "
00793             "    " "COSD                            " "TAND                  "
00794             "          " "MEDIAN                          " "FICO_T2P        "
00795             "                " "FICO_P2T                        " "FICO_T2Z  "
00796             "                      " "FITT_T2P                        " "FITT"
00797             "_P2T                        " "FITT_T2Z                        " 
00798             "FIFT_T2P                        " "FIFT_P2T                    "
00799             "    " "FIFT_T2Z                        " "FIZT_T2P              "
00800             "          " "FIZT_P2T                        " "FIZT_T2Z        "
00801             "                " "FICT_T2P                        " "FICT_P2T  "
00802             "                      " "FICT_T2Z                        " "FIBT"
00803             "_T2P                        " "FIBT_P2T                        " 
00804             "FIBT_T2Z                        " "FIBN_T2P                    "
00805             "    " "FIBN_P2T                        " "FIBN_T2Z              "
00806             "          " "FIGT_T2P                        " "FIGT_P2T        "
00807             "                " "FIGT_T2Z                        " "FIPT_T2P  "
00808             "                      " "FIPT_P2T                        " "FIPT"
00809             "_T2Z                        " "ZTONE                           " 
00810             "LMODE                           " "HMODE                       "
00811             "    " "GRAN                            " "URAN                  "
00812             "          " "IRAN                            " "ERAN            "
00813             "                " "LRAN                            " "ORSTAT    "
00814             "                      " "TENT                            " "MAD "
00815             "                            " "ARGMAX                          " 
00816             "ARGNUM                          " "NOTZERO                     "
00817             "    " "ISZERO                          " "EQUALS                "
00818             "          " "ISPOSITIVE                      " "ISNEGATIVE      "
00819             "                " "MEAN                            " "STDEV     "
00820             "                      " "SEM                             " "PLEG"
00821             "                            " "DUMMY                           ";
00822 
00823     /* Format strings */
00824     static char fmt_5501[] = "(\002(F\002,i1,\002.0)\002)";
00825     static char fmt_5502[] = "(\002(F\002,i2,\002.0)\002)";
00826 
00827     /* System generated locals */
00828     char ch__1[1];
00829     icilist ici__1;
00830     static doublereal equiv_0[1];
00831 
00832     /* Builtin functions */
00833     integer i_len(char *, ftnlen), s_cmp(char *, char *, ftnlen, ftnlen);
00834     /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
00835     integer s_wsfi(icilist *), do_fio(integer *, char *, ftnlen), e_wsfi(void)
00836             , s_rsfi(icilist *), e_rsfi(void);
00837 
00838     /* Local variables */
00839     static integer nlen, ipos, npos;
00840     static char c_val__[32];
00841     static integer ifunc;
00842 #define c8_val__ ((char *)equiv_0)
00843 #define r8_val__ (equiv_0)
00844     static integer io_code__;
00845     static char c_first__[1], c_id__[32];
00846 
00847     /* Fortran I/O blocks */
00848     static icilist io___36 = { 0, c_val__, 0, fmt_5501, 32, 1 };
00849     static icilist io___37 = { 0, c_val__, 0, fmt_5502, 32, 1 };
00850 
00851 
00852 
00853 /*  Return the 1st token in the input stream. */
00854 
00855 
00856 
00857 
00858 /* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
00859  */
00860 /*  Statement function definitions */
00861 
00862 /* -----------------------------------------------------------------------
00863  */
00864 /*  Include file for PARSER.  This file must be kept with PARSER.FOR. */
00865 /*  It defines some symbolic constants that PARSER and its subsidiary */
00866 /*  routines use. */
00867 /* .......................................................................
00868  */
00869 /* Define Token types and values */
00870 
00871 
00872 
00873 /* .......................................................................
00874  */
00875 /*  Define the Nonterminals */
00876 
00877 
00878 /* .......................................................................
00879  */
00880 /*  Define the Opcodes */
00881 
00882 
00883 /* .......................................................................
00884  */
00885 /*  Define Function names, etc. */
00886 
00887 
00888 
00889 
00890 /* -----------------------------------------------------------------------
00891  */
00892 
00893 
00894 /* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
00895  */
00896 
00897     *ntype = 1000;
00898     *nused = 0;
00899     nlen = i_len(c_input__, c_input_len);
00900     if (nlen <= 0) {
00901         goto L8000;
00902     }
00903 
00904 /*  Process the simple cases 1st */
00905 
00906     *(unsigned char *)c_first__ = *(unsigned char *)c_input__;
00907 
00908     if (*(unsigned char *)c_first__ == ' ') {
00909         goto L8000;
00910     }
00911 
00912     *nused = 1;
00913     if (*(unsigned char *)c_first__ == '+') {
00914         *ntype = 1001;
00915         *value = 1.;
00916     } else if (*(unsigned char *)c_first__ == '-') {
00917         *ntype = 1001;
00918         *value = 2.;
00919     } else if (*(unsigned char *)c_first__ == '/') {
00920         *ntype = 1002;
00921         *value = 2.;
00922     } else if (*(unsigned char *)c_first__ == '*') {
00923         if (s_cmp(c_input__, "**", 2L, 2L) == 0) {
00924             *ntype = 1003;
00925             *value = 1.;
00926             *nused = 2;
00927         } else {
00928             *ntype = 1002;
00929             *value = 1.;
00930         }
00931     } else if (*(unsigned char *)c_first__ == '^') {
00932         *ntype = 1003;
00933         *value = 1.;
00934     } else if (*(unsigned char *)c_first__ == '(') {
00935         *ntype = 1004;
00936     } else if (*(unsigned char *)c_first__ == ')') {
00937         *ntype = 1005;
00938     } else if (*(unsigned char *)c_first__ == ',') {
00939         *ntype = 1006;
00940     }
00941 
00942     if (*ntype != 1000) {
00943         goto L8000;
00944     }
00945 /* !exit if above was successful */
00946 /* .......................................................................
00947  */
00948 /*  The only possibilities left are a variable name, a function name, */
00949 /*  or a number. */
00950 
00951     *(unsigned char *)&ch__1[0] = *(unsigned char *)c_first__;
00952     if (*(unsigned char *)&ch__1[0] >= 'A' && *(unsigned char *)&ch__1[0] <= 
00953             'Z') {
00954 /* !a name */
00955 
00956         npos = 2;
00957 L110:
00958         *(unsigned char *)&ch__1[0] = *(unsigned char *)&c_input__[npos - 1];
00959         if (! (*(unsigned char *)&ch__1[0] >= 'A' && *(unsigned char *)&ch__1[
00960                 0] <= 'Z' || *(unsigned char *)&ch__1[0] >= '0' && *(unsigned 
00961                 char *)&ch__1[0] <= '9' || *(unsigned char *)&ch__1[0] == '_' 
00962                 || *(unsigned char *)&ch__1[0] == '$')) {
00963             goto L120;
00964         }
00965         ++npos;
00966         goto L110;
00967 L120:
00968         --npos;
00969         s_copy(c_id__, c_input__, 32L, npos);
00970 
00971 /*  The name is now in C_ID.  Check to see if it is a function name. 
00972 */
00973 
00974         ifunc = 1;
00975         s_copy(c_funcname__ + 3168, c_id__, 32L, 32L);
00976 L210:
00977         if (! (s_cmp(c_id__, c_funcname__ + (ifunc - 1 << 5), 32L, 32L) != 0))
00978                  {
00979             goto L220;
00980         }
00981         ++ifunc;
00982         goto L210;
00983 L220:
00984         if (ifunc <= 99) {
00985 /* !it is a function */
00986             *ntype = 1008;
00987             *value = (doublereal) ifunc;
00988             *nused = npos;
00989         } else if (s_cmp(c_id__, "PI", npos, 2L) == 0) {
00990 /* !symbolic pi */
00991             *ntype = 1007;
00992             *value = 3.1415926535897932;
00993             *nused = npos;
00994         } else {
00995 /* !must be a symbol */
00996             *ntype = 1009;
00997             s_copy(c8_val__, c_id__, 8L, npos);
00998             *value = *r8_val__;
00999             *nused = npos;
01000         }
01001 /* ...................................................................
01002 .... */
01003 /*  try for a number */
01004 
01005     } else /* if(complicated condition) */ {
01006         *(unsigned char *)&ch__1[0] = *(unsigned char *)c_first__;
01007         if (*(unsigned char *)&ch__1[0] >= '0' && *(unsigned char *)&ch__1[0] 
01008                 <= '9' || *(unsigned char *)c_first__ == '.') {
01009             npos = 2;
01010 L310:
01011             *(unsigned char *)&ch__1[0] = *(unsigned char *)&c_input__[npos - 
01012                     1];
01013             if (! (*(unsigned char *)&ch__1[0] >= '0' && *(unsigned char *)&
01014                     ch__1[0] <= '9')) {
01015                 goto L320;
01016             }
01017 /* !skip digits */
01018             ++npos;
01019             goto L310;
01020 L320:
01021             if (*(unsigned char *)c_first__ != '.' && *(unsigned char *)&
01022                     c_input__[npos - 1] == '.') {
01023                 ++npos;
01024 L410:
01025                 *(unsigned char *)&ch__1[0] = *(unsigned char *)&c_input__[
01026                         npos - 1];
01027                 if (! (*(unsigned char *)&ch__1[0] >= '0' && *(unsigned char *
01028                         )&ch__1[0] <= '9')) {
01029                     goto L420;
01030                 }
01031 /* !skip digits after decimal pt */
01032                 ++npos;
01033                 goto L410;
01034 L420:
01035                 ;
01036             }
01037 /* !allow for exponent */
01038             if (*(unsigned char *)&c_input__[npos - 1] == 'E' || *(unsigned 
01039                     char *)&c_input__[npos - 1] == 'D') {
01040                 ipos = npos + 1;
01041                 if (*(unsigned char *)&c_input__[ipos - 1] == '+' || *(
01042                         unsigned char *)&c_input__[ipos - 1] == '-') {
01043                     ++ipos;
01044                 }
01045                 *(unsigned char *)&ch__1[0] = *(unsigned char *)&c_input__[
01046                         ipos - 1];
01047                 if (*(unsigned char *)&ch__1[0] >= '0' && *(unsigned char *)&
01048                         ch__1[0] <= '9') {
01049 /* !only if a digit follows the E can it be legal */
01050                     npos = ipos;
01051 L510:
01052                     *(unsigned char *)&ch__1[0] = *(unsigned char *)&
01053                             c_input__[npos - 1];
01054                     if (! (*(unsigned char *)&ch__1[0] >= '0' && *(unsigned 
01055                             char *)&ch__1[0] <= '9')) {
01056                         goto L520;
01057                     }
01058                     ++npos;
01059                     goto L510;
01060 L520:
01061                     ;
01062                 }
01063             }
01064             --npos;
01065 /* !number runs from position 1 to NPOS */
01066             *nused = npos;
01067             if (npos <= 9) {
01068                 s_wsfi(&io___36);
01069                 do_fio(&c__1, (char *)&npos, (ftnlen)sizeof(integer));
01070                 e_wsfi();
01071             } else {
01072                 s_wsfi(&io___37);
01073                 do_fio(&c__1, (char *)&npos, (ftnlen)sizeof(integer));
01074                 e_wsfi();
01075             }
01076             ici__1.icierr = 1;
01077             ici__1.iciend = 1;
01078             ici__1.icirnum = 1;
01079             ici__1.icirlen = npos;
01080             ici__1.iciunit = c_input__;
01081             ici__1.icifmt = c_val__;
01082             io_code__ = s_rsfi(&ici__1);
01083             if (io_code__ != 0) {
01084                 goto L100001;
01085             }
01086             io_code__ = do_fio(&c__1, (char *)&(*value), (ftnlen)sizeof(
01087                     doublereal));
01088             if (io_code__ != 0) {
01089                 goto L100001;
01090             }
01091             io_code__ = e_rsfi();
01092 L100001:
01093 
01094 /* CC         WRITE(*,5509) C_INPUT(1:NPOS) , C_VAL , VALUE */
01095 /* CC5509     FORMAT( */
01096 /* CC     X     ' scanned text ',A/ */
01097 /* CC     X     ' using format ',A/ */
01098 /* CC     X     ' giving VALUE ',1PG14.7) */
01099 
01100             if (io_code__ == 0) {
01101                 *ntype = 1007;
01102             } else {
01103                 *ntype = 1999;
01104             }
01105 /* ...............................................................
01106 ........ */
01107 /*  If not a number, an error! */
01108 
01109         } else {
01110             *ntype = 1999;
01111             *nused = 1;
01112         }
01113     }
01114 /* .......................................................................
01115  */
01116 L8000:
01117     return 0;
01118 } /* get_token__ */
01119 
01120 #undef r8_val__
01121 #undef c8_val__
01122 
01123 
01124 
01125 
01126 
01127 /* (((.................................................................... */
01128 integer last_nonblank__(char *cline, ftnlen cline_len)
01129 {
01130     /* System generated locals */
01131     integer ret_val;
01132 
01133     /* Builtin functions */
01134     integer i_len(char *, ftnlen);
01135 
01136     /* Local variables */
01137     static integer npos;
01138 
01139 
01140 /*  Return the position of the last nonblank character in the input */
01141 /*  character string.  CLINE is CHARACTER*(*).  Even if CLINE is all */
01142 /*  blanks, LAST_NONBLANK will be returned as 1 so that operations of the 
01143 */
01144 /*  form CLINE(1:LAST_NONBLANK) won't be garbage. */
01145 /* )))....................................................................
01146  */
01147 
01148 /* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
01149  */
01150 
01151 /*  Start at the end and work backwards until a nonblank is found. */
01152 /*  Loop back to 100 to check position # NPOS each time. */
01153 
01154     npos = i_len(cline, cline_len);
01155 L100:
01156 /*  quit if at the beginning */
01157     if (npos <= 1) {
01158         goto L200;
01159     }
01160 /*  quit if not a blank or a null */
01161     if (*(unsigned char *)&cline[npos - 1] != ' ' && *(unsigned char *)&cline[
01162             npos - 1] != '\0') {
01163         goto L200;
01164     }
01165 /*  move back one position and try again */
01166     --npos;
01167     goto L100;
01168 /* .......................................................................
01169  */
01170 L200:
01171     ret_val = npos;
01172     return ret_val;
01173 } /* last_nonblank__ */
01174 
01175 
01176 
01177 
01178 integer hassym_(char *sym, integer *num_code__, char *c_code__, ftnlen 
01179         sym_len, ftnlen c_code_len)
01180 {
01181     /* System generated locals */
01182     integer ret_val, i__1;
01183 
01184     /* Builtin functions */
01185     integer s_cmp(char *, char *, ftnlen, ftnlen);
01186 
01187     /* Local variables */
01188     static integer ncode;
01189     static char sss[1];
01190 
01191 
01192 
01193 /* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
01194  */
01195 
01196     /* Parameter adjustments */
01197     c_code__ -= 8;
01198 
01199     /* Function Body */
01200     ret_val = 0;
01201     if (*num_code__ <= 0) {
01202         return ret_val;
01203     }
01204     *(unsigned char *)sss = *(unsigned char *)sym;
01205 
01206     i__1 = *num_code__;
01207     for (ncode = 1; ncode <= i__1; ++ncode) {
01208         if (s_cmp(c_code__ + (ncode << 3), "PUSHSYM", 8L, 7L) == 0) {
01209             if (*(unsigned char *)&c_code__[(ncode + 1) * 8] == *(unsigned 
01210                     char *)sss) {
01211                 ret_val = 1;
01212                 return ret_val;
01213             }
01214         }
01215 /* L1000: */
01216     }
01217 
01218     return ret_val;
01219 } /* hassym_ */
01220 
01221 
01222 
01223 
01224 doublereal pareval_(integer *num_code__, char *c_code__, doublereal *r8val, 
01225         ftnlen c_code_len)
01226 {
01227     /* System generated locals */
01228     doublereal ret_val, d__1, d__2;
01229     static doublereal equiv_0[1];
01230 
01231     /* Builtin functions */
01232     /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
01233     integer s_cmp(char *, char *, ftnlen, ftnlen);
01234     double d_int(doublereal *), pow_dd(doublereal *, doublereal *), sin(
01235             doublereal), cos(doublereal), tan(doublereal), sqrt(doublereal), 
01236             exp(doublereal), log(doublereal), d_lg10(doublereal *), asin(
01237             doublereal), acos(doublereal), atan(doublereal), atan2(doublereal,
01238              doublereal), sinh(doublereal), cosh(doublereal), tanh(doublereal)
01239             ;
01240 
01241     /* Local variables */
01242     extern doublereal land_(integer *, doublereal *), mean_(integer *, 
01243             doublereal *), derf_(doublereal *), eran_(doublereal *), gran_(
01244             doublereal *, doublereal *), iran_(doublereal *), bool_(
01245             doublereal *), lran_(doublereal *), rect_(doublereal *), 
01246             legendre_(doublereal *, doublereal *), uran_(doublereal *), tent_(
01247             doublereal *), step_(doublereal *), bell2_(doublereal *), derfc_(
01248             doublereal *);
01249     static integer ncode;
01250     static doublereal x, y;
01251     extern doublereal hmode_(integer *, doublereal *), lmode_(integer *, 
01252             doublereal *);
01253     static integer neval;
01254     extern doublereal lmofn_(integer *, integer *, doublereal *), qginv_(
01255             doublereal *), stdev_(integer *, doublereal *), ztone_(doublereal 
01256             *), dbesi0_(doublereal *), dbesi1_(doublereal *), dbesj0_(
01257             doublereal *), dbesj1_(doublereal *), dbesk0_(doublereal *), 
01258             dbesk1_(doublereal *);
01259 #define c8_val__ ((char *)equiv_0)
01260     extern doublereal dbesy0_(doublereal *), dbesy1_(doublereal *);
01261 #define r8_val__ (equiv_0)
01262     extern doublereal dgamma_(doublereal *), qg_(doublereal *);
01263     static char cncode[8];
01264     extern doublereal median_(integer *, doublereal *);
01265     static integer ialpha;
01266     extern doublereal argmax_(integer *, doublereal *), fibntp_(doublereal *, 
01267             doublereal *, doublereal *), fibnpt_(doublereal *, doublereal *, 
01268             doublereal *), ficotp_(doublereal *, doublereal *, doublereal *, 
01269             doublereal *), ficopt_(doublereal *, doublereal *, doublereal *, 
01270             doublereal *), fibttp_(doublereal *, doublereal *, doublereal *), 
01271             argnum_(integer *, doublereal *), ficttp_(doublereal *, 
01272             doublereal *), fictpt_(doublereal *, doublereal *), fifttp_(
01273             doublereal *, doublereal *, doublereal *), fiftpt_(doublereal *, 
01274             doublereal *, doublereal *), ficotz_(doublereal *, doublereal *, 
01275             doublereal *, doublereal *), fibtpt_(doublereal *, doublereal *, 
01276             doublereal *), fibntz_(doublereal *, doublereal *, doublereal *), 
01277             figttp_(doublereal *, doublereal *, doublereal *), fibttz_(
01278             doublereal *, doublereal *, doublereal *), ficttz_(doublereal *, 
01279             doublereal *), figtpt_(doublereal *, doublereal *, doublereal *), 
01280             fifttz_(doublereal *, doublereal *, doublereal *), figttz_(
01281             doublereal *, doublereal *, doublereal *), fipttp_(doublereal *, 
01282             doublereal *), fitttp_(doublereal *, doublereal *), fittpt_(
01283             doublereal *, doublereal *), orstat_(integer *, integer *, 
01284             doublereal *), fiptpt_(doublereal *, doublereal *), fizttp_(
01285             doublereal *), fiztpt_(doublereal *), fipttz_(doublereal *, 
01286             doublereal *), fitttz_(doublereal *, doublereal *), fizttz_(
01287             doublereal *);
01288     static doublereal r8_eval__[128];
01289     extern doublereal dai_(doublereal *), dbi_(doublereal *, integer *), mad_(
01290             integer *, doublereal *), sem_(integer *, doublereal *);
01291     static integer itm;
01292     extern doublereal lor_(integer *, doublereal *);
01293     static integer ntm;
01294 
01295 
01296 
01297 
01298 
01299 /*  Internal library functions */
01300 
01301 
01302 /*  External library functions */
01303 
01304 
01305 /*  Statistics functions (01 Mar 1999 - see parser_int.c) */
01306 
01307 
01308 /* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
01309  */
01310 
01311     /* Parameter adjustments */
01312     --r8val;
01313     c_code__ -= 8;
01314 
01315     /* Function Body */
01316     if (*num_code__ <= 0) {
01317         ret_val = 0.;
01318         goto L8000;
01319     }
01320 /* -----------------------------------------------------------------------
01321  */
01322     ialpha = 'A' - 1;
01323     neval = 0;
01324     ncode = 0;
01325 
01326 L1000:
01327     ++ncode;
01328     s_copy(cncode, c_code__ + (ncode << 3), 8L, 8L);
01329 /* .......................................................................
01330  */
01331     if (s_cmp(cncode, "PUSHSYM", 8L, 7L) == 0) {
01332         ++neval;
01333         r8_eval__[neval - 1] = r8val[*(unsigned char *)&c_code__[(ncode + 1) *
01334                  8] - ialpha];
01335         ++ncode;
01336 /* ...................................................................
01337 .... */
01338     } else if (s_cmp(cncode, "PUSHNUM", 8L, 7L) == 0) {
01339         ++neval;
01340         s_copy(c8_val__, c_code__ + (ncode + 1 << 3), 8L, 8L);
01341         r8_eval__[neval - 1] = *r8_val__;
01342         ++ncode;
01343 /* ...................................................................
01344 .... */
01345     } else if (s_cmp(cncode, "+", 8L, 1L) == 0) {
01346         --neval;
01347         r8_eval__[neval - 1] += r8_eval__[neval];
01348 /* ...................................................................
01349 .... */
01350     } else if (s_cmp(cncode, "-", 8L, 1L) == 0) {
01351         --neval;
01352         r8_eval__[neval - 1] -= r8_eval__[neval];
01353 /* ...................................................................
01354 .... */
01355     } else if (s_cmp(cncode, "*", 8L, 1L) == 0) {
01356         --neval;
01357         r8_eval__[neval - 1] *= r8_eval__[neval];
01358 /* ...................................................................
01359 .... */
01360     } else if (s_cmp(cncode, "/", 8L, 1L) == 0) {
01361         --neval;
01362         if (r8_eval__[neval] != 0.) {
01363             r8_eval__[neval - 1] /= r8_eval__[neval];
01364         } else {
01365             r8_eval__[neval - 1] = 0.;
01366         }
01367 /* ...................................................................
01368 .... */
01369     } else if (s_cmp(cncode, "**", 8L, 2L) == 0) {
01370         --neval;
01371         if (r8_eval__[neval - 1] > 0. || r8_eval__[neval - 1] != 0. && 
01372                 r8_eval__[neval] == d_int(&r8_eval__[neval])) {
01373             r8_eval__[neval - 1] = pow_dd(&r8_eval__[neval - 1], &r8_eval__[
01374                     neval]);
01375         }
01376 /* ...................................................................
01377 .... */
01378     } else if (s_cmp(cncode, "--", 8L, 2L) == 0) {
01379         r8_eval__[neval - 1] = -r8_eval__[neval - 1];
01380 /* ...................................................................
01381 .... */
01382     } else if (s_cmp(cncode, "SIN", 8L, 3L) == 0) {
01383         r8_eval__[neval - 1] = sin(r8_eval__[neval - 1]);
01384 /* ...................................................................
01385 .... */
01386     } else if (s_cmp(cncode, "SIND", 8L, 4L) == 0) {
01387         r8_eval__[neval - 1] = sin(r8_eval__[neval - 1] * .01745329251994);
01388 /* ...................................................................
01389 .... */
01390     } else if (s_cmp(cncode, "COS", 8L, 3L) == 0) {
01391         r8_eval__[neval - 1] = cos(r8_eval__[neval - 1]);
01392 /* ...................................................................
01393 .... */
01394     } else if (s_cmp(cncode, "COSD", 8L, 4L) == 0) {
01395         r8_eval__[neval - 1] = cos(r8_eval__[neval - 1] * .01745329251994);
01396 /* ...................................................................
01397 .... */
01398     } else if (s_cmp(cncode, "TAN", 8L, 3L) == 0) {
01399         r8_eval__[neval - 1] = tan(r8_eval__[neval - 1]);
01400 /* ...................................................................
01401 .... */
01402     } else if (s_cmp(cncode, "TAND", 8L, 4L) == 0) {
01403         r8_eval__[neval - 1] = tan(r8_eval__[neval - 1] * .01745329251994);
01404 /* ...................................................................
01405 .... */
01406     } else if (s_cmp(cncode, "SQRT", 8L, 4L) == 0) {
01407         r8_eval__[neval - 1] = sqrt((d__1 = r8_eval__[neval - 1], abs(d__1)));
01408 /* ...................................................................
01409 .... */
01410     } else if (s_cmp(cncode, "ABS", 8L, 3L) == 0) {
01411         r8_eval__[neval - 1] = (d__1 = r8_eval__[neval - 1], abs(d__1));
01412 /* ...................................................................
01413 .... */
01414     } else if (s_cmp(cncode, "EXP", 8L, 3L) == 0) {
01415 /* Computing MIN */
01416         d__1 = 87.5, d__2 = r8_eval__[neval - 1];
01417         r8_eval__[neval - 1] = exp((min(d__1,d__2)));
01418 /* ...................................................................
01419 .... */
01420     } else if (s_cmp(cncode, "LOG", 8L, 3L) == 0) {
01421         if (r8_eval__[neval - 1] != 0.) {
01422             r8_eval__[neval - 1] = log((d__1 = r8_eval__[neval - 1], abs(d__1)
01423                     ));
01424         }
01425 /* ...................................................................
01426 .... */
01427     } else if (s_cmp(cncode, "LOG10", 8L, 5L) == 0) {
01428         if (r8_eval__[neval - 1] != 0.) {
01429             d__2 = (d__1 = r8_eval__[neval - 1], abs(d__1));
01430             r8_eval__[neval - 1] = d_lg10(&d__2);
01431         }
01432 /* ...................................................................
01433 .... */
01434     } else if (s_cmp(cncode, "INT", 8L, 3L) == 0) {
01435         r8_eval__[neval - 1] = d_int(&r8_eval__[neval - 1]);
01436 /* ...................................................................
01437 .... */
01438     } else if (s_cmp(cncode, "MAX", 8L, 3L) == 0) {
01439         --neval;
01440 /* Computing MAX */
01441         d__1 = r8_eval__[neval - 1], d__2 = r8_eval__[neval];
01442         r8_eval__[neval - 1] = max(d__1,d__2);
01443 /* ...................................................................
01444 .... */
01445     } else if (s_cmp(cncode, "MIN", 8L, 3L) == 0) {
01446         --neval;
01447 /* Computing MIN */
01448         d__1 = r8_eval__[neval - 1], d__2 = r8_eval__[neval];
01449         r8_eval__[neval - 1] = min(d__1,d__2);
01450 /* ...................................................................
01451 .... */
01452     } else if (s_cmp(cncode, "ASIN", 8L, 4L) == 0) {
01453         if ((d__1 = r8_eval__[neval - 1], abs(d__1)) <= 1.) {
01454             r8_eval__[neval - 1] = asin(r8_eval__[neval - 1]);
01455         }
01456 /* ...................................................................
01457 .... */
01458     } else if (s_cmp(cncode, "ACOS", 8L, 4L) == 0) {
01459         if ((d__1 = r8_eval__[neval - 1], abs(d__1)) <= 1.) {
01460             r8_eval__[neval - 1] = acos(r8_eval__[neval - 1]);
01461         }
01462 /* ...................................................................
01463 .... */
01464     } else if (s_cmp(cncode, "ATAN", 8L, 4L) == 0) {
01465         r8_eval__[neval - 1] = atan(r8_eval__[neval - 1]);
01466 /* ...................................................................
01467 .... */
01468     } else if (s_cmp(cncode, "ATAN2", 8L, 5L) == 0) {
01469         --neval;
01470         if (r8_eval__[neval - 1] != 0. && r8_eval__[neval] != 0.) {
01471             r8_eval__[neval - 1] = atan2(r8_eval__[neval - 1], r8_eval__[
01472                     neval]);
01473         }
01474 /* ...................................................................
01475 .... */
01476     } else if (s_cmp(cncode, "GRAN", 8L, 4L) == 0) {
01477         --neval;
01478         r8_eval__[neval - 1] = gran_(&r8_eval__[neval - 1], &r8_eval__[neval])
01479                 ;
01480 /* ...................................................................
01481 .... */
01482     } else if (s_cmp(cncode, "URAN", 8L, 4L) == 0) {
01483         r8_eval__[neval - 1] = uran_(&r8_eval__[neval - 1]);
01484 /* ...................................................................
01485 .... */
01486     } else if (s_cmp(cncode, "IRAN", 8L, 4L) == 0) {
01487         r8_eval__[neval - 1] = iran_(&r8_eval__[neval - 1]);
01488 /* ...................................................................
01489 .... */
01490     } else if (s_cmp(cncode, "ERAN", 8L, 4L) == 0) {
01491         r8_eval__[neval - 1] = eran_(&r8_eval__[neval - 1]);
01492 /* ...................................................................
01493 .... */
01494     } else if (s_cmp(cncode, "LRAN", 8L, 4L) == 0) {
01495         r8_eval__[neval - 1] = lran_(&r8_eval__[neval - 1]);
01496 /* ...................................................................
01497 .... */
01498     } else if (s_cmp(cncode, "PLEG", 8L, 4L) == 0) {
01499         --neval;
01500         r8_eval__[neval - 1] = legendre_(&r8_eval__[neval - 1], &r8_eval__[
01501                 neval]);
01502 /* ...................................................................
01503 .... */
01504     } else if (s_cmp(cncode, "SINH", 8L, 4L) == 0) {
01505         if ((d__1 = r8_eval__[neval - 1], abs(d__1)) < 87.5f) {
01506             r8_eval__[neval - 1] = sinh(r8_eval__[neval - 1]);
01507         }
01508 /* ...................................................................
01509 .... */
01510     } else if (s_cmp(cncode, "COSH", 8L, 4L) == 0) {
01511         if ((d__1 = r8_eval__[neval - 1], abs(d__1)) < 87.5f) {
01512             r8_eval__[neval - 1] = cosh(r8_eval__[neval - 1]);
01513         }
01514 /* ...................................................................
01515 .... */
01516     } else if (s_cmp(cncode, "TANH", 8L, 4L) == 0) {
01517         r8_eval__[neval - 1] = tanh(r8_eval__[neval - 1]);
01518 /* ...................................................................
01519 .... */
01520     } else if (s_cmp(cncode, "ASINH", 8L, 5L) == 0) {
01521         x = (d__1 = r8_eval__[neval - 1], abs(d__1));
01522         if (x <= 10.) {
01523 /* Computing 2nd power */
01524             d__1 = x;
01525             y = x + sqrt(d__1 * d__1 + 1.);
01526         } else {
01527 /* Computing 2nd power */
01528             d__1 = 1. / x;
01529             y = x * (sqrt(d__1 * d__1 + 1.) + 1.);
01530         }
01531         y = log(y);
01532         if (r8_eval__[neval - 1] < 0.) {
01533             r8_eval__[neval - 1] = -y;
01534         } else {
01535             r8_eval__[neval - 1] = y;
01536         }
01537 /* ...................................................................
01538 .... */
01539     } else if (s_cmp(cncode, "ACOSH", 8L, 5L) == 0) {
01540         x = r8_eval__[neval - 1];
01541         if (x >= 1.) {
01542             if (x <= 10.) {
01543 /* Computing 2nd power */
01544                 d__1 = x;
01545                 y = x + sqrt(d__1 * d__1 - 1.);
01546             } else {
01547 /* Computing 2nd power */
01548                 d__1 = 1. / x;
01549                 y = x * (sqrt(1. - d__1 * d__1) + 1.);
01550             }
01551             r8_eval__[neval - 1] = log(y);
01552         }
01553 /* ...................................................................
01554 .... */
01555     } else if (s_cmp(cncode, "ATANH", 8L, 5L) == 0) {
01556         x = r8_eval__[neval - 1];
01557         if (abs(x) < 1.) {
01558             r8_eval__[neval - 1] = log((x + 1.) / (1. - x)) * .5;
01559         }
01560 /* ...................................................................
01561 .... */
01562     } else if (s_cmp(cncode, "AI", 8L, 2L) == 0) {
01563         r8_eval__[neval - 1] = dai_(&r8_eval__[neval - 1]);
01564 /* ...................................................................
01565 .... */
01566     } else if (s_cmp(cncode, "BI", 8L, 2L) == 0) {
01567         r8_eval__[neval - 1] = dbi_(&r8_eval__[neval - 1], &c__1);
01568 /* ...................................................................
01569 .... */
01570     } else if (s_cmp(cncode, "ERF", 8L, 3L) == 0) {
01571         r8_eval__[neval - 1] = derf_(&r8_eval__[neval - 1]);
01572     } else if (s_cmp(cncode, "ERFC", 8L, 4L) == 0) {
01573         r8_eval__[neval - 1] = derfc_(&r8_eval__[neval - 1]);
01574 /* ...................................................................
01575 .... */
01576     } else if (s_cmp(cncode, "GAMMA", 8L, 5L) == 0) {
01577         r8_eval__[neval - 1] = dgamma_(&r8_eval__[neval - 1]);
01578 /* ...................................................................
01579 .... */
01580     } else if (s_cmp(cncode, "I0", 8L, 2L) == 0) {
01581         r8_eval__[neval - 1] = dbesi0_(&r8_eval__[neval - 1]);
01582     } else if (s_cmp(cncode, "I1", 8L, 2L) == 0) {
01583         r8_eval__[neval - 1] = dbesi1_(&r8_eval__[neval - 1]);
01584 /* ...................................................................
01585 .... */
01586     } else if (s_cmp(cncode, "J0", 8L, 2L) == 0) {
01587         r8_eval__[neval - 1] = dbesj0_(&r8_eval__[neval - 1]);
01588     } else if (s_cmp(cncode, "J1", 8L, 2L) == 0) {
01589         r8_eval__[neval - 1] = dbesj1_(&r8_eval__[neval - 1]);
01590 /* ...................................................................
01591 .... */
01592     } else if (s_cmp(cncode, "K0", 8L, 2L) == 0) {
01593         r8_eval__[neval - 1] = dbesk0_(&r8_eval__[neval - 1]);
01594     } else if (s_cmp(cncode, "K1", 8L, 2L) == 0) {
01595         r8_eval__[neval - 1] = dbesk1_(&r8_eval__[neval - 1]);
01596 /* ...................................................................
01597 .... */
01598     } else if (s_cmp(cncode, "Y0", 8L, 2L) == 0) {
01599         r8_eval__[neval - 1] = dbesy0_(&r8_eval__[neval - 1]);
01600     } else if (s_cmp(cncode, "Y1", 8L, 2L) == 0) {
01601         r8_eval__[neval - 1] = dbesy1_(&r8_eval__[neval - 1]);
01602 /* ...................................................................
01603 .... */
01604     } else if (s_cmp(cncode, "QG", 8L, 2L) == 0) {
01605         r8_eval__[neval - 1] = qg_(&r8_eval__[neval - 1]);
01606     } else if (s_cmp(cncode, "QGINV", 8L, 5L) == 0) {
01607         r8_eval__[neval - 1] = qginv_(&r8_eval__[neval - 1]);
01608     } else if (s_cmp(cncode, "BELL2", 8L, 5L) == 0) {
01609         r8_eval__[neval - 1] = bell2_(&r8_eval__[neval - 1]);
01610     } else if (s_cmp(cncode, "RECT", 8L, 4L) == 0) {
01611         r8_eval__[neval - 1] = rect_(&r8_eval__[neval - 1]);
01612     } else if (s_cmp(cncode, "STEP", 8L, 4L) == 0) {
01613         r8_eval__[neval - 1] = step_(&r8_eval__[neval - 1]);
01614     } else if (s_cmp(cncode, "TENT", 8L, 4L) == 0) {
01615         r8_eval__[neval - 1] = tent_(&r8_eval__[neval - 1]);
01616     } else if (s_cmp(cncode, "BOOL", 8L, 4L) == 0) {
01617         r8_eval__[neval - 1] = bool_(&r8_eval__[neval - 1]);
01618     } else if (s_cmp(cncode, "ZTONE", 8L, 5L) == 0) {
01619         r8_eval__[neval - 1] = ztone_(&r8_eval__[neval - 1]);
01620 /* ...................................................................
01621 .... */
01622     } else if (s_cmp(cncode, "NOTZERO", 8L, 7L) == 0) {
01623         r8_eval__[neval - 1] = bool_(&r8_eval__[neval - 1]);
01624     } else if (s_cmp(cncode, "ISZERO", 8L, 6L) == 0) {
01625         r8_eval__[neval - 1] = 1. - bool_(&r8_eval__[neval - 1]);
01626     } else if (s_cmp(cncode, "EQUALS", 8L, 6L) == 0) {
01627         --neval;
01628         d__1 = r8_eval__[neval - 1] - r8_eval__[neval];
01629         r8_eval__[neval - 1] = 1. - bool_(&d__1);
01630     } else if (s_cmp(cncode, "ISPOSITI", 8L, 8L) == 0) {
01631         r8_eval__[neval - 1] = step_(&r8_eval__[neval - 1]);
01632     } else if (s_cmp(cncode, "ISNEGATI", 8L, 8L) == 0) {
01633         d__1 = -r8_eval__[neval - 1];
01634         r8_eval__[neval - 1] = step_(&d__1);
01635 /* ...................................................................
01636 .... */
01637     } else if (s_cmp(cncode, "AND", 8L, 3L) == 0) {
01638         ntm = (integer) r8_eval__[neval - 1];
01639         neval -= ntm;
01640         r8_eval__[neval - 1] = land_(&ntm, &r8_eval__[neval - 1]);
01641     } else if (s_cmp(cncode, "MEDIAN", 8L, 6L) == 0) {
01642         ntm = (integer) r8_eval__[neval - 1];
01643         neval -= ntm;
01644         r8_eval__[neval - 1] = median_(&ntm, &r8_eval__[neval - 1]);
01645     } else if (s_cmp(cncode, "MAD", 8L, 3L) == 0) {
01646         ntm = (integer) r8_eval__[neval - 1];
01647         neval -= ntm;
01648         r8_eval__[neval - 1] = mad_(&ntm, &r8_eval__[neval - 1]);
01649     } else if (s_cmp(cncode, "MEAN", 8L, 4L) == 0) {
01650         ntm = (integer) r8_eval__[neval - 1];
01651         neval -= ntm;
01652         r8_eval__[neval - 1] = mean_(&ntm, &r8_eval__[neval - 1]);
01653     } else if (s_cmp(cncode, "STDEV", 8L, 5L) == 0) {
01654         ntm = (integer) r8_eval__[neval - 1];
01655         neval -= ntm;
01656         r8_eval__[neval - 1] = stdev_(&ntm, &r8_eval__[neval - 1]);
01657     } else if (s_cmp(cncode, "SEM", 8L, 3L) == 0) {
01658         ntm = (integer) r8_eval__[neval - 1];
01659         neval -= ntm;
01660         r8_eval__[neval - 1] = sem_(&ntm, &r8_eval__[neval - 1]);
01661     } else if (s_cmp(cncode, "ORSTAT", 8L, 6L) == 0) {
01662         ntm = (integer) r8_eval__[neval - 1];
01663         neval -= ntm;
01664         --ntm;
01665         itm = (integer) r8_eval__[neval - 1];
01666         r8_eval__[neval - 1] = orstat_(&itm, &ntm, &r8_eval__[neval]);
01667     } else if (s_cmp(cncode, "HMODE", 8L, 5L) == 0) {
01668         ntm = (integer) r8_eval__[neval - 1];
01669         neval -= ntm;
01670         r8_eval__[neval - 1] = hmode_(&ntm, &r8_eval__[neval - 1]);
01671     } else if (s_cmp(cncode, "LMODE", 8L, 5L) == 0) {
01672         ntm = (integer) r8_eval__[neval - 1];
01673         neval -= ntm;
01674         r8_eval__[neval - 1] = lmode_(&ntm, &r8_eval__[neval - 1]);
01675     } else if (s_cmp(cncode, "OR", 8L, 2L) == 0) {
01676         ntm = (integer) r8_eval__[neval - 1];
01677         neval -= ntm;
01678         r8_eval__[neval - 1] = lor_(&ntm, &r8_eval__[neval - 1]);
01679     } else if (s_cmp(cncode, "MOFN", 8L, 4L) == 0) {
01680         ntm = (integer) r8_eval__[neval - 1];
01681         neval -= ntm;
01682         --ntm;
01683         itm = (integer) r8_eval__[neval - 1];
01684         r8_eval__[neval - 1] = lmofn_(&itm, &ntm, &r8_eval__[neval]);
01685     } else if (s_cmp(cncode, "ASTEP", 8L, 5L) == 0) {
01686         --neval;
01687         if ((d__1 = r8_eval__[neval - 1], abs(d__1)) > r8_eval__[neval]) {
01688             r8_eval__[neval - 1] = 1.;
01689         } else {
01690             r8_eval__[neval - 1] = 0.;
01691         }
01692     } else if (s_cmp(cncode, "ARGMAX", 8L, 6L) == 0) {
01693         ntm = (integer) r8_eval__[neval - 1];
01694         neval -= ntm;
01695         r8_eval__[neval - 1] = argmax_(&ntm, &r8_eval__[neval - 1]);
01696     } else if (s_cmp(cncode, "ARGNUM", 8L, 6L) == 0) {
01697         ntm = (integer) r8_eval__[neval - 1];
01698         neval -= ntm;
01699         r8_eval__[neval - 1] = argnum_(&ntm, &r8_eval__[neval - 1]);
01700 /* ...................................................................
01701 .... */
01702     } else if (s_cmp(cncode, "FICO_T2P", 8L, 8L) == 0) {
01703         neval += -3;
01704         d__2 = (d__1 = r8_eval__[neval - 1], abs(d__1));
01705         r8_eval__[neval - 1] = ficotp_(&d__2, &r8_eval__[neval], &r8_eval__[
01706                 neval + 1], &r8_eval__[neval + 2]);
01707     } else if (s_cmp(cncode, "FICO_P2T", 8L, 8L) == 0) {
01708         neval += -3;
01709         r8_eval__[neval - 1] = ficopt_(&r8_eval__[neval - 1], &r8_eval__[
01710                 neval], &r8_eval__[neval + 1], &r8_eval__[neval + 2]);
01711     } else if (s_cmp(cncode, "FICO_T2Z", 8L, 8L) == 0) {
01712         neval += -3;
01713         r8_eval__[neval - 1] = ficotz_(&r8_eval__[neval - 1], &r8_eval__[
01714                 neval], &r8_eval__[neval + 1], &r8_eval__[neval + 2]);
01715 /* ...................................................................
01716 .... */
01717     } else if (s_cmp(cncode, "FITT_T2P", 8L, 8L) == 0) {
01718         --neval;
01719         d__2 = (d__1 = r8_eval__[neval - 1], abs(d__1));
01720         r8_eval__[neval - 1] = fitttp_(&d__2, &r8_eval__[neval]);
01721     } else if (s_cmp(cncode, "FITT_P2T", 8L, 8L) == 0) {
01722         --neval;
01723         r8_eval__[neval - 1] = fittpt_(&r8_eval__[neval - 1], &r8_eval__[
01724                 neval]);
01725     } else if (s_cmp(cncode, "FITT_T2Z", 8L, 8L) == 0) {
01726         --neval;
01727         r8_eval__[neval - 1] = fitttz_(&r8_eval__[neval - 1], &r8_eval__[
01728                 neval]);
01729 /* ...................................................................
01730 .... */
01731     } else if (s_cmp(cncode, "FIFT_T2P", 8L, 8L) == 0) {
01732         neval += -2;
01733         r8_eval__[neval - 1] = fifttp_(&r8_eval__[neval - 1], &r8_eval__[
01734                 neval], &r8_eval__[neval + 1]);
01735     } else if (s_cmp(cncode, "FIFT_P2T", 8L, 8L) == 0) {
01736         neval += -2;
01737         r8_eval__[neval - 1] = fiftpt_(&r8_eval__[neval - 1], &r8_eval__[
01738                 neval], &r8_eval__[neval + 1]);
01739     } else if (s_cmp(cncode, "FIFT_T2Z", 8L, 8L) == 0) {
01740         neval += -2;
01741         r8_eval__[neval - 1] = fifttz_(&r8_eval__[neval - 1], &r8_eval__[
01742                 neval], &r8_eval__[neval + 1]);
01743 /* ...................................................................
01744 .... */
01745     } else if (s_cmp(cncode, "FIZT_T2P", 8L, 8L) == 0) {
01746         d__2 = (d__1 = r8_eval__[neval - 1], abs(d__1));
01747         r8_eval__[neval - 1] = fizttp_(&d__2);
01748     } else if (s_cmp(cncode, "FIZT_P2T", 8L, 8L) == 0) {
01749         r8_eval__[neval - 1] = fiztpt_(&r8_eval__[neval - 1]);
01750     } else if (s_cmp(cncode, "FIZT_T2Z", 8L, 8L) == 0) {
01751         r8_eval__[neval - 1] = fizttz_(&r8_eval__[neval - 1]);
01752 /* ...................................................................
01753 .... */
01754     } else if (s_cmp(cncode, "FICT_T2P", 8L, 8L) == 0) {
01755         --neval;
01756         r8_eval__[neval - 1] = ficttp_(&r8_eval__[neval - 1], &r8_eval__[
01757                 neval]);
01758     } else if (s_cmp(cncode, "FICT_P2T", 8L, 8L) == 0) {
01759         --neval;
01760         r8_eval__[neval - 1] = fictpt_(&r8_eval__[neval - 1], &r8_eval__[
01761                 neval]);
01762     } else if (s_cmp(cncode, "FICT_T2Z", 8L, 8L) == 0) {
01763         --neval;
01764         r8_eval__[neval - 1] = ficttz_(&r8_eval__[neval - 1], &r8_eval__[
01765                 neval]);
01766 /* ...................................................................
01767 .... */
01768     } else if (s_cmp(cncode, "FIBT_T2P", 8L, 8L) == 0) {
01769         neval += -2;
01770         r8_eval__[neval - 1] = fibttp_(&r8_eval__[neval - 1], &r8_eval__[
01771                 neval], &r8_eval__[neval + 1]);
01772     } else if (s_cmp(cncode, "FIBT_P2T", 8L, 8L) == 0) {
01773         neval += -2;
01774         r8_eval__[neval - 1] = fibtpt_(&r8_eval__[neval - 1], &r8_eval__[
01775                 neval], &r8_eval__[neval + 1]);
01776     } else if (s_cmp(cncode, "FIBT_T2Z", 8L, 8L) == 0) {
01777         neval += -2;
01778         r8_eval__[neval - 1] = fibttz_(&r8_eval__[neval - 1], &r8_eval__[
01779                 neval], &r8_eval__[neval + 1]);
01780 /* ...................................................................
01781 .... */
01782     } else if (s_cmp(cncode, "FIBN_T2P", 8L, 8L) == 0) {
01783         neval += -2;
01784         r8_eval__[neval - 1] = fibntp_(&r8_eval__[neval - 1], &r8_eval__[
01785                 neval], &r8_eval__[neval + 1]);
01786     } else if (s_cmp(cncode, "FIBN_P2T", 8L, 8L) == 0) {
01787         neval += -2;
01788         r8_eval__[neval - 1] = fibnpt_(&r8_eval__[neval - 1], &r8_eval__[
01789                 neval], &r8_eval__[neval + 1]);
01790     } else if (s_cmp(cncode, "FIBN_T2Z", 8L, 8L) == 0) {
01791         neval += -2;
01792         r8_eval__[neval - 1] = fibntz_(&r8_eval__[neval - 1], &r8_eval__[
01793                 neval], &r8_eval__[neval + 1]);
01794 /* ...................................................................
01795 .... */
01796     } else if (s_cmp(cncode, "FIGT_T2P", 8L, 8L) == 0) {
01797         neval += -2;
01798         r8_eval__[neval - 1] = figttp_(&r8_eval__[neval - 1], &r8_eval__[
01799                 neval], &r8_eval__[neval + 1]);
01800     } else if (s_cmp(cncode, "FIGT_P2T", 8L, 8L) == 0) {
01801         neval += -2;
01802         r8_eval__[neval - 1] = figtpt_(&r8_eval__[neval - 1], &r8_eval__[
01803                 neval], &r8_eval__[neval + 1]);
01804     } else if (s_cmp(cncode, "FIGT_T2Z", 8L, 8L) == 0) {
01805         neval += -2;
01806         r8_eval__[neval - 1] = figttz_(&r8_eval__[neval - 1], &r8_eval__[
01807                 neval], &r8_eval__[neval + 1]);
01808 /* ...................................................................
01809 .... */
01810     } else if (s_cmp(cncode, "FIPT_T2P", 8L, 8L) == 0) {
01811         --neval;
01812         r8_eval__[neval - 1] = fipttp_(&r8_eval__[neval - 1], &r8_eval__[
01813                 neval]);
01814     } else if (s_cmp(cncode, "FIPT_P2T", 8L, 8L) == 0) {
01815         --neval;
01816         r8_eval__[neval - 1] = fiptpt_(&r8_eval__[neval - 1], &r8_eval__[
01817                 neval]);
01818     } else if (s_cmp(cncode, "FIPT_T2Z", 8L, 8L) == 0) {
01819         --neval;
01820         r8_eval__[neval - 1] = fipttz_(&r8_eval__[neval - 1], &r8_eval__[
01821                 neval]);
01822 /* ...................................................................
01823 .... */
01824     }
01825 /* .......................................................................
01826  */
01827     if (ncode < *num_code__) {
01828         goto L1000;
01829     }
01830     ret_val = r8_eval__[neval - 1];
01831 /* -----------------------------------------------------------------------
01832  */
01833 L8000:
01834     return ret_val;
01835 } /* pareval_ */
01836 
01837 #undef r8_val__
01838 #undef c8_val__
01839 
01840 
01841 
01842 
01843 
01844 /* Subroutine */ int parevec_(integer *num_code__, char *c_code__, doublereal 
01845         *va, doublereal *vb, doublereal *vc, doublereal *vd, doublereal *ve, 
01846         doublereal *vf, doublereal *vg, doublereal *vh, doublereal *vi, 
01847         doublereal *vj, doublereal *vk, doublereal *vl, doublereal *vm, 
01848         doublereal *vn, doublereal *vo, doublereal *vp, doublereal *vq, 
01849         doublereal *vr, doublereal *vs, doublereal *vt, doublereal *vu, 
01850         doublereal *vv, doublereal *vw, doublereal *vx, doublereal *vy, 
01851         doublereal *vz, integer *lvec, doublereal *vout, ftnlen c_code_len)
01852 {
01853     /* System generated locals */
01854     integer i__1, i__2, i__3;
01855     doublereal d__1, d__2;
01856     static doublereal equiv_0[1];
01857 
01858     /* Builtin functions */
01859     /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
01860     integer s_cmp(char *, char *, ftnlen, ftnlen);
01861     double d_int(doublereal *), pow_dd(doublereal *, doublereal *), sin(
01862             doublereal), cos(doublereal), tan(doublereal), sqrt(doublereal), 
01863             exp(doublereal), log(doublereal), d_lg10(doublereal *), asin(
01864             doublereal), acos(doublereal), atan(doublereal), atan2(doublereal,
01865              doublereal), sinh(doublereal), cosh(doublereal), tanh(doublereal)
01866             ;
01867 
01868     /* Local variables */
01869     extern doublereal land_(integer *, doublereal *), mean_(integer *, 
01870             doublereal *), derf_(doublereal *), eran_(doublereal *), gran_(
01871             doublereal *, doublereal *), iran_(doublereal *), bool_(
01872             doublereal *), lran_(doublereal *), rect_(doublereal *);
01873     static doublereal scop[101];
01874     extern doublereal uran_(doublereal *), legendre_(doublereal *, doublereal 
01875             *), tent_(doublereal *), step_(doublereal *), bell2_(doublereal *)
01876             ;
01877     static doublereal r8val[1664]       /* was [64][26] */;
01878     extern doublereal derfc_(doublereal *);
01879     static integer ncode;
01880     static doublereal x, y;
01881     extern doublereal hmode_(integer *, doublereal *), lmode_(integer *, 
01882             doublereal *);
01883     static integer neval;
01884     extern doublereal lmofn_(integer *, integer *, doublereal *);
01885     static integer ivbot;
01886     extern doublereal qginv_(doublereal *), stdev_(integer *, doublereal *);
01887     static char c2code[8];
01888     extern doublereal ztone_(doublereal *);
01889     static integer ivtop;
01890     extern doublereal dbesi0_(doublereal *), dbesi1_(doublereal *), dbesj0_(
01891             doublereal *), dbesj1_(doublereal *), dbesk0_(doublereal *), 
01892             dbesk1_(doublereal *);
01893 #define c8_val__ ((char *)equiv_0)
01894     extern doublereal dbesy0_(doublereal *), dbesy1_(doublereal *);
01895 #define r8_val__ (equiv_0)
01896     static integer jf;
01897     extern doublereal dgamma_(doublereal *);
01898     static integer ialpha, iv;
01899     static char cncode[8];
01900     extern doublereal qg_(doublereal *), median_(integer *, doublereal *), 
01901             argmax_(integer *, doublereal *), ficotp_(doublereal *, 
01902             doublereal *, doublereal *, doublereal *), ficopt_(doublereal *, 
01903             doublereal *, doublereal *, doublereal *), argnum_(integer *, 
01904             doublereal *), ficttp_(doublereal *, doublereal *), fictpt_(
01905             doublereal *, doublereal *), fifttp_(doublereal *, doublereal *, 
01906             doublereal *), fiftpt_(doublereal *, doublereal *, doublereal *), 
01907             ficotz_(doublereal *, doublereal *, doublereal *, doublereal *), 
01908             fibttp_(doublereal *, doublereal *, doublereal *), fibtpt_(
01909             doublereal *, doublereal *, doublereal *), fibntp_(doublereal *, 
01910             doublereal *, doublereal *), fibttz_(doublereal *, doublereal *, 
01911             doublereal *), ficttz_(doublereal *, doublereal *), fibnpt_(
01912             doublereal *, doublereal *, doublereal *), fibntz_(doublereal *, 
01913             doublereal *, doublereal *), fifttz_(doublereal *, doublereal *, 
01914             doublereal *), figttp_(doublereal *, doublereal *, doublereal *), 
01915             figtpt_(doublereal *, doublereal *, doublereal *), fitttp_(
01916             doublereal *, doublereal *), fittpt_(doublereal *, doublereal *), 
01917             orstat_(integer *, integer *, doublereal *), figttz_(doublereal *,
01918              doublereal *, doublereal *), fipttp_(doublereal *, doublereal *),
01919              fiptpt_(doublereal *, doublereal *), fizttp_(doublereal *), 
01920             fiztpt_(doublereal *), fipttz_(doublereal *, doublereal *), 
01921             fitttz_(doublereal *, doublereal *), fizttz_(doublereal *);
01922     static doublereal r8_eval__[6464]   /* was [64][101] */;
01923     extern doublereal dai_(doublereal *), dbi_(doublereal *, integer *), mad_(
01924             integer *, doublereal *);
01925     static integer ibv;
01926     extern doublereal sem_(integer *, doublereal *);
01927     static integer itm, jtm;
01928     extern doublereal lor_(integer *, doublereal *);
01929     static integer ntm;
01930 
01931 
01932 /*  Vector version of PAREVAL, where VA..VZ with length LVEC */
01933 /*  are supplied as vectors. */
01934 /*  [Modified by Raoqiong Tong, August 1997] */
01935 
01936 
01937 
01938 
01939 /*  14 Jul 1998: add 1D array for stack copy */
01940 
01941 
01942 /*  Internal library functions */
01943 
01944 
01945 /*  External library functions */
01946 
01947 
01948 /*  Statistics functions (01 Mar 1999 - see parser_int.c) */
01949 
01950 
01951 /* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
01952  */
01953 
01954     /* Parameter adjustments */
01955     c_code__ -= 8;
01956     --vout;
01957     --vz;
01958     --vy;
01959     --vx;
01960     --vw;
01961     --vv;
01962     --vu;
01963     --vt;
01964     --vs;
01965     --vr;
01966     --vq;
01967     --vp;
01968     --vo;
01969     --vn;
01970     --vm;
01971     --vl;
01972     --vk;
01973     --vj;
01974     --vi;
01975     --vh;
01976     --vg;
01977     --vf;
01978     --ve;
01979     --vd;
01980     --vc;
01981     --vb;
01982     --va;
01983 
01984     /* Function Body */
01985     if (*num_code__ <= 0 || *lvec <= 0) {
01986         goto L8000;
01987     }
01988 
01989     ialpha = 'A' - 1;
01990 /* -----------------------------------------------------------------------
01991  */
01992     i__1 = *lvec - 1;
01993     for (ibv = 0; ibv <= i__1; ibv += 64) {
01994         ivbot = ibv + 1;
01995         ivtop = ibv + 64;
01996         if (ivtop > *lvec) {
01997             ivtop = *lvec;
01998         }
01999 
02000 /* cc         WRITE(*,9802) IVBOT,IVTOP */
02001 /* cc9802     FORMAT('   .. PAREVEC: loop from',I5,' to',I5) */
02002 
02003         i__2 = ivtop;
02004         for (iv = ivbot; iv <= i__2; ++iv) {
02005             r8val[iv - ibv - 1] = va[iv];
02006 /* L100: */
02007         }
02008         i__2 = ivtop;
02009         for (iv = ivbot; iv <= i__2; ++iv) {
02010             r8val[iv - ibv + 63] = vb[iv];
02011 /* L101: */
02012         }
02013         i__2 = ivtop;
02014         for (iv = ivbot; iv <= i__2; ++iv) {
02015             r8val[iv - ibv + 127] = vc[iv];
02016 /* L102: */
02017         }
02018         i__2 = ivtop;
02019         for (iv = ivbot; iv <= i__2; ++iv) {
02020             r8val[iv - ibv + 191] = vd[iv];
02021 /* L103: */
02022         }
02023         i__2 = ivtop;
02024         for (iv = ivbot; iv <= i__2; ++iv) {
02025             r8val[iv - ibv + 255] = ve[iv];
02026 /* L104: */
02027         }
02028         i__2 = ivtop;
02029         for (iv = ivbot; iv <= i__2; ++iv) {
02030             r8val[iv - ibv + 319] = vf[iv];
02031 /* L105: */
02032         }
02033         i__2 = ivtop;
02034         for (iv = ivbot; iv <= i__2; ++iv) {
02035             r8val[iv - ibv + 383] = vg[iv];
02036 /* L106: */
02037         }
02038         i__2 = ivtop;
02039         for (iv = ivbot; iv <= i__2; ++iv) {
02040             r8val[iv - ibv + 447] = vh[iv];
02041 /* L107: */
02042         }
02043         i__2 = ivtop;
02044         for (iv = ivbot; iv <= i__2; ++iv) {
02045             r8val[iv - ibv + 511] = vi[iv];
02046 /* L108: */
02047         }
02048         i__2 = ivtop;
02049         for (iv = ivbot; iv <= i__2; ++iv) {
02050             r8val[iv - ibv + 575] = vj[iv];
02051 /* L109: */
02052         }
02053         i__2 = ivtop;
02054         for (iv = ivbot; iv <= i__2; ++iv) {
02055             r8val[iv - ibv + 639] = vk[iv];
02056 /* L110: */
02057         }
02058         i__2 = ivtop;
02059         for (iv = ivbot; iv <= i__2; ++iv) {
02060             r8val[iv - ibv + 703] = vl[iv];
02061 /* L111: */
02062         }
02063         i__2 = ivtop;
02064         for (iv = ivbot; iv <= i__2; ++iv) {
02065             r8val[iv - ibv + 767] = vm[iv];
02066 /* L112: */
02067         }
02068         i__2 = ivtop;
02069         for (iv = ivbot; iv <= i__2; ++iv) {
02070             r8val[iv - ibv + 831] = vn[iv];
02071 /* L113: */
02072         }
02073         i__2 = ivtop;
02074         for (iv = ivbot; iv <= i__2; ++iv) {
02075             r8val[iv - ibv + 895] = vo[iv];
02076 /* L114: */
02077         }
02078         i__2 = ivtop;
02079         for (iv = ivbot; iv <= i__2; ++iv) {
02080             r8val[iv - ibv + 959] = vp[iv];
02081 /* L115: */
02082         }
02083         i__2 = ivtop;
02084         for (iv = ivbot; iv <= i__2; ++iv) {
02085             r8val[iv - ibv + 1023] = vq[iv];
02086 /* L116: */
02087         }
02088         i__2 = ivtop;
02089         for (iv = ivbot; iv <= i__2; ++iv) {
02090             r8val[iv - ibv + 1087] = vr[iv];
02091 /* L117: */
02092         }
02093         i__2 = ivtop;
02094         for (iv = ivbot; iv <= i__2; ++iv) {
02095             r8val[iv - ibv + 1151] = vs[iv];
02096 /* L118: */
02097         }
02098         i__2 = ivtop;
02099         for (iv = ivbot; iv <= i__2; ++iv) {
02100             r8val[iv - ibv + 1215] = vt[iv];
02101 /* L119: */
02102         }
02103         i__2 = ivtop;
02104         for (iv = ivbot; iv <= i__2; ++iv) {
02105             r8val[iv - ibv + 1279] = vu[iv];
02106 /* L120: */
02107         }
02108         i__2 = ivtop;
02109         for (iv = ivbot; iv <= i__2; ++iv) {
02110             r8val[iv - ibv + 1343] = vv[iv];
02111 /* L121: */
02112         }
02113         i__2 = ivtop;
02114         for (iv = ivbot; iv <= i__2; ++iv) {
02115             r8val[iv - ibv + 1407] = vw[iv];
02116 /* L122: */
02117         }
02118         i__2 = ivtop;
02119         for (iv = ivbot; iv <= i__2; ++iv) {
02120             r8val[iv - ibv + 1471] = vx[iv];
02121 /* L123: */
02122         }
02123         i__2 = ivtop;
02124         for (iv = ivbot; iv <= i__2; ++iv) {
02125             r8val[iv - ibv + 1535] = vy[iv];
02126 /* L124: */
02127         }
02128         i__2 = ivtop;
02129         for (iv = ivbot; iv <= i__2; ++iv) {
02130             r8val[iv - ibv + 1599] = vz[iv];
02131 /* L125: */
02132         }
02133 
02134         neval = 0;
02135         ncode = 0;
02136 
02137 L1000:
02138         ++ncode;
02139         s_copy(cncode, c_code__ + (ncode << 3), 8L, 8L);
02140 /* cc         WRITE(*,9803) CNCODE */
02141 /* cc9803     FORMAT('   .. PAREVEC: opcode=',A) */
02142 /* ...................................................................
02143 .... */
02144         if (s_cmp(cncode, "PUSHSYM", 8L, 7L) == 0) {
02145             jf = *(unsigned char *)&c_code__[(ncode + 1) * 8] - ialpha;
02146             if (ncode + 2 <= *num_code__) {
02147                 s_copy(c2code, c_code__ + (ncode + 2 << 3), 8L, 8L);
02148             } else {
02149                 s_copy(c2code, "q", 8L, 1L);
02150             }
02151             if (s_cmp(c2code, "+", 8L, 1L) == 0) {
02152                 ncode += 2;
02153                 i__2 = ivtop;
02154                 for (iv = ivbot; iv <= i__2; ++iv) {
02155                     r8_eval__[iv - ibv + (neval << 6) - 65] += r8val[iv - ibv 
02156                             + (jf << 6) - 65];
02157                 }
02158             } else if (s_cmp(c2code, "-", 8L, 1L) == 0) {
02159                 ncode += 2;
02160                 i__2 = ivtop;
02161                 for (iv = ivbot; iv <= i__2; ++iv) {
02162                     r8_eval__[iv - ibv + (neval << 6) - 65] -= r8val[iv - ibv 
02163                             + (jf << 6) - 65];
02164                 }
02165             } else if (s_cmp(c2code, "*", 8L, 1L) == 0) {
02166                 ncode += 2;
02167                 i__2 = ivtop;
02168                 for (iv = ivbot; iv <= i__2; ++iv) {
02169                     r8_eval__[iv - ibv + (neval << 6) - 65] *= r8val[iv - ibv 
02170                             + (jf << 6) - 65];
02171                 }
02172             } else if (s_cmp(c2code, "/", 8L, 1L) == 0) {
02173                 ncode += 2;
02174                 i__2 = ivtop;
02175                 for (iv = ivbot; iv <= i__2; ++iv) {
02176                     if (r8val[iv - ibv + (jf << 6) - 65] != 0.) {
02177                         r8_eval__[iv - ibv + (neval << 6) - 65] /= r8val[iv - 
02178                                 ibv + (jf << 6) - 65];
02179                     } else {
02180                         r8_eval__[iv - ibv + (neval << 6) - 65] = 0.;
02181                     }
02182                 }
02183             } else {
02184                 ++neval;
02185                 ++ncode;
02186                 i__2 = ivtop;
02187                 for (iv = ivbot; iv <= i__2; ++iv) {
02188                     r8_eval__[iv - ibv + (neval << 6) - 65] = r8val[iv - ibv 
02189                             + (jf << 6) - 65];
02190                 }
02191             }
02192 /* ...............................................................
02193 ........ */
02194         } else if (s_cmp(cncode, "PUSHNUM", 8L, 7L) == 0) {
02195             s_copy(c8_val__, c_code__ + (ncode + 1 << 3), 8L, 8L);
02196             if (ncode + 2 <= *num_code__) {
02197                 s_copy(c2code, c_code__ + (ncode + 2 << 3), 8L, 8L);
02198             } else {
02199                 s_copy(c2code, "q", 8L, 1L);
02200             }
02201             if (s_cmp(c2code, "+", 8L, 1L) == 0) {
02202                 ncode += 2;
02203                 i__2 = ivtop;
02204                 for (iv = ivbot; iv <= i__2; ++iv) {
02205                     r8_eval__[iv - ibv + (neval << 6) - 65] += *r8_val__;
02206                 }
02207             } else if (s_cmp(c2code, "-", 8L, 1L) == 0) {
02208                 ncode += 2;
02209                 i__2 = ivtop;
02210                 for (iv = ivbot; iv <= i__2; ++iv) {
02211                     r8_eval__[iv - ibv + (neval << 6) - 65] -= *r8_val__;
02212                 }
02213             } else if (s_cmp(c2code, "*", 8L, 1L) == 0) {
02214                 ncode += 2;
02215                 i__2 = ivtop;
02216                 for (iv = ivbot; iv <= i__2; ++iv) {
02217                     r8_eval__[iv - ibv + (neval << 6) - 65] *= *r8_val__;
02218                 }
02219             } else if (s_cmp(c2code, "/", 8L, 1L) == 0) {
02220                 ncode += 2;
02221                 if (*r8_val__ != 0.) {
02222                     *r8_val__ = 1. / *r8_val__;
02223                     i__2 = ivtop;
02224                     for (iv = ivbot; iv <= i__2; ++iv) {
02225                         r8_eval__[iv - ibv + (neval << 6) - 65] *= *r8_val__;
02226                     }
02227                 } else {
02228                     i__2 = ivtop;
02229                     for (iv = ivbot; iv <= i__2; ++iv) {
02230                         r8_eval__[iv - ibv + (neval << 6) - 65] = 0.;
02231                     }
02232                 }
02233             } else {
02234                 ++ncode;
02235                 ++neval;
02236                 i__2 = ivtop;
02237                 for (iv = ivbot; iv <= i__2; ++iv) {
02238                     r8_eval__[iv - ibv + (neval << 6) - 65] = *r8_val__;
02239                 }
02240             }
02241 /* ...............................................................
02242 ........ */
02243         } else if (s_cmp(cncode, "+", 8L, 1L) == 0) {
02244             --neval;
02245             i__2 = ivtop;
02246             for (iv = ivbot; iv <= i__2; ++iv) {
02247                 r8_eval__[iv - ibv + (neval << 6) - 65] += r8_eval__[iv - ibv 
02248                         + (neval + 1 << 6) - 65];
02249             }
02250 /* ...............................................................
02251 ........ */
02252         } else if (s_cmp(cncode, "-", 8L, 1L) == 0) {
02253             --neval;
02254             i__2 = ivtop;
02255             for (iv = ivbot; iv <= i__2; ++iv) {
02256                 r8_eval__[iv - ibv + (neval << 6) - 65] -= r8_eval__[iv - ibv 
02257                         + (neval + 1 << 6) - 65];
02258             }
02259 /* ...............................................................
02260 ........ */
02261         } else if (s_cmp(cncode, "*", 8L, 1L) == 0) {
02262             --neval;
02263             i__2 = ivtop;
02264             for (iv = ivbot; iv <= i__2; ++iv) {
02265                 r8_eval__[iv - ibv + (neval << 6) - 65] *= r8_eval__[iv - ibv 
02266                         + (neval + 1 << 6) - 65];
02267             }
02268 /* ...............................................................
02269 ........ */
02270         } else if (s_cmp(cncode, "/", 8L, 1L) == 0) {
02271             --neval;
02272             i__2 = ivtop;
02273             for (iv = ivbot; iv <= i__2; ++iv) {
02274                 if (r8_eval__[iv - ibv + (neval + 1 << 6) - 65] != 0.) {
02275                     r8_eval__[iv - ibv + (neval << 6) - 65] /= r8_eval__[iv - 
02276                             ibv + (neval + 1 << 6) - 65];
02277                 } else {
02278                     r8_eval__[iv - ibv + (neval << 6) - 65] = 0.;
02279                 }
02280             }
02281 /* ...............................................................
02282 ........ */
02283         } else if (s_cmp(cncode, "**", 8L, 2L) == 0) {
02284             --neval;
02285             i__2 = ivtop;
02286             for (iv = ivbot; iv <= i__2; ++iv) {
02287                 if (r8_eval__[iv - ibv + (neval << 6) - 65] > 0. || r8_eval__[
02288                         iv - ibv + (neval << 6) - 65] != 0. && r8_eval__[iv - 
02289                         ibv + (neval + 1 << 6) - 65] == d_int(&r8_eval__[iv - 
02290                         ibv + (neval + 1 << 6) - 65])) {
02291                     r8_eval__[iv - ibv + (neval << 6) - 65] = pow_dd(&
02292                             r8_eval__[iv - ibv + (neval << 6) - 65], &
02293                             r8_eval__[iv - ibv + (neval + 1 << 6) - 65]);
02294                 }
02295             }
02296 /* ...............................................................
02297 ........ */
02298         } else if (s_cmp(cncode, "--", 8L, 2L) == 0) {
02299             i__2 = ivtop;
02300             for (iv = ivbot; iv <= i__2; ++iv) {
02301                 r8_eval__[iv - ibv + (neval << 6) - 65] = -r8_eval__[iv - ibv 
02302                         + (neval << 6) - 65];
02303             }
02304 /* ...............................................................
02305 ........ */
02306         } else if (s_cmp(cncode, "SIN", 8L, 3L) == 0) {
02307             i__2 = ivtop;
02308             for (iv = ivbot; iv <= i__2; ++iv) {
02309                 r8_eval__[iv - ibv + (neval << 6) - 65] = sin(r8_eval__[iv - 
02310                         ibv + (neval << 6) - 65]);
02311             }
02312 /* ...............................................................
02313 ........ */
02314         } else if (s_cmp(cncode, "SIND", 8L, 4L) == 0) {
02315             i__2 = ivtop;
02316             for (iv = ivbot; iv <= i__2; ++iv) {
02317                 r8_eval__[iv - ibv + (neval << 6) - 65] = sin(r8_eval__[iv - 
02318                         ibv + (neval << 6) - 65] * .01745329251994);
02319             }
02320 /* ...............................................................
02321 ........ */
02322         } else if (s_cmp(cncode, "COS", 8L, 3L) == 0) {
02323             i__2 = ivtop;
02324             for (iv = ivbot; iv <= i__2; ++iv) {
02325                 r8_eval__[iv - ibv + (neval << 6) - 65] = cos(r8_eval__[iv - 
02326                         ibv + (neval << 6) - 65]);
02327             }
02328 /* ...............................................................
02329 ........ */
02330         } else if (s_cmp(cncode, "COSD", 8L, 4L) == 0) {
02331             i__2 = ivtop;
02332             for (iv = ivbot; iv <= i__2; ++iv) {
02333                 r8_eval__[iv - ibv + (neval << 6) - 65] = cos(r8_eval__[iv - 
02334                         ibv + (neval << 6) - 65] * .01745329251994);
02335             }
02336 /* ...............................................................
02337 ........ */
02338         } else if (s_cmp(cncode, "TAN", 8L, 3L) == 0) {
02339             i__2 = ivtop;
02340             for (iv = ivbot; iv <= i__2; ++iv) {
02341                 r8_eval__[iv - ibv + (neval << 6) - 65] = tan(r8_eval__[iv - 
02342                         ibv + (neval << 6) - 65]);
02343             }
02344 /* ...............................................................
02345 ........ */
02346         } else if (s_cmp(cncode, "TAND", 8L, 4L) == 0) {
02347             i__2 = ivtop;
02348             for (iv = ivbot; iv <= i__2; ++iv) {
02349                 r8_eval__[iv - ibv + (neval << 6) - 65] = tan(r8_eval__[iv - 
02350                         ibv + (neval << 6) - 65] * .01745329251994);
02351             }
02352 /* ...............................................................
02353 ........ */
02354         } else if (s_cmp(cncode, "SQRT", 8L, 4L) == 0) {
02355             i__2 = ivtop;
02356             for (iv = ivbot; iv <= i__2; ++iv) {
02357                 r8_eval__[iv - ibv + (neval << 6) - 65] = sqrt((d__1 = 
02358                         r8_eval__[iv - ibv + (neval << 6) - 65], abs(d__1)));
02359             }
02360 /* ...............................................................
02361 ........ */
02362         } else if (s_cmp(cncode, "ABS", 8L, 3L) == 0) {
02363             i__2 = ivtop;
02364             for (iv = ivbot; iv <= i__2; ++iv) {
02365 /* cc               WRITE(*,9809) IV */
02366 /* cc9809           FORMAT('     about to ABS #',I5) */
02367                 r8_eval__[iv - ibv + (neval << 6) - 65] = (d__1 = r8_eval__[
02368                         iv - ibv + (neval << 6) - 65], abs(d__1));
02369             }
02370 /* ...............................................................
02371 ........ */
02372         } else if (s_cmp(cncode, "EXP", 8L, 3L) == 0) {
02373             i__2 = ivtop;
02374             for (iv = ivbot; iv <= i__2; ++iv) {
02375 /* Computing MIN */
02376                 d__1 = 87.5f, d__2 = r8_eval__[iv - ibv + (neval << 6) - 65];
02377                 r8_eval__[iv - ibv + (neval << 6) - 65] = exp((min(d__1,d__2))
02378                         );
02379             }
02380 /* ...............................................................
02381 ........ */
02382         } else if (s_cmp(cncode, "LOG", 8L, 3L) == 0) {
02383             i__2 = ivtop;
02384             for (iv = ivbot; iv <= i__2; ++iv) {
02385                 if (r8_eval__[iv - ibv + (neval << 6) - 65] != 0.) {
02386                     r8_eval__[iv - ibv + (neval << 6) - 65] = log((d__1 = 
02387                             r8_eval__[iv - ibv + (neval << 6) - 65], abs(d__1)
02388                             ));
02389                 }
02390             }
02391 /* ...............................................................
02392 ........ */
02393         } else if (s_cmp(cncode, "LOG10", 8L, 5L) == 0) {
02394             i__2 = ivtop;
02395             for (iv = ivbot; iv <= i__2; ++iv) {
02396                 if (r8_eval__[iv - ibv + (neval << 6) - 65] != 0.) {
02397                     d__2 = (d__1 = r8_eval__[iv - ibv + (neval << 6) - 65], 
02398                             abs(d__1));
02399                     r8_eval__[iv - ibv + (neval << 6) - 65] = d_lg10(&d__2);
02400                 }
02401             }
02402 /* ...............................................................
02403 ........ */
02404         } else if (s_cmp(cncode, "INT", 8L, 3L) == 0) {
02405             i__2 = ivtop;
02406             for (iv = ivbot; iv <= i__2; ++iv) {
02407                 r8_eval__[iv - ibv + (neval << 6) - 65] = d_int(&r8_eval__[iv 
02408                         - ibv + (neval << 6) - 65]);
02409             }
02410 /* ...............................................................
02411 ........ */
02412         } else if (s_cmp(cncode, "MAX", 8L, 3L) == 0) {
02413             --neval;
02414             i__2 = ivtop;
02415             for (iv = ivbot; iv <= i__2; ++iv) {
02416 /* Computing MAX */
02417                 d__1 = r8_eval__[iv - ibv + (neval << 6) - 65], d__2 = 
02418                         r8_eval__[iv - ibv + (neval + 1 << 6) - 65];
02419                 r8_eval__[iv - ibv + (neval << 6) - 65] = max(d__1,d__2);
02420             }
02421 /* ...............................................................
02422 ........ */
02423         } else if (s_cmp(cncode, "MIN", 8L, 3L) == 0) {
02424             --neval;
02425             i__2 = ivtop;
02426             for (iv = ivbot; iv <= i__2; ++iv) {
02427 /* Computing MIN */
02428                 d__1 = r8_eval__[iv - ibv + (neval << 6) - 65], d__2 = 
02429                         r8_eval__[iv - ibv + (neval + 1 << 6) - 65];
02430                 r8_eval__[iv - ibv + (neval << 6) - 65] = min(d__1,d__2);
02431             }
02432 /* ...............................................................
02433 ........ */
02434         } else if (s_cmp(cncode, "ASIN", 8L, 4L) == 0) {
02435             i__2 = ivtop;
02436             for (iv = ivbot; iv <= i__2; ++iv) {
02437                 if ((d__1 = r8_eval__[iv - ibv + (neval << 6) - 65], abs(d__1)
02438                         ) <= 1.) {
02439                     r8_eval__[iv - ibv + (neval << 6) - 65] = asin(r8_eval__[
02440                             iv - ibv + (neval << 6) - 65]);
02441                 }
02442             }
02443 /* ...............................................................
02444 ........ */
02445         } else if (s_cmp(cncode, "ACOS", 8L, 4L) == 0) {
02446             i__2 = ivtop;
02447             for (iv = ivbot; iv <= i__2; ++iv) {
02448                 if ((d__1 = r8_eval__[iv - ibv + (neval << 6) - 65], abs(d__1)
02449                         ) <= 1.) {
02450                     r8_eval__[iv - ibv + (neval << 6) - 65] = acos(r8_eval__[
02451                             iv - ibv + (neval << 6) - 65]);
02452                 }
02453             }
02454 /* ...............................................................
02455 ........ */
02456         } else if (s_cmp(cncode, "ATAN", 8L, 4L) == 0) {
02457             i__2 = ivtop;
02458             for (iv = ivbot; iv <= i__2; ++iv) {
02459                 r8_eval__[iv - ibv + (neval << 6) - 65] = atan(r8_eval__[iv - 
02460                         ibv + (neval << 6) - 65]);
02461             }
02462 /* ...............................................................
02463 ........ */
02464         } else if (s_cmp(cncode, "ATAN2", 8L, 5L) == 0) {
02465             --neval;
02466             i__2 = ivtop;
02467             for (iv = ivbot; iv <= i__2; ++iv) {
02468                 if (r8_eval__[iv - ibv + (neval << 6) - 65] != 0. && 
02469                         r8_eval__[iv - ibv + (neval + 1 << 6) - 65] != 0.) {
02470                     r8_eval__[iv - ibv + (neval << 6) - 65] = atan2(r8_eval__[
02471                             iv - ibv + (neval << 6) - 65], r8_eval__[iv - ibv 
02472                             + (neval + 1 << 6) - 65]);
02473                 }
02474             }
02475 /* ...............................................................
02476 ........ */
02477         } else if (s_cmp(cncode, "GRAN", 8L, 4L) == 0) {
02478             --neval;
02479             i__2 = ivtop;
02480             for (iv = ivbot; iv <= i__2; ++iv) {
02481                 r8_eval__[iv - ibv + (neval << 6) - 65] = gran_(&r8_eval__[iv 
02482                         - ibv + (neval << 6) - 65], &r8_eval__[iv - ibv + (
02483                         neval + 1 << 6) - 65]);
02484             }
02485 /* ...............................................................
02486 ........ */
02487         } else if (s_cmp(cncode, "URAN", 8L, 4L) == 0) {
02488             i__2 = ivtop;
02489             for (iv = ivbot; iv <= i__2; ++iv) {
02490                 r8_eval__[iv - ibv + (neval << 6) - 65] = uran_(&r8_eval__[iv 
02491                         - ibv + (neval << 6) - 65]);
02492             }
02493 /* ...............................................................
02494 ........ */
02495         } else if (s_cmp(cncode, "IRAN", 8L, 4L) == 0) {
02496             i__2 = ivtop;
02497             for (iv = ivbot; iv <= i__2; ++iv) {
02498                 r8_eval__[iv - ibv + (neval << 6) - 65] = iran_(&r8_eval__[iv 
02499                         - ibv + (neval << 6) - 65]);
02500             }
02501 /* ...............................................................
02502 ........ */
02503         } else if (s_cmp(cncode, "ERAN", 8L, 4L) == 0) {
02504             i__2 = ivtop;
02505             for (iv = ivbot; iv <= i__2; ++iv) {
02506                 r8_eval__[iv - ibv + (neval << 6) - 65] = eran_(&r8_eval__[iv 
02507                         - ibv + (neval << 6) - 65]);
02508             }
02509 /* ...............................................................
02510 ........ */
02511         } else if (s_cmp(cncode, "LRAN", 8L, 4L) == 0) {
02512             i__2 = ivtop;
02513             for (iv = ivbot; iv <= i__2; ++iv) {
02514                 r8_eval__[iv - ibv + (neval << 6) - 65] = lran_(&r8_eval__[iv 
02515                         - ibv + (neval << 6) - 65]);
02516             }
02517 /* ...............................................................
02518 ........ */
02519         } else if (s_cmp(cncode, "PLEG", 8L, 4L) == 0) {
02520             --neval;
02521             i__2 = ivtop;
02522             for (iv = ivbot; iv <= i__2; ++iv) {
02523                 r8_eval__[iv - ibv + (neval << 6) - 65] = legendre_(&
02524                         r8_eval__[iv - ibv + (neval << 6) - 65], &r8_eval__[
02525                         iv - ibv + (neval + 1 << 6) - 65]);
02526             }
02527 /* ...............................................................
02528 ........ */
02529         } else if (s_cmp(cncode, "SINH", 8L, 4L) == 0) {
02530             i__2 = ivtop;
02531             for (iv = ivbot; iv <= i__2; ++iv) {
02532                 if ((d__1 = r8_eval__[iv - ibv + (neval << 6) - 65], abs(d__1)
02533                         ) < 87.5f) {
02534                     r8_eval__[iv - ibv + (neval << 6) - 65] = sinh(r8_eval__[
02535                             iv - ibv + (neval << 6) - 65]);
02536                 }
02537             }
02538 /* ...............................................................
02539 ........ */
02540         } else if (s_cmp(cncode, "COSH", 8L, 4L) == 0) {
02541             i__2 = ivtop;
02542             for (iv = ivbot; iv <= i__2; ++iv) {
02543                 if ((d__1 = r8_eval__[iv - ibv + (neval << 6) - 65], abs(d__1)
02544                         ) < 87.5f) {
02545                     r8_eval__[iv - ibv + (neval << 6) - 65] = cosh(r8_eval__[
02546                             iv - ibv + (neval << 6) - 65]);
02547                 }
02548             }
02549 /* ...............................................................
02550 ........ */
02551         } else if (s_cmp(cncode, "TANH", 8L, 4L) == 0) {
02552             i__2 = ivtop;
02553             for (iv = ivbot; iv <= i__2; ++iv) {
02554                 r8_eval__[iv - ibv + (neval << 6) - 65] = tanh(r8_eval__[iv - 
02555                         ibv + (neval << 6) - 65]);
02556             }
02557 /* ...............................................................
02558 ........ */
02559         } else if (s_cmp(cncode, "ASINH", 8L, 5L) == 0) {
02560             i__2 = ivtop;
02561             for (iv = ivbot; iv <= i__2; ++iv) {
02562                 x = (d__1 = r8_eval__[iv - ibv + (neval << 6) - 65], abs(d__1)
02563                         );
02564                 if (x <= 10.) {
02565 /* Computing 2nd power */
02566                     d__1 = x;
02567                     y = x + sqrt(d__1 * d__1 + 1.);
02568                 } else {
02569 /* Computing 2nd power */
02570                     d__1 = 1. / x;
02571                     y = x * (sqrt(d__1 * d__1 + 1.) + 1.);
02572                 }
02573                 y = log(y);
02574                 if (r8_eval__[iv - ibv + (neval << 6) - 65] < 0.) {
02575                     r8_eval__[iv - ibv + (neval << 6) - 65] = -y;
02576                 } else {
02577                     r8_eval__[iv - ibv + (neval << 6) - 65] = y;
02578                 }
02579             }
02580 /* ...............................................................
02581 ........ */
02582         } else if (s_cmp(cncode, "ACOSH", 8L, 5L) == 0) {
02583             i__2 = ivtop;
02584             for (iv = ivbot; iv <= i__2; ++iv) {
02585                 x = r8_eval__[iv - ibv + (neval << 6) - 65];
02586                 if (x >= 1.) {
02587                     if (x <= 10.) {
02588 /* Computing 2nd power */
02589                         d__1 = x;
02590                         y = x + sqrt(d__1 * d__1 - 1.);
02591                     } else {
02592 /* Computing 2nd power */
02593                         d__1 = 1. / x;
02594                         y = x * (sqrt(1. - d__1 * d__1) + 1.);
02595                     }
02596                     r8_eval__[iv - ibv + (neval << 6) - 65] = log(y);
02597                 }
02598             }
02599 /* ...............................................................
02600 ........ */
02601         } else if (s_cmp(cncode, "ATANH", 8L, 5L) == 0) {
02602             i__2 = ivtop;
02603             for (iv = ivbot; iv <= i__2; ++iv) {
02604                 x = r8_eval__[iv - ibv + (neval << 6) - 65];
02605                 if (abs(x) < 1.) {
02606                     r8_eval__[iv - ibv + (neval << 6) - 65] = log((x + 1.) / (
02607                             1. - x)) * .5;
02608                 }
02609             }
02610 /* ...............................................................
02611 ........ */
02612         } else if (s_cmp(cncode, "AI", 8L, 2L) == 0) {
02613             i__2 = ivtop;
02614             for (iv = ivbot; iv <= i__2; ++iv) {
02615                 r8_eval__[iv - ibv + (neval << 6) - 65] = dai_(&r8_eval__[iv 
02616                         - ibv + (neval << 6) - 65]);
02617             }
02618 /* ...............................................................
02619 ........ */
02620         } else if (s_cmp(cncode, "BI", 8L, 2L) == 0) {
02621             i__2 = ivtop;
02622             for (iv = ivbot; iv <= i__2; ++iv) {
02623                 r8_eval__[iv - ibv + (neval << 6) - 65] = dbi_(&r8_eval__[iv 
02624                         - ibv + (neval << 6) - 65], &c__1);
02625             }
02626 /* ...............................................................
02627 ........ */
02628         } else if (s_cmp(cncode, "ERF", 8L, 3L) == 0) {
02629             i__2 = ivtop;
02630             for (iv = ivbot; iv <= i__2; ++iv) {
02631                 r8_eval__[iv - ibv + (neval << 6) - 65] = derf_(&r8_eval__[iv 
02632                         - ibv + (neval << 6) - 65]);
02633             }
02634         } else if (s_cmp(cncode, "ERFC", 8L, 4L) == 0) {
02635             i__2 = ivtop;
02636             for (iv = ivbot; iv <= i__2; ++iv) {
02637                 r8_eval__[iv - ibv + (neval << 6) - 65] = derfc_(&r8_eval__[
02638                         iv - ibv + (neval << 6) - 65]);
02639             }
02640 /* ...............................................................
02641 ........ */
02642         } else if (s_cmp(cncode, "GAMMA", 8L, 5L) == 0) {
02643             i__2 = ivtop;
02644             for (iv = ivbot; iv <= i__2; ++iv) {
02645                 r8_eval__[iv - ibv + (neval << 6) - 65] = dgamma_(&r8_eval__[
02646                         iv - ibv + (neval << 6) - 65]);
02647             }
02648 /* ...............................................................
02649 ........ */
02650         } else if (s_cmp(cncode, "I0", 8L, 2L) == 0) {
02651             i__2 = ivtop;
02652             for (iv = ivbot; iv <= i__2; ++iv) {
02653                 r8_eval__[iv - ibv + (neval << 6) - 65] = dbesi0_(&r8_eval__[
02654                         iv - ibv + (neval << 6) - 65]);
02655             }
02656         } else if (s_cmp(cncode, "I1", 8L, 2L) == 0) {
02657             i__2 = ivtop;
02658             for (iv = ivbot; iv <= i__2; ++iv) {
02659                 r8_eval__[iv - ibv + (neval << 6) - 65] = dbesi1_(&r8_eval__[
02660                         iv - ibv + (neval << 6) - 65]);
02661             }
02662 /* ...............................................................
02663 ........ */
02664         } else if (s_cmp(cncode, "J0", 8L, 2L) == 0) {
02665             i__2 = ivtop;
02666             for (iv = ivbot; iv <= i__2; ++iv) {
02667                 r8_eval__[iv - ibv + (neval << 6) - 65] = dbesj0_(&r8_eval__[
02668                         iv - ibv + (neval << 6) - 65]);
02669             }
02670         } else if (s_cmp(cncode, "J1", 8L, 2L) == 0) {
02671             i__2 = ivtop;
02672             for (iv = ivbot; iv <= i__2; ++iv) {
02673                 r8_eval__[iv - ibv + (neval << 6) - 65] = dbesj1_(&r8_eval__[
02674                         iv - ibv + (neval << 6) - 65]);
02675             }
02676 /* ...............................................................
02677 ........ */
02678         } else if (s_cmp(cncode, "K0", 8L, 2L) == 0) {
02679             i__2 = ivtop;
02680             for (iv = ivbot; iv <= i__2; ++iv) {
02681                 r8_eval__[iv - ibv + (neval << 6) - 65] = dbesk0_(&r8_eval__[
02682                         iv - ibv + (neval << 6) - 65]);
02683             }
02684         } else if (s_cmp(cncode, "K1", 8L, 2L) == 0) {
02685             i__2 = ivtop;
02686             for (iv = ivbot; iv <= i__2; ++iv) {
02687                 r8_eval__[iv - ibv + (neval << 6) - 65] = dbesk1_(&r8_eval__[
02688                         iv - ibv + (neval << 6) - 65]);
02689             }
02690 /* ...............................................................
02691 ........ */
02692         } else if (s_cmp(cncode, "Y0", 8L, 2L) == 0) {
02693             i__2 = ivtop;
02694             for (iv = ivbot; iv <= i__2; ++iv) {
02695                 r8_eval__[iv - ibv + (neval << 6) - 65] = dbesy0_(&r8_eval__[
02696                         iv - ibv + (neval << 6) - 65]);
02697             }
02698         } else if (s_cmp(cncode, "Y1", 8L, 2L) == 0) {
02699             i__2 = ivtop;
02700             for (iv = ivbot; iv <= i__2; ++iv) {
02701                 r8_eval__[iv - ibv + (neval << 6) - 65] = dbesy1_(&r8_eval__[
02702                         iv - ibv + (neval << 6) - 65]);
02703             }
02704 /* ...............................................................
02705 ........ */
02706         } else if (s_cmp(cncode, "QG", 8L, 2L) == 0) {
02707             i__2 = ivtop;
02708             for (iv = ivbot; iv <= i__2; ++iv) {
02709                 r8_eval__[iv - ibv + (neval << 6) - 65] = qg_(&r8_eval__[iv - 
02710                         ibv + (neval << 6) - 65]);
02711             }
02712         } else if (s_cmp(cncode, "QGINV", 8L, 5L) == 0) {
02713             i__2 = ivtop;
02714             for (iv = ivbot; iv <= i__2; ++iv) {
02715                 r8_eval__[iv - ibv + (neval << 6) - 65] = qginv_(&r8_eval__[
02716                         iv - ibv + (neval << 6) - 65]);
02717             }
02718         } else if (s_cmp(cncode, "BELL2", 8L, 5L) == 0) {
02719             i__2 = ivtop;
02720             for (iv = ivbot; iv <= i__2; ++iv) {
02721                 r8_eval__[iv - ibv + (neval << 6) - 65] = bell2_(&r8_eval__[
02722                         iv - ibv + (neval << 6) - 65]);
02723             }
02724         } else if (s_cmp(cncode, "RECT", 8L, 4L) == 0) {
02725             i__2 = ivtop;
02726             for (iv = ivbot; iv <= i__2; ++iv) {
02727                 r8_eval__[iv - ibv + (neval << 6) - 65] = rect_(&r8_eval__[iv 
02728                         - ibv + (neval << 6) - 65]);
02729             }
02730         } else if (s_cmp(cncode, "STEP", 8L, 4L) == 0) {
02731             i__2 = ivtop;
02732             for (iv = ivbot; iv <= i__2; ++iv) {
02733                 r8_eval__[iv - ibv + (neval << 6) - 65] = step_(&r8_eval__[iv 
02734                         - ibv + (neval << 6) - 65]);
02735             }
02736         } else if (s_cmp(cncode, "TENT", 8L, 4L) == 0) {
02737             i__2 = ivtop;
02738             for (iv = ivbot; iv <= i__2; ++iv) {
02739                 r8_eval__[iv - ibv + (neval << 6) - 65] = tent_(&r8_eval__[iv 
02740                         - ibv + (neval << 6) - 65]);
02741             }
02742         } else if (s_cmp(cncode, "BOOL", 8L, 4L) == 0) {
02743             i__2 = ivtop;
02744             for (iv = ivbot; iv <= i__2; ++iv) {
02745                 r8_eval__[iv - ibv + (neval << 6) - 65] = bool_(&r8_eval__[iv 
02746                         - ibv + (neval << 6) - 65]);
02747             }
02748         } else if (s_cmp(cncode, "ZTONE", 8L, 5L) == 0) {
02749             i__2 = ivtop;
02750             for (iv = ivbot; iv <= i__2; ++iv) {
02751                 r8_eval__[iv - ibv + (neval << 6) - 65] = ztone_(&r8_eval__[
02752                         iv - ibv + (neval << 6) - 65]);
02753             }
02754 /* ...............................................................
02755 ........ */
02756         } else if (s_cmp(cncode, "NOTZERO", 8L, 7L) == 0) {
02757             i__2 = ivtop;
02758             for (iv = ivbot; iv <= i__2; ++iv) {
02759                 r8_eval__[iv - ibv + (neval << 6) - 65] = bool_(&r8_eval__[iv 
02760                         - ibv + (neval << 6) - 65]);
02761             }
02762         } else if (s_cmp(cncode, "ISZERO", 8L, 6L) == 0) {
02763             i__2 = ivtop;
02764             for (iv = ivbot; iv <= i__2; ++iv) {
02765                 r8_eval__[iv - ibv + (neval << 6) - 65] = 1. - bool_(&
02766                         r8_eval__[iv - ibv + (neval << 6) - 65]);
02767             }
02768         } else if (s_cmp(cncode, "EQUALS", 8L, 6L) == 0) {
02769             --neval;
02770             i__2 = ivtop;
02771             for (iv = ivbot; iv <= i__2; ++iv) {
02772                 d__1 = r8_eval__[iv - ibv + (neval << 6) - 65] - r8_eval__[iv 
02773                         - ibv + (neval + 1 << 6) - 65];
02774                 r8_eval__[iv - ibv + (neval << 6) - 65] = 1. - bool_(&d__1);
02775             }
02776         } else if (s_cmp(cncode, "ISPOSITI", 8L, 8L) == 0) {
02777             i__2 = ivtop;
02778             for (iv = ivbot; iv <= i__2; ++iv) {
02779                 r8_eval__[iv - ibv + (neval << 6) - 65] = step_(&r8_eval__[iv 
02780                         - ibv + (neval << 6) - 65]);
02781             }
02782         } else if (s_cmp(cncode, "ISNEGATI", 8L, 8L) == 0) {
02783             i__2 = ivtop;
02784             for (iv = ivbot; iv <= i__2; ++iv) {
02785                 d__1 = -r8_eval__[iv - ibv + (neval << 6) - 65];
02786                 r8_eval__[iv - ibv + (neval << 6) - 65] = step_(&d__1);
02787             }
02788 /* ...............................................................
02789 ........ */
02790         } else if (s_cmp(cncode, "AND", 8L, 3L) == 0) {
02791             ntm = (integer) r8_eval__[(neval << 6) - 64];
02792             neval -= ntm;
02793             i__2 = ivtop;
02794             for (iv = ivbot; iv <= i__2; ++iv) {
02795                 i__3 = ntm;
02796                 for (jtm = 1; jtm <= i__3; ++jtm) {
02797                     scop[jtm - 1] = r8_eval__[iv - ibv + (neval + jtm - 1 << 
02798                             6) - 65];
02799                 }
02800                 r8_eval__[iv - ibv + (neval << 6) - 65] = land_(&ntm, scop);
02801             }
02802         } else if (s_cmp(cncode, "MEDIAN", 8L, 6L) == 0) {
02803             ntm = (integer) r8_eval__[(neval << 6) - 64];
02804             neval -= ntm;
02805             i__2 = ivtop;
02806             for (iv = ivbot; iv <= i__2; ++iv) {
02807                 i__3 = ntm;
02808                 for (jtm = 1; jtm <= i__3; ++jtm) {
02809                     scop[jtm - 1] = r8_eval__[iv - ibv + (neval + jtm - 1 << 
02810                             6) - 65];
02811                 }
02812                 r8_eval__[iv - ibv + (neval << 6) - 65] = median_(&ntm, scop);
02813             }
02814         } else if (s_cmp(cncode, "MAD", 8L, 3L) == 0) {
02815             ntm = (integer) r8_eval__[(neval << 6) - 64];
02816             neval -= ntm;
02817             i__2 = ivtop;
02818             for (iv = ivbot; iv <= i__2; ++iv) {
02819                 i__3 = ntm;
02820                 for (jtm = 1; jtm <= i__3; ++jtm) {
02821                     scop[jtm - 1] = r8_eval__[iv - ibv + (neval + jtm - 1 << 
02822                             6) - 65];
02823                 }
02824                 r8_eval__[iv - ibv + (neval << 6) - 65] = mad_(&ntm, scop);
02825             }
02826         } else if (s_cmp(cncode, "MEAN", 8L, 4L) == 0) {
02827             ntm = (integer) r8_eval__[(neval << 6) - 64];
02828             neval -= ntm;
02829             i__2 = ivtop;
02830             for (iv = ivbot; iv <= i__2; ++iv) {
02831                 i__3 = ntm;
02832                 for (jtm = 1; jtm <= i__3; ++jtm) {
02833                     scop[jtm - 1] = r8_eval__[iv - ibv + (neval + jtm - 1 << 
02834                             6) - 65];
02835                 }
02836                 r8_eval__[iv - ibv + (neval << 6) - 65] = mean_(&ntm, scop);
02837             }
02838         } else if (s_cmp(cncode, "STDEV", 8L, 5L) == 0) {
02839             ntm = (integer) r8_eval__[(neval << 6) - 64];
02840             neval -= ntm;
02841             i__2 = ivtop;
02842             for (iv = ivbot; iv <= i__2; ++iv) {
02843                 i__3 = ntm;
02844                 for (jtm = 1; jtm <= i__3; ++jtm) {
02845                     scop[jtm - 1] = r8_eval__[iv - ibv + (neval + jtm - 1 << 
02846                             6) - 65];
02847                 }
02848                 r8_eval__[iv - ibv + (neval << 6) - 65] = stdev_(&ntm, scop);
02849             }
02850         } else if (s_cmp(cncode, "SEM", 8L, 3L) == 0) {
02851             ntm = (integer) r8_eval__[(neval << 6) - 64];
02852             neval -= ntm;
02853             i__2 = ivtop;
02854             for (iv = ivbot; iv <= i__2; ++iv) {
02855                 i__3 = ntm;
02856                 for (jtm = 1; jtm <= i__3; ++jtm) {
02857                     scop[jtm - 1] = r8_eval__[iv - ibv + (neval + jtm - 1 << 
02858                             6) - 65];
02859                 }
02860                 r8_eval__[iv - ibv + (neval << 6) - 65] = sem_(&ntm, scop);
02861             }
02862         } else if (s_cmp(cncode, "ORSTAT", 8L, 6L) == 0) {
02863             ntm = (integer) r8_eval__[(neval << 6) - 64];
02864             neval -= ntm;
02865             --ntm;
02866             i__2 = ivtop;
02867             for (iv = ivbot; iv <= i__2; ++iv) {
02868                 itm = (integer) r8_eval__[iv - ibv + (neval << 6) - 65];
02869                 i__3 = ntm;
02870                 for (jtm = 1; jtm <= i__3; ++jtm) {
02871                     scop[jtm - 1] = r8_eval__[iv - ibv + (neval + jtm << 6) - 
02872                             65];
02873                 }
02874                 r8_eval__[iv - ibv + (neval << 6) - 65] = orstat_(&itm, &ntm, 
02875                         scop);
02876             }
02877         } else if (s_cmp(cncode, "HMODE", 8L, 5L) == 0) {
02878             ntm = (integer) r8_eval__[(neval << 6) - 64];
02879             neval -= ntm;
02880             i__2 = ivtop;
02881             for (iv = ivbot; iv <= i__2; ++iv) {
02882                 i__3 = ntm;
02883                 for (jtm = 1; jtm <= i__3; ++jtm) {
02884                     scop[jtm - 1] = r8_eval__[iv - ibv + (neval + jtm - 1 << 
02885                             6) - 65];
02886                 }
02887                 r8_eval__[iv - ibv + (neval << 6) - 65] = hmode_(&ntm, scop);
02888             }
02889         } else if (s_cmp(cncode, "LMODE", 8L, 5L) == 0) {
02890             ntm = (integer) r8_eval__[(neval << 6) - 64];
02891             neval -= ntm;
02892             i__2 = ivtop;
02893             for (iv = ivbot; iv <= i__2; ++iv) {
02894                 i__3 = ntm;
02895                 for (jtm = 1; jtm <= i__3; ++jtm) {
02896                     scop[jtm - 1] = r8_eval__[iv - ibv + (neval + jtm - 1 << 
02897                             6) - 65];
02898                 }
02899                 r8_eval__[iv - ibv + (neval << 6) - 65] = lmode_(&ntm, scop);
02900             }
02901         } else if (s_cmp(cncode, "OR", 8L, 2L) == 0) {
02902             ntm = (integer) r8_eval__[(neval << 6) - 64];
02903             neval -= ntm;
02904             i__2 = ivtop;
02905             for (iv = ivbot; iv <= i__2; ++iv) {
02906                 i__3 = ntm;
02907                 for (jtm = 1; jtm <= i__3; ++jtm) {
02908                     scop[jtm - 1] = r8_eval__[iv - ibv + (neval + jtm - 1 << 
02909                             6) - 65];
02910                 }
02911                 r8_eval__[iv - ibv + (neval << 6) - 65] = lor_(&ntm, scop);
02912             }
02913         } else if (s_cmp(cncode, "MOFN", 8L, 4L) == 0) {
02914             ntm = (integer) r8_eval__[(neval << 6) - 64];
02915             neval -= ntm;
02916             --ntm;
02917             i__2 = ivtop;
02918             for (iv = ivbot; iv <= i__2; ++iv) {
02919                 itm = (integer) r8_eval__[iv - ibv + (neval << 6) - 65];
02920                 i__3 = ntm;
02921                 for (jtm = 1; jtm <= i__3; ++jtm) {
02922                     scop[jtm - 1] = r8_eval__[iv - ibv + (neval + jtm << 6) - 
02923                             65];
02924                 }
02925                 r8_eval__[iv - ibv + (neval << 6) - 65] = lmofn_(&itm, &ntm, 
02926                         scop);
02927             }
02928         } else if (s_cmp(cncode, "ASTEP", 8L, 5L) == 0) {
02929             --neval;
02930             i__2 = ivtop;
02931             for (iv = ivbot; iv <= i__2; ++iv) {
02932                 if ((d__1 = r8_eval__[iv - ibv + (neval << 6) - 65], abs(d__1)
02933                         ) > r8_eval__[iv - ibv + (neval + 1 << 6) - 65]) {
02934                     r8_eval__[iv - ibv + (neval << 6) - 65] = 1.;
02935                 } else {
02936                     r8_eval__[iv - ibv + (neval << 6) - 65] = 0.;
02937                 }
02938             }
02939         } else if (s_cmp(cncode, "ARGMAX", 8L, 6L) == 0) {
02940             ntm = (integer) r8_eval__[(neval << 6) - 64];
02941             neval -= ntm;
02942             i__2 = ivtop;
02943             for (iv = ivbot; iv <= i__2; ++iv) {
02944                 i__3 = ntm;
02945                 for (jtm = 1; jtm <= i__3; ++jtm) {
02946                     scop[jtm - 1] = r8_eval__[iv - ibv + (neval + jtm - 1 << 
02947                             6) - 65];
02948                 }
02949                 r8_eval__[iv - ibv + (neval << 6) - 65] = argmax_(&ntm, scop);
02950             }
02951         } else if (s_cmp(cncode, "ARGNUM", 8L, 6L) == 0) {
02952             ntm = (integer) r8_eval__[(neval << 6) - 64];
02953             neval -= ntm;
02954             i__2 = ivtop;
02955             for (iv = ivbot; iv <= i__2; ++iv) {
02956                 i__3 = ntm;
02957                 for (jtm = 1; jtm <= i__3; ++jtm) {
02958                     scop[jtm - 1] = r8_eval__[iv - ibv + (neval + jtm - 1 << 
02959                             6) - 65];
02960                 }
02961                 r8_eval__[iv - ibv + (neval << 6) - 65] = argnum_(&ntm, scop);
02962             }
02963 /* ...............................................................
02964 ........ */
02965         } else if (s_cmp(cncode, "FICO_T2P", 8L, 8L) == 0) {
02966             neval += -3;
02967             i__2 = ivtop;
02968             for (iv = ivbot; iv <= i__2; ++iv) {
02969                 d__2 = (d__1 = r8_eval__[iv - ibv + (neval << 6) - 65], abs(
02970                         d__1));
02971                 r8_eval__[iv - ibv + (neval << 6) - 65] = ficotp_(&d__2, &
02972                         r8_eval__[iv - ibv + (neval + 1 << 6) - 65], &
02973                         r8_eval__[iv - ibv + (neval + 2 << 6) - 65], &
02974                         r8_eval__[iv - ibv + (neval + 3 << 6) - 65]);
02975             }
02976         } else if (s_cmp(cncode, "FICO_P2T", 8L, 8L) == 0) {
02977             neval += -3;
02978             i__2 = ivtop;
02979             for (iv = ivbot; iv <= i__2; ++iv) {
02980                 r8_eval__[iv - ibv + (neval << 6) - 65] = ficopt_(&r8_eval__[
02981                         iv - ibv + (neval << 6) - 65], &r8_eval__[iv - ibv + (
02982                         neval + 1 << 6) - 65], &r8_eval__[iv - ibv + (neval + 
02983                         2 << 6) - 65], &r8_eval__[iv - ibv + (neval + 3 << 6) 
02984                         - 65]);
02985             }
02986         } else if (s_cmp(cncode, "FICO_T2Z", 8L, 8L) == 0) {
02987             neval += -3;
02988             i__2 = ivtop;
02989             for (iv = ivbot; iv <= i__2; ++iv) {
02990                 r8_eval__[iv - ibv + (neval << 6) - 65] = ficotz_(&r8_eval__[
02991                         iv - ibv + (neval << 6) - 65], &r8_eval__[iv - ibv + (
02992                         neval + 1 << 6) - 65], &r8_eval__[iv - ibv + (neval + 
02993                         2 << 6) - 65], &r8_eval__[iv - ibv + (neval + 3 << 6) 
02994                         - 65]);
02995             }
02996 /* ...............................................................
02997 ........ */
02998         } else if (s_cmp(cncode, "FITT_T2P", 8L, 8L) == 0) {
02999             --neval;
03000             i__2 = ivtop;
03001             for (iv = ivbot; iv <= i__2; ++iv) {
03002                 d__2 = (d__1 = r8_eval__[iv - ibv + (neval << 6) - 65], abs(
03003                         d__1));
03004                 r8_eval__[iv - ibv + (neval << 6) - 65] = fitttp_(&d__2, &
03005                         r8_eval__[iv - ibv + (neval + 1 << 6) - 65]);
03006             }
03007         } else if (s_cmp(cncode, "FITT_P2T", 8L, 8L) == 0) {
03008             --neval;
03009             i__2 = ivtop;
03010             for (iv = ivbot; iv <= i__2; ++iv) {
03011                 r8_eval__[iv - ibv + (neval << 6) - 65] = fittpt_(&r8_eval__[
03012                         iv - ibv + (neval << 6) - 65], &r8_eval__[iv - ibv + (
03013                         neval + 1 << 6) - 65]);
03014             }
03015         } else if (s_cmp(cncode, "FITT_T2Z", 8L, 8L) == 0) {
03016             --neval;
03017             i__2 = ivtop;
03018             for (iv = ivbot; iv <= i__2; ++iv) {
03019                 r8_eval__[iv - ibv + (neval << 6) - 65] = fitttz_(&r8_eval__[
03020                         iv - ibv + (neval << 6) - 65], &r8_eval__[iv - ibv + (
03021                         neval + 1 << 6) - 65]);
03022             }
03023 /* ...............................................................
03024 ........ */
03025         } else if (s_cmp(cncode, "FIFT_T2P", 8L, 8L) == 0) {
03026             neval += -2;
03027             i__2 = ivtop;
03028             for (iv = ivbot; iv <= i__2; ++iv) {
03029                 r8_eval__[iv - ibv + (neval << 6) - 65] = fifttp_(&r8_eval__[
03030                         iv - ibv + (neval << 6) - 65], &r8_eval__[iv - ibv + (
03031                         neval + 1 << 6) - 65], &r8_eval__[iv - ibv + (neval + 
03032                         2 << 6) - 65]);
03033             }
03034         } else if (s_cmp(cncode, "FIFT_P2T", 8L, 8L) == 0) {
03035             neval += -2;
03036             i__2 = ivtop;
03037             for (iv = ivbot; iv <= i__2; ++iv) {
03038                 r8_eval__[iv - ibv + (neval << 6) - 65] = fiftpt_(&r8_eval__[
03039                         iv - ibv + (neval << 6) - 65], &r8_eval__[iv - ibv + (
03040                         neval + 1 << 6) - 65], &r8_eval__[iv - ibv + (neval + 
03041                         2 << 6) - 65]);
03042             }
03043         } else if (s_cmp(cncode, "FIFT_T2Z", 8L, 8L) == 0) {
03044             neval += -2;
03045             i__2 = ivtop;
03046             for (iv = ivbot; iv <= i__2; ++iv) {
03047                 r8_eval__[iv - ibv + (neval << 6) - 65] = fifttz_(&r8_eval__[
03048                         iv - ibv + (neval << 6) - 65], &r8_eval__[iv - ibv + (
03049                         neval + 1 << 6) - 65], &r8_eval__[iv - ibv + (neval + 
03050                         2 << 6) - 65]);
03051             }
03052 /* ...............................................................
03053 ........ */
03054         } else if (s_cmp(cncode, "FIZT_T2P", 8L, 8L) == 0) {
03055             i__2 = ivtop;
03056             for (iv = ivbot; iv <= i__2; ++iv) {
03057                 d__2 = (d__1 = r8_eval__[iv - ibv + (neval << 6) - 65], abs(
03058                         d__1));
03059                 r8_eval__[iv - ibv + (neval << 6) - 65] = fizttp_(&d__2);
03060             }
03061         } else if (s_cmp(cncode, "FIZT_P2T", 8L, 8L) == 0) {
03062             i__2 = ivtop;
03063             for (iv = ivbot; iv <= i__2; ++iv) {
03064                 r8_eval__[iv - ibv + (neval << 6) - 65] = fiztpt_(&r8_eval__[
03065                         iv - ibv + (neval << 6) - 65]);
03066             }
03067         } else if (s_cmp(cncode, "FIZT_T2Z", 8L, 8L) == 0) {
03068             i__2 = ivtop;
03069             for (iv = ivbot; iv <= i__2; ++iv) {
03070                 r8_eval__[iv - ibv + (neval << 6) - 65] = fizttz_(&r8_eval__[
03071                         iv - ibv + (neval << 6) - 65]);
03072             }
03073 /* ...............................................................
03074 ........ */
03075         } else if (s_cmp(cncode, "FICT_T2P", 8L, 8L) == 0) {
03076             --neval;
03077             i__2 = ivtop;
03078             for (iv = ivbot; iv <= i__2; ++iv) {
03079                 r8_eval__[iv - ibv + (neval << 6) - 65] = ficttp_(&r8_eval__[
03080                         iv - ibv + (neval << 6) - 65], &r8_eval__[iv - ibv + (
03081                         neval + 1 << 6) - 65]);
03082             }
03083         } else if (s_cmp(cncode, "FICT_P2T", 8L, 8L) == 0) {
03084             --neval;
03085             i__2 = ivtop;
03086             for (iv = ivbot; iv <= i__2; ++iv) {
03087                 r8_eval__[iv - ibv + (neval << 6) - 65] = fictpt_(&r8_eval__[
03088                         iv - ibv + (neval << 6) - 65], &r8_eval__[iv - ibv + (
03089                         neval + 1 << 6) - 65]);
03090             }
03091         } else if (s_cmp(cncode, "FICT_T2Z", 8L, 8L) == 0) {
03092             --neval;
03093             i__2 = ivtop;
03094             for (iv = ivbot; iv <= i__2; ++iv) {
03095                 r8_eval__[iv - ibv + (neval << 6) - 65] = ficttz_(&r8_eval__[
03096                         iv - ibv + (neval << 6) - 65], &r8_eval__[iv - ibv + (
03097                         neval + 1 << 6) - 65]);
03098             }
03099 /* ...............................................................
03100 ........ */
03101         } else if (s_cmp(cncode, "FIBT_T2P", 8L, 8L) == 0) {
03102             neval += -2;
03103             i__2 = ivtop;
03104             for (iv = ivbot; iv <= i__2; ++iv) {
03105                 r8_eval__[iv - ibv + (neval << 6) - 65] = fibttp_(&r8_eval__[
03106                         iv - ibv + (neval << 6) - 65], &r8_eval__[iv - ibv + (
03107                         neval + 1 << 6) - 65], &r8_eval__[iv - ibv + (neval + 
03108                         2 << 6) - 65]);
03109             }
03110         } else if (s_cmp(cncode, "FIBT_P2T", 8L, 8L) == 0) {
03111             neval += -2;
03112             i__2 = ivtop;
03113             for (iv = ivbot; iv <= i__2; ++iv) {
03114                 r8_eval__[iv - ibv + (neval << 6) - 65] = fibtpt_(&r8_eval__[
03115                         iv - ibv + (neval << 6) - 65], &r8_eval__[iv - ibv + (
03116                         neval + 1 << 6) - 65], &r8_eval__[iv - ibv + (neval + 
03117                         2 << 6) - 65]);
03118             }
03119         } else if (s_cmp(cncode, "FIBT_T2Z", 8L, 8L) == 0) {
03120             neval += -2;
03121             i__2 = ivtop;
03122             for (iv = ivbot; iv <= i__2; ++iv) {
03123                 r8_eval__[iv - ibv + (neval << 6) - 65] = fibttz_(&r8_eval__[
03124                         iv - ibv + (neval << 6) - 65], &r8_eval__[iv - ibv + (
03125                         neval + 1 << 6) - 65], &r8_eval__[iv - ibv + (neval + 
03126                         2 << 6) - 65]);
03127             }
03128 /* ...............................................................
03129 ........ */
03130         } else if (s_cmp(cncode, "FIBN_T2P", 8L, 8L) == 0) {
03131             neval += -2;
03132             i__2 = ivtop;
03133             for (iv = ivbot; iv <= i__2; ++iv) {
03134                 r8_eval__[iv - ibv + (neval << 6) - 65] = fibntp_(&r8_eval__[
03135                         iv - ibv + (neval << 6) - 65], &r8_eval__[iv - ibv + (
03136                         neval + 1 << 6) - 65], &r8_eval__[iv - ibv + (neval + 
03137                         2 << 6) - 65]);
03138             }
03139         } else if (s_cmp(cncode, "FIBN_P2T", 8L, 8L) == 0) {
03140             neval += -2;
03141             i__2 = ivtop;
03142             for (iv = ivbot; iv <= i__2; ++iv) {
03143                 r8_eval__[iv - ibv + (neval << 6) - 65] = fibnpt_(&r8_eval__[
03144                         iv - ibv + (neval << 6) - 65], &r8_eval__[iv - ibv + (
03145                         neval + 1 << 6) - 65], &r8_eval__[iv - ibv + (neval + 
03146                         2 << 6) - 65]);
03147             }
03148         } else if (s_cmp(cncode, "FIBN_T2Z", 8L, 8L) == 0) {
03149             neval += -2;
03150             i__2 = ivtop;
03151             for (iv = ivbot; iv <= i__2; ++iv) {
03152                 r8_eval__[iv - ibv + (neval << 6) - 65] = fibntz_(&r8_eval__[
03153                         iv - ibv + (neval << 6) - 65], &r8_eval__[iv - ibv + (
03154                         neval + 1 << 6) - 65], &r8_eval__[iv - ibv + (neval + 
03155                         2 << 6) - 65]);
03156             }
03157 /* ...............................................................
03158 ........ */
03159         } else if (s_cmp(cncode, "FIGT_T2P", 8L, 8L) == 0) {
03160             neval += -2;
03161             i__2 = ivtop;
03162             for (iv = ivbot; iv <= i__2; ++iv) {
03163                 r8_eval__[iv - ibv + (neval << 6) - 65] = figttp_(&r8_eval__[
03164                         iv - ibv + (neval << 6) - 65], &r8_eval__[iv - ibv + (
03165                         neval + 1 << 6) - 65], &r8_eval__[iv - ibv + (neval + 
03166                         2 << 6) - 65]);
03167             }
03168         } else if (s_cmp(cncode, "FIGT_P2T", 8L, 8L) == 0) {
03169             neval += -2;
03170             i__2 = ivtop;
03171             for (iv = ivbot; iv <= i__2; ++iv) {
03172                 r8_eval__[iv - ibv + (neval << 6) - 65] = figtpt_(&r8_eval__[
03173                         iv - ibv + (neval << 6) - 65], &r8_eval__[iv - ibv + (
03174                         neval + 1 << 6) - 65], &r8_eval__[iv - ibv + (neval + 
03175                         2 << 6) - 65]);
03176             }
03177         } else if (s_cmp(cncode, "FIGT_T2Z", 8L, 8L) == 0) {
03178             neval += -2;
03179             i__2 = ivtop;
03180             for (iv = ivbot; iv <= i__2; ++iv) {
03181                 r8_eval__[iv - ibv + (neval << 6) - 65] = figttz_(&r8_eval__[
03182                         iv - ibv + (neval << 6) - 65], &r8_eval__[iv - ibv + (
03183                         neval + 1 << 6) - 65], &r8_eval__[iv - ibv + (neval + 
03184                         2 << 6) - 65]);
03185             }
03186 /* ...............................................................
03187 ........ */
03188         } else if (s_cmp(cncode, "FIPT_T2P", 8L, 8L) == 0) {
03189             --neval;
03190             i__2 = ivtop;
03191             for (iv = ivbot; iv <= i__2; ++iv) {
03192                 r8_eval__[iv - ibv + (neval << 6) - 65] = fipttp_(&r8_eval__[
03193                         iv - ibv + (neval << 6) - 65], &r8_eval__[iv - ibv + (
03194                         neval + 1 << 6) - 65]);
03195             }
03196         } else if (s_cmp(cncode, "FIPT_P2T", 8L, 8L) == 0) {
03197             --neval;
03198             i__2 = ivtop;
03199             for (iv = ivbot; iv <= i__2; ++iv) {
03200                 r8_eval__[iv - ibv + (neval << 6) - 65] = fiptpt_(&r8_eval__[
03201                         iv - ibv + (neval << 6) - 65], &r8_eval__[iv - ibv + (
03202                         neval + 1 << 6) - 65]);
03203             }
03204         } else if (s_cmp(cncode, "FIPT_T2Z", 8L, 8L) == 0) {
03205             --neval;
03206             i__2 = ivtop;
03207             for (iv = ivbot; iv <= i__2; ++iv) {
03208                 r8_eval__[iv - ibv + (neval << 6) - 65] = fipttz_(&r8_eval__[
03209                         iv - ibv + (neval << 6) - 65], &r8_eval__[iv - ibv + (
03210                         neval + 1 << 6) - 65]);
03211             }
03212 /* ...............................................................
03213 ........ */
03214         }
03215 /* ------------------------------------------------------------------
03216 ---- */
03217         if (ncode < *num_code__) {
03218             goto L1000;
03219         }
03220 
03221         i__2 = ivtop;
03222         for (iv = ivbot; iv <= i__2; ++iv) {
03223             vout[iv] = r8_eval__[iv - ibv + (neval << 6) - 65];
03224 /* L4990: */
03225         }
03226 
03227 /* L5000: */
03228     }
03229 /* -----------------------------------------------------------------------
03230  */
03231 L8000:
03232     return 0;
03233 } /* parevec_ */
03234 
03235 #undef r8_val__
03236 #undef c8_val__
03237 
03238 
03239 
03240 
03241 
03242 doublereal ztone_(doublereal *x)
03243 {
03244     /* System generated locals */
03245     doublereal ret_val;
03246 
03247     /* Builtin functions */
03248     double tan(doublereal), tanh(doublereal);
03249 
03250     /* Local variables */
03251     static doublereal y;
03252 
03253 /* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
03254  */
03255 
03256     if (*x <= 0.) {
03257         ret_val = 0.;
03258     } else if (*x >= 1.f) {
03259         ret_val = 1.;
03260     } else {
03261         y = (*x * 1.6 - .8) * 1.5707963267948966;
03262         ret_val = (tanh(tan(y)) + .99576486) * .50212657;
03263     }
03264     return ret_val;
03265 } /* ztone_ */
03266 
03267 
03268 
03269 
03270 doublereal qg_(doublereal *x)
03271 {
03272     /* System generated locals */
03273     doublereal ret_val, d__1;
03274 
03275     /* Local variables */
03276     extern doublereal derfc_(doublereal *);
03277 
03278 
03279 /*  Compute the reversed cdf of a Gaussian. */
03280 
03281 /* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
03282  */
03283 
03284     d__1 = *x / 1.414213562373095;
03285     ret_val = derfc_(&d__1) * .5;
03286     return ret_val;
03287 } /* qg_ */
03288 
03289 
03290 
03291 
03292 /* CC The UNIF() function is now in parser_int.c, */
03293 /* CC where it calls CCC upon the C library to do the dirty work. */
03294 
03295 /* CC      FUNCTION UNIF( XJUNK ) */
03296 /* CC      IMPLICIT REAL*8 (A-H,O-Z) */
03297 /* CC      PARAMETER ( IA = 99992 , IB = 12345 , IT = 99991 ) */
03298 /* CC      PARAMETER ( F  = 1.00009D-05 ) */
03299 /* CC      DATA IX / 271 / */
03300 /*CCC+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*/
03301 /* CC      IX = MOD( IA*IX+IB , IT ) */
03302 /* CC      UNIF = F * IX */
03303 /* CC      RETURN */
03304 /* CC      END */
03305 
03306 
03307 
03308 /* CC      FUNCTION UNIF( XJUNK ) */
03309 /* CC      IMPLICIT REAL*8 (A-H,O-Z) */
03310 /* CCC */
03311 /* CCC     FACTOR - INTEGER OF THE FORM 8*K+5 AS CLOSE AS POSSIBLE */
03312 /* CCC              TO  2**26 * (SQRT(5)-1)/2     (GOLDEN SECTION) */
03313 /* CCC     TWO28  = 2**28  (I.E. 28 SIGNIFICANT BITS FOR DEVIATES) */
03314 /* CCC */
03315 /* CC      PARAMETER ( FACTOR = 41475557.0D+00 , TWO28 = 268435456.0D+00 ) */
03316 /* CCC */
03317 /* CC      DATA R / 0.D+00 / */
03318 /* CCC */
03319 /* CCC     RETURNS SAMPLE U FROM THE  0,1 -UNIFORM DISTRIBUTION */
03320 /* CCC     BY A MULTIPLICATIVE CONGRUENTIAL GENERATOR OF THE FORM */
03321 /* CCC        R := R * FACTOR (MOD 1) . */
03322 /* CCC     IN THE FIRST CALL R IS INITIALIZED TO */
03323 /* CCC        R := IR / 2**28 , */
03324 /* CCC     WHERE IR MUST BE OF THE FORM  IR = 4*K+1. */
03325 /* CCC     THEN R ASSUMES ALL VALUES  0 < (4*K+1)/2**28 < 1 DURING */
03326 /* CCC     A FULL PERIOD 2**26 OF SUNIF. */
03327 /*CCC+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*/
03328 /* CCC */
03329 /* CC      IF( R .EQ. 0.D+00 ) R = 4000001.D+00 / TWO28 */
03330 /* CC      R    = DMOD(R*FACTOR,1.0D+00) */
03331 /* CC      UNIF = R */
03332 /* CC      RETURN */
03333 /* CC      END */
03334 
03335 
03336 
03337 doublereal iran_(doublereal *top)
03338 {
03339     /* System generated locals */
03340     doublereal ret_val, d__1;
03341 
03342     /* Builtin functions */
03343     double d_int(doublereal *);
03344 
03345     /* Local variables */
03346     extern doublereal unif_(doublereal *);
03347 
03348 
03349 /*  Return an integer uniformly distributed among 0..TOP */
03350 /* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
03351  */
03352     d__1 = (*top + 1.) * unif_(&c_b384);
03353     ret_val = d_int(&d__1);
03354     return ret_val;
03355 } /* iran_ */
03356 
03357 
03358 
03359 
03360 doublereal eran_(doublereal *top)
03361 {
03362     /* System generated locals */
03363     doublereal ret_val;
03364 
03365     /* Builtin functions */
03366     double log(doublereal);
03367 
03368     /* Local variables */
03369     extern doublereal unif_(doublereal *);
03370     static doublereal u1;
03371 
03372 
03373 /*  Return an exponentially distributed deviate: F(x) = 1-exp(-x/top) */
03374 /* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
03375  */
03376 L100:
03377     u1 = unif_(&c_b384);
03378     if (u1 <= 0.) {
03379         goto L100;
03380     }
03381     ret_val = -(*top) * log(u1);
03382     return ret_val;
03383 } /* eran_ */
03384 
03385 
03386 
03387 
03388 doublereal lran_(doublereal *top)
03389 {
03390     /* System generated locals */
03391     doublereal ret_val;
03392 
03393     /* Builtin functions */
03394     double log(doublereal);
03395 
03396     /* Local variables */
03397     extern doublereal unif_(doublereal *);
03398     static doublereal u1;
03399 
03400 
03401 /*  Return a logistically distributed deviate: F(x) = 1/[1+exp(-x/top)] */
03402 /* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
03403  */
03404 L100:
03405     u1 = unif_(&c_b384);
03406     if (u1 <= 0. || u1 >= 1.) {
03407         goto L100;
03408     }
03409     ret_val = *top * log(1. / u1 - 1.);
03410     return ret_val;
03411 } /* lran_ */
03412 
03413 
03414 
03415 
03416 doublereal uran_(doublereal *x)
03417 {
03418     /* System generated locals */
03419     doublereal ret_val;
03420 
03421     /* Local variables */
03422     extern doublereal unif_(doublereal *);
03423 
03424 
03425 /*  Return a U(0,X) random variable. */
03426 /* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
03427  */
03428 
03429     ret_val = *x * unif_(&c_b384);
03430     return ret_val;
03431 } /* uran_ */
03432 
03433 
03434 
03435 
03436 doublereal gran2_(doublereal *b, doublereal *s)
03437 {
03438     /* Initialized data */
03439 
03440     static integer ip = 0;
03441 
03442     /* System generated locals */
03443     doublereal ret_val;
03444 
03445     /* Builtin functions */
03446     double log(doublereal), sqrt(doublereal), sin(doublereal), cos(doublereal)
03447             ;
03448 
03449     /* Local variables */
03450     extern doublereal unif_(doublereal *);
03451     static doublereal u1, u2;
03452 
03453 
03454 /*  Compute a Gaussian random deviate with mean B and stdev S */
03455 
03456 /* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
03457  */
03458 
03459     if (ip == 0) {
03460 L100:
03461         u1 = unif_(&c_b384);
03462         if (u1 <= 0.) {
03463             goto L100;
03464         }
03465         u2 = unif_(&c_b384);
03466         ret_val = *b + *s * sqrt(log(u1) * -2.) * sin(u2 * 6.2831853);
03467         ip = 1;
03468     } else {
03469         ret_val = *b + *s * sqrt(log(u1) * -2.) * cos(u2 * 6.2831853);
03470         ip = 0;
03471     }
03472     return ret_val;
03473 } /* gran2_ */
03474 
03475 
03476 
03477 
03478 doublereal gran1_(doublereal *b, doublereal *s)
03479 {
03480     /* System generated locals */
03481     doublereal ret_val;
03482 
03483     /* Local variables */
03484     extern doublereal unif_(doublereal *);
03485     static doublereal g;
03486 
03487 /* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
03488  */
03489 
03490     g = unif_(&c_b398) - 6. + unif_(&c_b399) + unif_(&c_b400) + unif_(&c_b401)
03491              + unif_(&c_b402) + unif_(&c_b403) + unif_(&c_b404) + unif_(&
03492             c_b405) + unif_(&c_b406) + unif_(&c_b407) + unif_(&c_b408) + 
03493             unif_(&c_b409);
03494     ret_val = *b + *s * g;
03495     return ret_val;
03496 } /* gran1_ */
03497 
03498 
03499 
03500 
03501 doublereal gran_(doublereal *b, doublereal *s)
03502 {
03503     /* System generated locals */
03504     doublereal ret_val;
03505 
03506     /* Local variables */
03507     extern doublereal unif_(doublereal *), gran1_(doublereal *, doublereal *),
03508              gran2_(doublereal *, doublereal *);
03509     static doublereal uu;
03510 
03511 /* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
03512  */
03513 
03514     uu = unif_(&c_b384);
03515     if (uu <= .5) {
03516         ret_val = gran1_(b, s);
03517     } else {
03518         ret_val = gran2_(b, s);
03519     }
03520     return ret_val;
03521 } /* gran_ */
03522 
03523 
03524 
03525 
03526 doublereal qginv_(doublereal *p)
03527 {
03528     /* System generated locals */
03529     doublereal ret_val, d__1;
03530 
03531     /* Builtin functions */
03532     double log(doublereal), sqrt(doublereal), exp(doublereal);
03533 
03534     /* Local variables */
03535     static integer newt;
03536     extern doublereal derfc_(doublereal *);
03537     static doublereal dp, dq, dt, dx, ddq;
03538 
03539 
03540 /*  Return x such that Q(x)=P, for 0 < P < 1.  Q=reversed Gaussian cdf. */
03541 
03542 /* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
03543  */
03544 
03545     dp = *p;
03546     if (dp > .5) {
03547         dp = 1. - dp;
03548     }
03549     if (dp <= 0.) {
03550         dx = 13.;
03551         goto L8000;
03552     }
03553 
03554 /*  Step 1:  use 26.2.23 from Abramowitz and Stegun */
03555 
03556     dt = sqrt(log(dp) * -2.);
03557     dx = dt - ((dt * .010328 + .802853) * dt + 2.525517) / (((dt * .001308 + 
03558             .189269) * dt + 1.432788) * dt + 1.);
03559 
03560 /*  Step 2:  do 3 Newton steps to improve this */
03561 
03562     for (newt = 1; newt <= 3; ++newt) {
03563         d__1 = dx / 1.414213562373095;
03564         dq = derfc_(&d__1) * .5 - dp;
03565         ddq = exp(dx * -.5 * dx) / 2.506628274631;
03566         dx += dq / ddq;
03567 /* L100: */
03568     }
03569 
03570 L8000:
03571     if (*p > .5) {
03572         ret_val = -dx;
03573     } else {
03574         ret_val = dx;
03575     }
03576 
03577     return ret_val;
03578 } /* qginv_ */
03579 
03580 
03581 
03582 
03583 doublereal bell2_(doublereal *x)
03584 {
03585     /* System generated locals */
03586     doublereal ret_val, d__1;
03587 
03588     /* Local variables */
03589     static doublereal ax;
03590 
03591 /* ... */
03592     ax = abs(*x);
03593     if (ax <= .5) {
03594         ret_val = 1. - ax * 1.3333333333333333 * ax;
03595     } else if (ax <= 1.5) {
03596 /* Computing 2nd power */
03597         d__1 = 1.5 - ax;
03598         ret_val = d__1 * d__1 * .666666666666667;
03599     } else {
03600         ret_val = 0.;
03601     }
03602     return ret_val;
03603 } /* bell2_ */
03604 
03605 
03606 
03607 
03608 doublereal rect_(doublereal *x)
03609 {
03610     /* System generated locals */
03611     doublereal ret_val;
03612 
03613     /* Local variables */
03614     static doublereal ax;
03615 
03616     ax = abs(*x);
03617     if (ax <= .5) {
03618         ret_val = 1.;
03619     } else {
03620         ret_val = 0.;
03621     }
03622     return ret_val;
03623 } /* rect_ */
03624 
03625 
03626 
03627 
03628 doublereal step_(doublereal *x)
03629 {
03630     /* System generated locals */
03631     doublereal ret_val;
03632 
03633     if (*x <= 0.) {
03634         ret_val = 0.;
03635     } else {
03636         ret_val = 1.;
03637     }
03638     return ret_val;
03639 } /* step_ */
03640 
03641 
03642 
03643 
03644 doublereal tent_(doublereal *x)
03645 {
03646     /* System generated locals */
03647     doublereal ret_val;
03648 
03649     /* Local variables */
03650     static doublereal ax;
03651 
03652     ax = abs(*x);
03653     if (ax >= 1.) {
03654         ret_val = 0.;
03655     } else {
03656         ret_val = 1. - ax;
03657     }
03658     return ret_val;
03659 } /* tent_ */
03660 
03661 
03662 
03663 
03664 doublereal bool_(doublereal *x)
03665 {
03666     /* System generated locals */
03667     doublereal ret_val;
03668 
03669     if (*x == 0.) {
03670         ret_val = 0.;
03671     } else {
03672         ret_val = 1.;
03673     }
03674     return ret_val;
03675 } /* bool_ */
03676 
03677 
03678 
03679 
03680 doublereal land_(integer *n, doublereal *x)
03681 {
03682     /* System generated locals */
03683     integer i__1;
03684     doublereal ret_val;
03685 
03686     /* Local variables */
03687     static integer i__;
03688 
03689     /* Parameter adjustments */
03690     --x;
03691 
03692     /* Function Body */
03693     ret_val = 0.;
03694     i__1 = *n;
03695     for (i__ = 1; i__ <= i__1; ++i__) {
03696         if (x[i__] == 0.) {
03697             return ret_val;
03698         }
03699 /* L100: */
03700     }
03701     ret_val = 1.;
03702     return ret_val;
03703 } /* land_ */
03704 
03705 
03706 
03707 
03708 /* Subroutine */ int bsort_(integer *n, doublereal *x)
03709 {
03710     /* System generated locals */
03711     integer i__1;
03712 
03713     /* Local variables */
03714     static integer i__, it;
03715     static doublereal tmp;
03716 
03717 /* ------------------------------------  Bubble sort */
03718     /* Parameter adjustments */
03719     --x;
03720 
03721     /* Function Body */
03722 L50:
03723     it = 0;
03724     i__1 = *n;
03725     for (i__ = 2; i__ <= i__1; ++i__) {
03726         if (x[i__ - 1] > x[i__]) {
03727             tmp = x[i__];
03728             x[i__] = x[i__ - 1];
03729             x[i__ - 1] = tmp;
03730             it = 1;
03731         }
03732 /* L100: */
03733     }
03734     if (it != 0) {
03735         goto L50;
03736     }
03737     return 0;
03738 } /* bsort_ */
03739 
03740 
03741 
03742 
03743 doublereal orstat_(integer *m, integer *n, doublereal *x)
03744 {
03745     /* System generated locals */
03746     doublereal ret_val;
03747 
03748     /* Local variables */
03749     static integer i__;
03750     extern /* Subroutine */ int bsort_(integer *, doublereal *);
03751 
03752 
03753     /* Parameter adjustments */
03754     --x;
03755 
03756     /* Function Body */
03757     if (*n <= 1) {
03758         ret_val = x[1];
03759         return ret_val;
03760     }
03761 
03762     i__ = *m;
03763     if (i__ <= 0) {
03764         i__ = 1;
03765     } else if (i__ > *n) {
03766         i__ = *n;
03767     }
03768     bsort_(n, &x[1]);
03769     ret_val = x[i__];
03770     return ret_val;
03771 } /* orstat_ */
03772 
03773 
03774 
03775 
03776 doublereal mean_(integer *n, doublereal *x)
03777 {
03778     /* System generated locals */
03779     integer i__1;
03780     doublereal ret_val;
03781 
03782     /* Local variables */
03783     static integer it;
03784     static doublereal tmp;
03785 
03786 
03787     /* Parameter adjustments */
03788     --x;
03789 
03790     /* Function Body */
03791     if (*n == 1) {
03792         ret_val = x[1];
03793         return ret_val;
03794     } else if (*n == 2) {
03795         ret_val = (x[1] + x[2]) * .5;
03796         return ret_val;
03797     }
03798     tmp = 0.;
03799     i__1 = *n;
03800     for (it = 1; it <= i__1; ++it) {
03801         tmp += x[it];
03802     }
03803     ret_val = tmp / *n;
03804     return ret_val;
03805 } /* mean_ */
03806 
03807 
03808 
03809 
03810 doublereal stdev_(integer *n, doublereal *x)
03811 {
03812     /* System generated locals */
03813     integer i__1;
03814     doublereal ret_val, d__1;
03815 
03816     /* Builtin functions */
03817     double sqrt(doublereal);
03818 
03819     /* Local variables */
03820     static doublereal xbar;
03821     static integer it;
03822     static doublereal tmp;
03823 
03824 
03825     /* Parameter adjustments */
03826     --x;
03827 
03828     /* Function Body */
03829     if (*n == 1) {
03830         ret_val = 0.;
03831         return ret_val;
03832     }
03833     tmp = 0.;
03834     i__1 = *n;
03835     for (it = 1; it <= i__1; ++it) {
03836         tmp += x[it];
03837     }
03838     xbar = tmp / *n;
03839     tmp = 0.;
03840     i__1 = *n;
03841     for (it = 1; it <= i__1; ++it) {
03842 /* Computing 2nd power */
03843         d__1 = x[it] - xbar;
03844         tmp += d__1 * d__1;
03845     }
03846     ret_val = sqrt(tmp / (*n - 1.));
03847     return ret_val;
03848 } /* stdev_ */
03849 
03850 
03851 
03852 
03853 doublereal sem_(integer *n, doublereal *x)
03854 {
03855     /* System generated locals */
03856     doublereal ret_val;
03857 
03858     /* Builtin functions */
03859     double sqrt(doublereal);
03860 
03861     /* Local variables */
03862     extern doublereal stdev_(integer *, doublereal *);
03863 
03864 
03865     /* Parameter adjustments */
03866     --x;
03867 
03868     /* Function Body */
03869     ret_val = stdev_(n, &x[1]) / sqrt(*n + 1e-6);
03870     return ret_val;
03871 } /* sem_ */
03872 
03873 
03874 
03875 
03876 doublereal median_(integer *n, doublereal *x)
03877 {
03878     /* System generated locals */
03879     doublereal ret_val;
03880 
03881     /* Local variables */
03882     extern /* Subroutine */ int bsort_(integer *, doublereal *);
03883     static integer it;
03884     static doublereal tmp;
03885 
03886 
03887     /* Parameter adjustments */
03888     --x;
03889 
03890     /* Function Body */
03891     if (*n == 1) {
03892         ret_val = x[1];
03893         return ret_val;
03894     } else if (*n == 2) {
03895         ret_val = (x[1] + x[2]) * .5;
03896         return ret_val;
03897     } else if (*n == 3) {
03898         if (x[1] > x[2]) {
03899             tmp = x[2];
03900             x[2] = x[1];
03901             x[1] = tmp;
03902         }
03903         if (x[1] > x[3]) {
03904             ret_val = x[1];
03905         } else if (x[2] > x[3]) {
03906             ret_val = x[3];
03907         } else {
03908             ret_val = x[2];
03909         }
03910         return ret_val;
03911     }
03912 
03913 /* ---  sort it */
03914 
03915     bsort_(n, &x[1]);
03916 
03917 /* ---  Even N --> average of middle 2 */
03918 /* ---  Odd  N --> middle 1 */
03919 
03920     it = *n / 2;
03921     if (it << 1 == *n) {
03922         ret_val = (x[it] + x[it + 1]) * .5;
03923     } else {
03924         ret_val = x[it + 1];
03925     }
03926     return ret_val;
03927 } /* median_ */
03928 
03929 
03930 
03931 
03932 doublereal mad_(integer *n, doublereal *x)
03933 {
03934     /* System generated locals */
03935     integer i__1;
03936     doublereal ret_val, d__1;
03937 
03938     /* Local variables */
03939     extern doublereal median_(integer *, doublereal *);
03940     static integer it;
03941     static doublereal tmp;
03942 
03943 
03944     /* Parameter adjustments */
03945     --x;
03946 
03947     /* Function Body */
03948     if (*n == 1) {
03949         ret_val = 0.;
03950         return ret_val;
03951     } else if (*n == 2) {
03952         ret_val = (d__1 = x[1] - x[2], abs(d__1)) * .5;
03953         return ret_val;
03954     }
03955 
03956     tmp = median_(n, &x[1]);
03957     i__1 = *n;
03958     for (it = 1; it <= i__1; ++it) {
03959         x[it] = (d__1 = x[it] - tmp, abs(d__1));
03960 /* L100: */
03961     }
03962     ret_val = median_(n, &x[1]);
03963     return ret_val;
03964 } /* mad_ */
03965 
03966 
03967 
03968 
03969 doublereal argmax_(integer *n, doublereal *x)
03970 {
03971     /* System generated locals */
03972     integer i__1;
03973     doublereal ret_val;
03974 
03975     /* Local variables */
03976     static integer i__, it, nz;
03977     static doublereal tmp;
03978 
03979 
03980     /* Parameter adjustments */
03981     --x;
03982 
03983     /* Function Body */
03984     tmp = x[1];
03985     it = 1;
03986     nz = 0;
03987     if (tmp == 0.) {
03988         nz = 1;
03989     }
03990     i__1 = *n;
03991     for (i__ = 2; i__ <= i__1; ++i__) {
03992         if (x[i__] > tmp) {
03993             it = i__;
03994             tmp = x[i__];
03995         }
03996         if (x[i__] == 0.) {
03997             ++nz;
03998         }
03999 /* L100: */
04000     }
04001     if (nz == *n) {
04002         ret_val = 0.;
04003     } else {
04004         ret_val = (doublereal) it;
04005     }
04006     return ret_val;
04007 } /* argmax_ */
04008 
04009 
04010 
04011 
04012 doublereal argnum_(integer *n, doublereal *x)
04013 {
04014     /* System generated locals */
04015     integer i__1;
04016     doublereal ret_val;
04017 
04018     /* Local variables */
04019     static integer i__, nz;
04020 
04021 
04022     /* Parameter adjustments */
04023     --x;
04024 
04025     /* Function Body */
04026     nz = 0;
04027     i__1 = *n;
04028     for (i__ = 1; i__ <= i__1; ++i__) {
04029         if (x[i__] != 0.) {
04030             ++nz;
04031         }
04032 /* L100: */
04033     }
04034     ret_val = (doublereal) nz;
04035     return ret_val;
04036 } /* argnum_ */
04037 
04038 
04039 
04040 
04041 doublereal hmode_(integer *n, doublereal *x)
04042 {
04043     /* System generated locals */
04044     integer i__1;
04045     doublereal ret_val;
04046 
04047     /* Local variables */
04048     static integer i__;
04049     extern /* Subroutine */ int bsort_(integer *, doublereal *);
04050     static integer ib;
04051     static doublereal vb;
04052     static integer iv;
04053     static doublereal val;
04054 
04055 
04056     /* Parameter adjustments */
04057     --x;
04058 
04059     /* Function Body */
04060     if (*n == 1) {
04061         ret_val = x[1];
04062         return ret_val;
04063     }
04064 
04065     bsort_(n, &x[1]);
04066 
04067     val = x[1];
04068     iv = 1;
04069     ib = 0;
04070     i__1 = *n;
04071     for (i__ = 2; i__ <= i__1; ++i__) {
04072         if (x[i__] != val) {
04073             if (iv >= ib) {
04074                 vb = val;
04075                 ib = iv;
04076             }
04077             val = x[i__];
04078             iv = 1;
04079         } else {
04080             ++iv;
04081         }
04082 /* L100: */
04083     }
04084     if (iv >= ib) {
04085         vb = val;
04086     }
04087     ret_val = vb;
04088     return ret_val;
04089 } /* hmode_ */
04090 
04091 
04092 
04093 
04094 doublereal lmode_(integer *n, doublereal *x)
04095 {
04096     /* System generated locals */
04097     integer i__1;
04098     doublereal ret_val;
04099 
04100     /* Local variables */
04101     static integer i__;
04102     extern /* Subroutine */ int bsort_(integer *, doublereal *);
04103     static integer ib;
04104     static doublereal vb;
04105     static integer iv;
04106     static doublereal val;
04107 
04108 
04109     /* Parameter adjustments */
04110     --x;
04111 
04112     /* Function Body */
04113     if (*n == 1) {
04114         ret_val = x[1];
04115         return ret_val;
04116     }
04117 
04118     bsort_(n, &x[1]);
04119 
04120     val = x[1];
04121     iv = 1;
04122     ib = 0;
04123     i__1 = *n;
04124     for (i__ = 2; i__ <= i__1; ++i__) {
04125         if (x[i__] != val) {
04126             if (iv > ib) {
04127                 vb = val;
04128                 ib = iv;
04129             }
04130             val = x[i__];
04131             iv = 1;
04132         } else {
04133             ++iv;
04134         }
04135 /* L100: */
04136     }
04137     if (iv > ib) {
04138         vb = val;
04139     }
04140     ret_val = vb;
04141     return ret_val;
04142 } /* lmode_ */
04143 
04144 
04145 
04146 
04147 doublereal lor_(integer *n, doublereal *x)
04148 {
04149     /* System generated locals */
04150     integer i__1;
04151     doublereal ret_val;
04152 
04153     /* Local variables */
04154     static integer i__;
04155 
04156     /* Parameter adjustments */
04157     --x;
04158 
04159     /* Function Body */
04160     ret_val = 1.;
04161     i__1 = *n;
04162     for (i__ = 1; i__ <= i__1; ++i__) {
04163         if (x[i__] != 0.) {
04164             return ret_val;
04165         }
04166 /* L100: */
04167     }
04168     ret_val = 0.;
04169     return ret_val;
04170 } /* lor_ */
04171 
04172 
04173 
04174 
04175 doublereal lmofn_(integer *m, integer *n, doublereal *x)
04176 {
04177     /* System generated locals */
04178     integer i__1;
04179     doublereal ret_val;
04180 
04181     /* Local variables */
04182     static integer c__, i__;
04183 
04184     /* Parameter adjustments */
04185     --x;
04186 
04187     /* Function Body */
04188     c__ = 0;
04189     i__1 = *n;
04190     for (i__ = 1; i__ <= i__1; ++i__) {
04191         if (x[i__] != 0.) {
04192             ++c__;
04193         }
04194 /* L100: */
04195     }
04196     if (c__ >= *m) {
04197         ret_val = 1.;
04198     } else {
04199         ret_val = 0.;
04200     }
04201     return ret_val;
04202 } /* lmofn_ */
04203 
04204 
04205 
04206 
04207 doublereal dai_(doublereal *x)
04208 {
04209     /* System generated locals */
04210     doublereal ret_val;
04211 
04212     /* Local variables */
04213     extern /* Subroutine */ int qqqerr_(void);
04214 
04215     qqqerr_();
04216     ret_val = 0.;
04217     return ret_val;
04218 } /* dai_ */
04219 
04220 doublereal dbi_(doublereal *x, integer *i__)
04221 {
04222     /* System generated locals */
04223     doublereal ret_val;
04224 
04225     /* Local variables */
04226     extern /* Subroutine */ int qqqerr_(void);
04227 
04228     qqqerr_();
04229     ret_val = 0.;
04230     return ret_val;
04231 } /* dbi_ */
04232 
04233 doublereal dgamma_(doublereal *x)
04234 {
04235     /* System generated locals */
04236     doublereal ret_val;
04237 
04238     /* Local variables */
04239     extern /* Subroutine */ int qqqerr_(void);
04240 
04241     qqqerr_();
04242     ret_val = 0.;
04243     return ret_val;
04244 } /* dgamma_ */
04245 
04246 doublereal dbesi0_(doublereal *x)
04247 {
04248     /* System generated locals */
04249     doublereal ret_val;
04250 
04251     /* Local variables */
04252     extern /* Subroutine */ int qqqerr_(void);
04253 
04254     qqqerr_();
04255     ret_val = 0.;
04256     return ret_val;
04257 } /* dbesi0_ */
04258 
04259 doublereal dbesi1_(doublereal *x)
04260 {
04261     /* System generated locals */
04262     doublereal ret_val;
04263 
04264     /* Local variables */
04265     extern /* Subroutine */ int qqqerr_(void);
04266 
04267     qqqerr_();
04268     ret_val = 0.;
04269     return ret_val;
04270 } /* dbesi1_ */
04271 
04272 /* cc      REAL*8 FUNCTION  DBESJ0( X ) */
04273 /* cc      REAL*8 X */
04274 /* cc      CALL QQQERR */
04275 /* cc      END */
04276 /* cc      REAL*8 FUNCTION  DBESJ1( X ) */
04277 /* cc      REAL*8 X */
04278 /* cc      CALL QQQERR */
04279 /* cc      END */
04280 doublereal dbesk0_(doublereal *x)
04281 {
04282     /* System generated locals */
04283     doublereal ret_val;
04284 
04285     /* Local variables */
04286     extern /* Subroutine */ int qqqerr_(void);
04287 
04288     qqqerr_();
04289     ret_val = 0.;
04290     return ret_val;
04291 } /* dbesk0_ */
04292 
04293 doublereal dbesk1_(doublereal *x)
04294 {
04295     /* System generated locals */
04296     doublereal ret_val;
04297 
04298     /* Local variables */
04299     extern /* Subroutine */ int qqqerr_(void);
04300 
04301     qqqerr_();
04302     ret_val = 0.;
04303     return ret_val;
04304 } /* dbesk1_ */
04305 
04306 /* cc      REAL*8 FUNCTION  DBESY0( X ) */
04307 /* cc      REAL*8 X */
04308 /* cc      CALL QQQERR */
04309 /* cc      END */
04310 /* cc      REAL*8 FUNCTION  DBESY1( X ) */
04311 /* cc      REAL*8 X */
04312 /* cc      CALL QQQERR */
04313 /* cc      END */
04314 /* cc      REAL*8 FUNCTION  DERF( X ) */
04315 /* cc      REAL*8 X */
04316 /* cc      CALL QQQERR */
04317 /* cc      END */
04318 /* cc      REAL*8 FUNCTION  DERFC( X ) */
04319 /* cc      REAL*8 X */
04320 /* cc      CALL QQQERR */
04321 /* cc      END */
04322 
04323 /* Subroutine */ int qqqerr_(void)
04324 {
04325     /* Format strings */
04326     static char fmt_999[] = "(\002*** PARSER: unimplemented function ***\002)"
04327             ;
04328 
04329     /* Builtin functions */
04330     integer s_wsfe(cilist *), e_wsfe(void);
04331 
04332     /* Fortran I/O blocks */
04333     static cilist io___123 = { 0, 6, 0, fmt_999, 0 };
04334 
04335 
04336     s_wsfe(&io___123);
04337     e_wsfe();
04338     return 0;
04339 } /* qqqerr_ */
04340