1 /* parser.f -- translated by f2c (version 19961017).
2 You must link the resulting object file with the libraries:
3 -lf2c -lm (in that order)
4 */
5
6 #include "f2c.h"
7
8 /* Table of constant values */
9
10 static integer c__3 = 3;
11 static integer c__1 = 1;
12 static doublereal c_b433 = 0.;
13 static doublereal c_b447 = 1.;
14 static doublereal c_b448 = 2.;
15 static doublereal c_b449 = 3.;
16 static doublereal c_b450 = 4.;
17 static doublereal c_b451 = 5.;
18 static doublereal c_b452 = 6.;
19 static doublereal c_b453 = 7.;
20 static doublereal c_b454 = 8.;
21 static doublereal c_b455 = 9.;
22 static doublereal c_b456 = 10.;
23 static doublereal c_b457 = 11.;
24 static doublereal c_b458 = 12.;
25
parser_(char * c_expr__,logical * l_print__,integer * num_code__,char * c_code__,ftnlen c_expr_len,ftnlen c_code_len)26 /* Subroutine */ int parser_(char *c_expr__, logical *l_print__, integer *
27 num_code__, char *c_code__, ftnlen c_expr_len, ftnlen c_code_len)
28 {
29 /* Initialized data */
30
31 static integer n_funcargs__[123] = { 1,1,1,1,1,1,2,1,1,1,1,1,1,1,1,1,1,1,
32 1,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,
33 -1,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,
34 2,1,1,1,1,-1,1,-1,-1,-1,1,1,2,1,1,-1,-1,-1,2,5,5,-1,-1,-1,1,3,2,2,
35 1,1,2,-1,-1,-1,-1,-1,-1,3,1,4,2,2,1 };
36
37 /* Format strings */
38 static char fmt_9001[] = "(\002 PARSER error\002,i4,\002: \002,a/1x,a/80"
39 "a1)";
40
41 /* System generated locals */
42 address a__1[3];
43 integer i__1, i__2[3], i__3;
44 static doublereal equiv_0[1];
45
46 /* Builtin functions */
47 /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen), s_cat(char *,
48 char **, integer *, integer *, ftnlen);
49 integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
50
51 /* Local variables */
52 #define r8_token__ (equiv_0)
53 static integer narg, nlen, nerr, ipos, npos, nextcode, ncode;
54 static char c_message__[30];
55 static integer nfunc, nused;
56 extern /* Subroutine */ int get_token__(char *, integer *, doublereal *,
57 integer *, ftnlen);
58 static doublereal val_token__;
59 extern integer last_nonblank__(char *, ftnlen);
60 static integer nf, n_code__[2048], n_func__[40], ntoken;
61 static char c_local__[10000];
62 extern /* Subroutine */ int execute_(integer *, char *, ftnlen);
63 #define c8_token__ ((char *)equiv_0)
64 static char c_ch__[1];
65
66 /* Fortran I/O blocks */
67 static cilist io___22 = { 0, 6, 0, fmt_9001, 0 };
68
69
70
71 /* Parse the arithmetic expression in C_EXPR. The code required to */
72 /* evaluate the expression is returned in the first NUM_CODE entries */
73 /* of the CHARACTER*8 array C_CODE. If NUM_CODE is returned as zero, */
74 /* an error occurred. On input, L_PRINT determines whether or not to */
75 /* print error messages. */
76
77 /* Modified 02/17/89 by RWCox from APEVAL subroutine in APFORT, for PC.
78 */
79 /* Modified 06/29/89 by RWCox for Sun Fortran. */
80 /* Modified 04/04/91 by RWCox to fix problem with -x**2 type operations.
81 */
82 /* Modified 11/20/96 by RWCox to try to control errors in evaluation. */
83 /* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
84 */
85
86
87 /* Compilation, evaluation, and function stacks. */
88
89
90
91 /* Random local stuff */
92
93
94
95
96 /* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
97 */
98
99 /* -----------------------------------------------------------------------
100 */
101 /* Include file for PARSER. This file must be kept with PARSER.FOR. */
102 /* It defines some symbolic constants that PARSER and its subsidiary */
103 /* routines use. */
104 /* .......................................................................
105 */
106 /* Define Token types and values */
107
108
109
110 /* .......................................................................
111 */
112 /* Define the Nonterminals */
113
114
115 /* .......................................................................
116 */
117 /* Define the Opcodes */
118
119
120 /* .......................................................................
121 */
122 /* Define Function names, etc. */
123
124
125
126 /* Parameter adjustments */
127 c_code__ -= 8;
128
129 /* Function Body */
130
131 /* -----------------------------------------------------------------------
132 */
133 nlen = last_nonblank__(c_expr__, c_expr_len);
134 if (nlen <= 0 || nlen > 9999) {
135 /* !no input, or too much */
136 *num_code__ = 0;
137 goto L8000;
138 }
139
140 /* Copy input string to local, deleting blanks and converting case. */
141
142 npos = 0;
143 i__1 = nlen;
144 for (ipos = 1; ipos <= i__1; ++ipos) {
145 *(unsigned char *)c_ch__ = *(unsigned char *)&c_expr__[ipos - 1];
146 if (*(unsigned char *)c_ch__ != ' ') {
147 if (*(unsigned char *)c_ch__ >= 'a' && *(unsigned char *)c_ch__ <=
148 'z') {
149 *(unsigned char *)c_ch__ = (char) (*(unsigned char *)c_ch__ +
150 ('A' - 'a'));
151 }
152 /* !convert case */
153 ++npos;
154 *(unsigned char *)&c_local__[npos - 1] = *(unsigned char *)c_ch__;
155 }
156 /* L10: */
157 }
158 /* !tack 1 blank at the end */
159 nlen = npos + 1;
160 *(unsigned char *)&c_local__[nlen - 1] = ' ';
161 /* .......................................................................
162 */
163 /* This routine parses expressions according to the grammar: */
164
165 /* EXPR == E9 E8 E6 E4 $ */
166
167 /* E4 == <addop> E9 E8 E6 E4 | <null> */
168
169 /* E6 == <mulop> E9 E8 E6 | <null> */
170
171 /* E8 == <expop> E9 E8 | <null> */
172
173 /* E9 == <number> | <function> ( E9 E8 E6 E4 ARGTL ) */
174 /* | ( E9 E8 E6 E4 ) | <addop> E9 */
175
176 /* ARGTL == , E9 E8 E6 E4 ARGTL | <null> */
177
178 /* <addop> is + or - */
179 /* <mulop> is * or / */
180 /* <expop> is ** */
181 /* <number> is a literal number or a DCL variable */
182 /* <function> is in the list C_FUNCNAME */
183
184 /* The predictive parser described in Aho and Ullman, "Principles of */
185 /* Compiler Design" on pages 185-191 for LL(1) grammars is used here, */
186 /* with additions to perform the evaluation as the parsing proceeds. */
187 /* These consist of adding code (NC_) to the compilation stack when an */
188 /* expansion is made. When the code is popped off the stack, it is */
189 /* executed. */
190
191 /* 02/17/89: Now, when code is popped off the stack, it is just */
192 /* added to the output code list. */
193 /* .......................................................................
194 */
195 /* Prepare to process input string. Initialize the stacks, etc. */
196
197 /* !start scan at 1st character */
198 npos = 1;
199 /* !no function calls yet */
200 nfunc = 0;
201 /* !initial compile stack is E9 E8 E6 E4 $ */
202 n_code__[0] = 2000;
203 n_code__[1] = 2001;
204 n_code__[2] = 2002;
205 n_code__[3] = 2003;
206 n_code__[4] = 2004;
207 ncode = 5;
208 *num_code__ = 0;
209 /* .......................................................................
210 */
211 /* 1000 is the loop back point to process the next token in the input */
212 /* string. */
213
214 L1000:
215 get_token__(c_local__ + (npos - 1), &ntoken, &val_token__, &nused, nlen -
216 (npos - 1));
217
218 if (ntoken == 1999) {
219 nerr = 1;
220 s_copy(c_message__, "Can't interpret symbol", 30L, 22L);
221 goto L9000;
222 /* !error exit */
223 }
224
225 /* At 2000, process the next compile code until the token is used up. */
226
227 L2000:
228 nextcode = n_code__[ncode - 1];
229
230 /* If next entry on the compile stack is an opcode, then apply it to */
231 /* the evaluation stack. */
232 /* 02/17/89: just add it to the output */
233
234 if (nextcode >= 3000 && nextcode <= 4999) {
235 ++(*num_code__);
236 execute_(&nextcode, c_code__ + (*num_code__ << 3), 8L);
237 --ncode;
238 /* !remove opcode from compile stack */
239 goto L2000;
240 /* !loop back for next compile stack entry */
241 }
242
243 /* If next compile stack entry is a token itself, it must match the */
244 /* new token from the input. */
245
246 if (nextcode >= 1000 && nextcode <= 1999) {
247 if (nextcode == ntoken) {
248 /* !a match */
249 --ncode;
250 /* !pop token from compile stack */
251 goto L5000;
252 /* !loop back for next token */
253 }
254 nerr = 2;
255 if (nextcode == 1004) {
256 *(unsigned char *)c_ch__ = '(';
257 } else if (nextcode == 1005) {
258 *(unsigned char *)c_ch__ = ')';
259 } else if (nextcode == 1006) {
260 *(unsigned char *)c_ch__ = ',';
261 } else {
262 *(unsigned char *)c_ch__ = '?';
263 }
264 /* Writing concatenation */
265 i__2[0] = 12, a__1[0] = "Expected a \"";
266 i__2[1] = 1, a__1[1] = c_ch__;
267 i__2[2] = 1, a__1[2] = "\"";
268 s_cat(c_message__, a__1, i__2, &c__3, 30L);
269 goto L9000;
270 /* !error exit */
271 }
272
273 /* Should have a nonterminal (NN) here. */
274
275 if (nextcode < 2000 || nextcode > 2999) {
276 nerr = 3;
277 s_copy(c_message__, "Internal parser error", 30L, 21L);
278 goto L9000;
279 /* !error exit */
280 }
281
282 /* Expand the nonterminal appropriately, depending on the token. */
283 /* If no legal expansion, then stop with an error. */
284
285 /* TOKEN = end of string */
286
287 if (ntoken == 1000) {
288 if (nextcode == 2000) {
289 /* !end of string = end of expr ==> compilation done */
290 goto L8000;
291
292 } else if (nextcode == 2003 || nextcode == 2002 || nextcode == 2001) {
293 --ncode;
294 /* !expand this to nothing */
295 goto L2000;
296 /* !and try this token again */
297 }
298 nerr = 4;
299 s_copy(c_message__, "Unexpected end of input", 30L, 23L);
300 goto L9000;
301 /* !error exit */
302 }
303
304 /* Check if end of input was expected but not encountered. */
305
306 if (nextcode == 2000) {
307 nerr = 15;
308 s_copy(c_message__, "Expected end of input", 30L, 21L);
309 goto L9000;
310 /* !error exit */
311 }
312
313 /* TOKEN = number or symbol */
314 /* 02/17/89: added NT_SYMBOL token type; now, the code for */
315 /* pushing the number or symbol onto the stack is */
316 /* added to the output. */
317
318 if (ntoken == 1007 || ntoken == 1009) {
319 if (nextcode == 2004) {
320 /* !only legal time for a number */
321 if (ntoken == 1007) {
322 s_copy(c_code__ + (*num_code__ + 1 << 3), "PUSHNUM", 8L, 7L);
323 } else {
324 s_copy(c_code__ + (*num_code__ + 1 << 3), "PUSHSYM", 8L, 7L);
325 }
326 *r8_token__ = val_token__;
327 s_copy(c_code__ + (*num_code__ + 2 << 3), c8_token__, 8L, 8L);
328 *num_code__ += 2;
329 --ncode;
330 /* !pop E9 from compile stack */
331 goto L5000;
332 /* !go to next token */
333 }
334 nerr = 5;
335 s_copy(c_message__, "Expected an operator", 30L, 20L);
336 goto L9000;
337 /* !error exit */
338 }
339
340 /* TOKEN = function call */
341
342 if (ntoken == 1008) {
343 if (nextcode == 2004) {
344 /* !only legal time for a function */
345
346 n_code__[ncode + 6] = 1004;
347 /* !expand E9 into ( E9 E8 E6 E4 ARGTL ) <func> */
348 n_code__[ncode + 5] = 2004;
349 n_code__[ncode + 4] = 2003;
350 n_code__[ncode + 3] = 2002;
351 n_code__[ncode + 2] = 2001;
352 n_code__[ncode + 1] = 2005;
353 n_code__[ncode] = 1005;
354 n_code__[ncode - 1] = (integer) val_token__ + 4000;
355 ncode += 7;
356
357 nfunc += 2;
358 /* !setup function stack to check # arguments */
359 n_func__[nfunc - 2] = (integer) val_token__;
360 n_func__[nfunc - 1] = 0;
361 goto L5000;
362 /* !process next token */
363 }
364 nerr = 6;
365 s_copy(c_message__, "Expected an operator", 30L, 20L);
366 goto L9000;
367 /* !error exit */
368 }
369
370 /* TOKEN = addition operator */
371
372 if (ntoken == 1001) {
373 if (nextcode == 2001) {
374 /* !expand E4 into E9 E8 E6 <binary addop> E4 */
375 n_code__[ncode + 3] = 2004;
376 n_code__[ncode + 2] = 2003;
377 n_code__[ncode + 1] = 2002;
378 if (val_token__ == 1.) {
379 n_code__[ncode] = 3001;
380 } else {
381 n_code__[ncode] = 3002;
382 }
383 n_code__[ncode - 1] = 2001;
384 ncode += 4;
385 goto L5000;
386 /* !process next token */
387
388 } else if (nextcode == 2002 || nextcode == 2003) {
389 --ncode;
390 /* !expand E6 or E8 to null and try again */
391 goto L2000;
392
393 } else if (nextcode == 2004) {
394 /* !unary + or - */
395 if (val_token__ == 2.) {
396 /*!expand E9 into E9 E8 <unary minus> if addop is - otherwise
397 leave E9 alone*/
398 /* [04/04/91 change: */
399 /* used to expand to E9 <unary minus>, which makes -x**2 beco
400 me (-x)**2] */
401 n_code__[ncode + 1] = 2004;
402 n_code__[ncode] = 2003;
403 n_code__[ncode - 1] = 3006;
404 ncode += 2;
405 }
406 goto L5000;
407 /* !process next token */
408 }
409 nerr = 7;
410 s_copy(c_message__, "Illegal arithmetic syntax", 30L, 25L);
411 goto L9000;
412 /* !error exit */
413 }
414
415 /* TOKEN = multiplying operator */
416
417 if (ntoken == 1002) {
418 if (nextcode == 2002) {
419 /* !expand E6 into E9 E8 <operator> E6 */
420 n_code__[ncode + 2] = 2004;
421 n_code__[ncode + 1] = 2003;
422 if (val_token__ == 1.) {
423 n_code__[ncode] = 3003;
424 } else {
425 n_code__[ncode] = 3004;
426 }
427 n_code__[ncode - 1] = 2002;
428 ncode += 3;
429 goto L5000;
430 /* !next token */
431
432 } else if (nextcode == 2003) {
433 /* !expand E8 to null and try this token again */
434 --ncode;
435 goto L2000;
436 }
437 nerr = 8;
438 s_copy(c_message__, "Illegal arithmetic syntax", 30L, 25L);
439 goto L9000;
440 /* !error exit */
441 }
442
443 /* TOKEN = exponentiation operator */
444
445 if (ntoken == 1003) {
446 if (nextcode == 2003) {
447 /* !expand E8 into E9 E8 <**> */
448 n_code__[ncode + 1] = 2004;
449 n_code__[ncode] = 2003;
450 n_code__[ncode - 1] = 3005;
451 ncode += 2;
452 goto L5000;
453 /* !process next token */
454 }
455 nerr = 9;
456 s_copy(c_message__, "Illegal arithmetic syntax", 30L, 25L);
457 goto L9000;
458 /* !error exit */
459 }
460
461 /* TOKEN = comma */
462
463 if (ntoken == 1006) {
464 if (nextcode == 2001 || nextcode == 2002 || nextcode == 2003) {
465
466 --ncode;
467 /* !pop this nonterminal and try this token again */
468 goto L2000;
469
470 } else if (nextcode == 2005) {
471 /* !expand ARGTL into E9 E8 E6 E4 ARGTL */
472 n_code__[ncode + 3] = 2004;
473 n_code__[ncode + 2] = 2003;
474 n_code__[ncode + 1] = 2002;
475 n_code__[ncode] = 2001;
476 n_code__[ncode - 1] = 2005;
477 ncode += 4;
478 /* !add 1 to no. of args. encountered, and check if there are too
479 many */
480 ++n_func__[nfunc - 1];
481 nf = n_func__[nfunc - 2];
482 if (n_funcargs__[nf - 1] <= n_func__[nfunc - 1] && n_funcargs__[
483 nf - 1] > 0) {
484 nerr = 12;
485 s_copy(c_message__, "Wrong number of arguments", 30L, 25L);
486 goto L9000;
487 /* !error exit */
488 }
489 goto L5000;
490 /* !process next token */
491 }
492 nerr = 10;
493 s_copy(c_message__, "Expected an expression", 30L, 22L);
494 goto L9000;
495 /* !error exit */
496 }
497
498 /* TOKEN = open parenthesis */
499
500 if (ntoken == 1004) {
501 if (nextcode == 2004) {
502 /* !expand E9 into E9 E8 E6 E4 ) */
503 n_code__[ncode + 3] = 2004;
504 n_code__[ncode + 2] = 2003;
505 n_code__[ncode + 1] = 2002;
506 n_code__[ncode] = 2001;
507 n_code__[ncode - 1] = 1005;
508 ncode += 4;
509 goto L5000;
510 /* !process next token */
511 }
512 nerr = 11;
513 s_copy(c_message__, "Expected an operator", 30L, 20L);
514 goto L9000;
515 /* !error exit */
516 }
517
518 /* TOKEN = close parenthesis */
519
520 if (ntoken == 1005) {
521 if (nextcode == 2001 || nextcode == 2002 || nextcode == 2003) {
522
523 --ncode;
524 /* !pop this nonterminal and try this token out on the next one */
525 goto L2000;
526
527 } else if (nextcode == 2005) {
528 /* !end of function call */
529
530 narg = n_func__[nfunc - 1] + 1;
531 /* !check # arguments */
532 nf = n_func__[nfunc - 2];
533 nfunc += -2;
534 if (n_funcargs__[nf - 1] <= 0) {
535 /* !variable # of args ==> push number of args on stack (Feb 1
536 997) */
537 s_copy(c_code__ + (*num_code__ + 1 << 3), "PUSHNUM", 8L, 7L);
538 *r8_token__ = (doublereal) narg;
539 s_copy(c_code__ + (*num_code__ + 2 << 3), c8_token__, 8L, 8L);
540 *num_code__ += 2;
541 } else if (n_funcargs__[nf - 1] != narg) {
542 /* !illegal # of args */
543 nerr = 12;
544 s_copy(c_message__, "Wrong number of arguments", 30L, 25L);
545 goto L9000;
546 /* !error exit */
547 }
548
549 --ncode;
550 /*!pop this nonterminal and try to match the ) with the next compi
551 le stack entry*/
552 goto L2000;
553 }
554 nerr = 13;
555 s_copy(c_message__, "Expected an expression", 30L, 22L);
556 goto L9000;
557 /* !error exit */
558 }
559 nerr = 14;
560 s_copy(c_message__, "Internal parser error", 30L, 21L);
561 goto L9000;
562 /* !error exit */
563 /* .......................................................................
564 */
565 /* At 5000, advance to the next token and loop back */
566
567 L5000:
568 npos += nused;
569 goto L1000;
570 /* .......................................................................
571 */
572 /* At 8000, exit */
573
574 L8000:
575 return 0;
576 /* .......................................................................
577 */
578 /* At 9000, error exit */
579
580 L9000:
581 if (*l_print__) {
582 if (nused < 1) {
583 nused = 1;
584 }
585 s_wsfe(&io___22);
586 do_fio(&c__1, (char *)&nerr, (ftnlen)sizeof(integer));
587 do_fio(&c__1, c_message__, 30L);
588 do_fio(&c__1, c_local__, nlen);
589 i__1 = npos;
590 for (nf = 1; nf <= i__1; ++nf) {
591 do_fio(&c__1, ".", 1L);
592 }
593 i__3 = nused;
594 for (nf = 1; nf <= i__3; ++nf) {
595 do_fio(&c__1, "#", 1L);
596 }
597 e_wsfe();
598
599 /* CC WRITE(*,9002) (N_CODE(NF),NF=NCODE,1,-1) */
600 /* CC9002 FORMAT(' Compile stack is (top down)' / 10(1X,I6) ) */
601 }
602
603 *num_code__ = 0;
604 return 0;
605 } /* parser_ */
606
607 #undef c8_token__
608 #undef r8_token__
609
610
611
612
613
execute_(integer * n_opcode__,char * c_code__,ftnlen c_code_len)614 /* Subroutine */ int execute_(integer *n_opcode__, char *c_code__, ftnlen
615 c_code_len)
616 {
617 /* Initialized data */
618
619 static char c_funcname__[32*124] = "SIN "
620 "COS " "TAN "
621 " " "ASIN " "ACOS "
622 " " "ATAN " "ATAN2 "
623 " " "SINH " "COSH "
624 " " "TANH " "ASIN"
625 "H " "ACOSH "
626 "ATANH " "EXP "
627 " " "LOG " "LOG10 "
628 " " "ABS " "INT "
629 " " "SQRT " "MAX "
630 " " "MIN " "AI "
631 " " "DAI "
632 "I0 " "I1 "
633 " " "J0 " "J1 "
634 " " "K0 " "K1 "
635 " " "Y0 " "Y1 "
636 " " "BI " "DBI "
637 " " "ERF "
638 "ERFC " "GAMMA "
639 " " "QG " "QGINV "
640 " " "BELL2 " "RECT "
641 " " "STEP " "BOOL "
642 " " "AND " "OR "
643 " " "MOFN "
644 "ASTEP " "SIND "
645 " " "COSD " "TAND "
646 " " "MEDIAN " "FICO_T2P "
647 " " "FICO_P2T " "FICO_T2Z "
648 " " "FITT_T2P " "FITT"
649 "_P2T " "FITT_T2Z "
650 "FIFT_T2P " "FIFT_P2T "
651 " " "FIFT_T2Z " "FIZT_T2P "
652 " " "FIZT_P2T " "FIZT_T2Z "
653 " " "FICT_T2P " "FICT_P2T "
654 " " "FICT_T2Z " "FIBT"
655 "_T2P " "FIBT_P2T "
656 "FIBT_T2Z " "FIBN_T2P "
657 " " "FIBN_P2T " "FIBN_T2Z "
658 " " "FIGT_T2P " "FIGT_P2T "
659 " " "FIGT_T2Z " "FIPT_T2P "
660 " " "FIPT_P2T " "FIPT"
661 "_T2Z " "ZTONE "
662 "LMODE " "HMODE "
663 " " "GRAN " "URAN "
664 " " "IRAN " "ERAN "
665 " " "LRAN " "ORSTAT "
666 " " "TENT " "MAD "
667 " " "ARGMAX "
668 "ARGNUM " "NOTZERO "
669 " " "ISZERO " "EQUALS "
670 " " "ISPOSITIVE " "ISNEGATIVE "
671 " " "MEAN " "STDEV "
672 " " "SEM " "PLEG"
673 " " "CDF2STAT "
674 "STAT2CDF " "PAIRMAX "
675 " " "PAIRMIN " "AMONGST "
676 " " "CBRT " "RHDDC2 "
677 " " "HRFBK4 " "HRFBK5 "
678 " " "POSVAL " "NOT "
679 " " "MOD "
680 "WITHIN " "MINABOVE "
681 " " "MAXBELOW " "EXTREME "
682 " " "ABSEXTREME " "CHOOSE "
683 " " "IFELSE " "LOGCOSH "
684 " " "ACFWXM " "GAMP"
685 " " "GAMQ "
686 "ISPRIME " "DUMMY "
687 " ";
688
689 /* Builtin functions */
690 /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
691
692
693 /* Execute the opcode on the evaluation stack. Note that no attempt is
694 */
695 /* made to intercept errors, such as divide by zero, ACOS(2), etc. */
696
697
698 /* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
699 */
700
701 /* Branch to special code for function evaluations */
702
703 /* -----------------------------------------------------------------------
704 */
705 /* Include file for PARSER. This file must be kept with PARSER.FOR. */
706 /* It defines some symbolic constants that PARSER and its subsidiary */
707 /* routines use. */
708 /* .......................................................................
709 */
710 /* Define Token types and values */
711
712
713
714 /* .......................................................................
715 */
716 /* Define the Nonterminals */
717
718
719 /* .......................................................................
720 */
721 /* Define the Opcodes */
722
723
724 /* .......................................................................
725 */
726 /* Define Function names, etc. */
727
728
729
730
731 /* -----------------------------------------------------------------------
732 */
733 if (*n_opcode__ >= 4000) {
734 goto L5000;
735 }
736 /* .......................................................................
737 */
738 if (*n_opcode__ == 3006) {
739 /* !unary minus, the only unary op. */
740 s_copy(c_code__, "--", 8L, 2L);
741
742 } else {
743 /* !a binary operation */
744 if (*n_opcode__ == 3001) {
745 /* !add */
746 s_copy(c_code__, "+", 8L, 1L);
747 } else if (*n_opcode__ == 3002) {
748 /* !subtract */
749 s_copy(c_code__, "-", 8L, 1L);
750 } else if (*n_opcode__ == 3003) {
751 /* !multiply */
752 s_copy(c_code__, "*", 8L, 1L);
753 } else if (*n_opcode__ == 3004) {
754 /* !divide */
755 s_copy(c_code__, "/", 8L, 1L);
756 } else if (*n_opcode__ == 3005) {
757 /* !** */
758 s_copy(c_code__, "**", 8L, 2L);
759 }
760 }
761 goto L8000;
762 /* .......................................................................
763 */
764 /* Function evaluation */
765
766 L5000:
767 s_copy(c_code__, c_funcname__ + (*n_opcode__ - 4001 << 5), 8L, 32L);
768 /* .......................................................................
769 */
770 L8000:
771 return 0;
772 } /* execute_ */
773
774
775
776
get_token__(char * c_input__,integer * ntype,doublereal * value,integer * nused,ftnlen c_input_len)777 /* Subroutine */ int get_token__(char *c_input__, integer *ntype, doublereal *
778 value, integer *nused, ftnlen c_input_len)
779 {
780 /* Initialized data */
781
782 static char c_funcname__[32*124] = "SIN "
783 "COS " "TAN "
784 " " "ASIN " "ACOS "
785 " " "ATAN " "ATAN2 "
786 " " "SINH " "COSH "
787 " " "TANH " "ASIN"
788 "H " "ACOSH "
789 "ATANH " "EXP "
790 " " "LOG " "LOG10 "
791 " " "ABS " "INT "
792 " " "SQRT " "MAX "
793 " " "MIN " "AI "
794 " " "DAI "
795 "I0 " "I1 "
796 " " "J0 " "J1 "
797 " " "K0 " "K1 "
798 " " "Y0 " "Y1 "
799 " " "BI " "DBI "
800 " " "ERF "
801 "ERFC " "GAMMA "
802 " " "QG " "QGINV "
803 " " "BELL2 " "RECT "
804 " " "STEP " "BOOL "
805 " " "AND " "OR "
806 " " "MOFN "
807 "ASTEP " "SIND "
808 " " "COSD " "TAND "
809 " " "MEDIAN " "FICO_T2P "
810 " " "FICO_P2T " "FICO_T2Z "
811 " " "FITT_T2P " "FITT"
812 "_P2T " "FITT_T2Z "
813 "FIFT_T2P " "FIFT_P2T "
814 " " "FIFT_T2Z " "FIZT_T2P "
815 " " "FIZT_P2T " "FIZT_T2Z "
816 " " "FICT_T2P " "FICT_P2T "
817 " " "FICT_T2Z " "FIBT"
818 "_T2P " "FIBT_P2T "
819 "FIBT_T2Z " "FIBN_T2P "
820 " " "FIBN_P2T " "FIBN_T2Z "
821 " " "FIGT_T2P " "FIGT_P2T "
822 " " "FIGT_T2Z " "FIPT_T2P "
823 " " "FIPT_P2T " "FIPT"
824 "_T2Z " "ZTONE "
825 "LMODE " "HMODE "
826 " " "GRAN " "URAN "
827 " " "IRAN " "ERAN "
828 " " "LRAN " "ORSTAT "
829 " " "TENT " "MAD "
830 " " "ARGMAX "
831 "ARGNUM " "NOTZERO "
832 " " "ISZERO " "EQUALS "
833 " " "ISPOSITIVE " "ISNEGATIVE "
834 " " "MEAN " "STDEV "
835 " " "SEM " "PLEG"
836 " " "CDF2STAT "
837 "STAT2CDF " "PAIRMAX "
838 " " "PAIRMIN " "AMONGST "
839 " " "CBRT " "RHDDC2 "
840 " " "HRFBK4 " "HRFBK5 "
841 " " "POSVAL " "NOT "
842 " " "MOD "
843 "WITHIN " "MINABOVE "
844 " " "MAXBELOW " "EXTREME "
845 " " "ABSEXTREME " "CHOOSE "
846 " " "IFELSE " "LOGCOSH "
847 " " "ACFWXM " "GAMP"
848 " " "GAMQ "
849 "ISPRIME " "DUMMY "
850 " ";
851
852 /* Format strings */
853 static char fmt_5501[] = "(\002(F\002,i1,\002.0)\002)";
854 static char fmt_5502[] = "(\002(F\002,i2,\002.0)\002)";
855
856 /* System generated locals */
857 char ch__1[1];
858 icilist ici__1;
859 static doublereal equiv_0[1];
860
861 /* Builtin functions */
862 integer i_len(char *, ftnlen), s_cmp(char *, char *, ftnlen, ftnlen);
863 /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
864 integer s_wsfi(icilist *), do_fio(integer *, char *, ftnlen), e_wsfi(void)
865 , s_rsfi(icilist *), e_rsfi(void);
866
867 /* Local variables */
868 static integer nlen, ipos, npos;
869 static char c_val__[32];
870 static integer ifunc;
871 #define c8_val__ ((char *)equiv_0)
872 #define r8_val__ (equiv_0)
873 static integer io_code__;
874 static char c_first__[1], c_id__[32];
875
876 /* Fortran I/O blocks */
877 static icilist io___36 = { 0, c_val__, 0, fmt_5501, 32, 1 };
878 static icilist io___37 = { 0, c_val__, 0, fmt_5502, 32, 1 };
879
880
881
882 /* Return the 1st token in the input stream. */
883
884
885
886
887 /* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
888 */
889 /* Statement function definitions */
890
891 /* -----------------------------------------------------------------------
892 */
893 /* Include file for PARSER. This file must be kept with PARSER.FOR. */
894 /* It defines some symbolic constants that PARSER and its subsidiary */
895 /* routines use. */
896 /* .......................................................................
897 */
898 /* Define Token types and values */
899
900
901
902 /* .......................................................................
903 */
904 /* Define the Nonterminals */
905
906
907 /* .......................................................................
908 */
909 /* Define the Opcodes */
910
911
912 /* .......................................................................
913 */
914 /* Define Function names, etc. */
915
916
917
918
919 /* -----------------------------------------------------------------------
920 */
921
922
923 /* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
924 */
925
926 *ntype = 1000;
927 *nused = 0;
928 nlen = i_len(c_input__, c_input_len);
929 if (nlen <= 0) {
930 goto L8000;
931 }
932
933 /* Process the simple cases 1st */
934
935 *(unsigned char *)c_first__ = *(unsigned char *)c_input__;
936
937 if (*(unsigned char *)c_first__ == ' ') {
938 goto L8000;
939 }
940
941 *nused = 1;
942 if (*(unsigned char *)c_first__ == '+') {
943 *ntype = 1001;
944 *value = 1.;
945 } else if (*(unsigned char *)c_first__ == '-') {
946 *ntype = 1001;
947 *value = 2.;
948 } else if (*(unsigned char *)c_first__ == '/') {
949 *ntype = 1002;
950 *value = 2.;
951 } else if (*(unsigned char *)c_first__ == '*') {
952 if (s_cmp(c_input__, "**", 2L, 2L) == 0) {
953 *ntype = 1003;
954 *value = 1.;
955 *nused = 2;
956 } else {
957 *ntype = 1002;
958 *value = 1.;
959 }
960 } else if (*(unsigned char *)c_first__ == '^') {
961 *ntype = 1003;
962 *value = 1.;
963 } else if (*(unsigned char *)c_first__ == '(' || *(unsigned char *)
964 c_first__ == '[') {
965 *ntype = 1004;
966 } else if (*(unsigned char *)c_first__ == ')' || *(unsigned char *)
967 c_first__ == ']') {
968 *ntype = 1005;
969 } else if (*(unsigned char *)c_first__ == ',') {
970 *ntype = 1006;
971 }
972
973 if (*ntype != 1000) {
974 goto L8000;
975 }
976 /* !exit if above was successful */
977 /* .......................................................................
978 */
979 /* The only possibilities left are a variable name, a function name, */
980 /* or a number. */
981
982 *(unsigned char *)&ch__1[0] = *(unsigned char *)c_first__;
983 if (*(unsigned char *)&ch__1[0] >= 'A' && *(unsigned char *)&ch__1[0] <=
984 'Z') {
985 /* !a name */
986
987 npos = 2;
988 L110:
989 *(unsigned char *)&ch__1[0] = *(unsigned char *)&c_input__[npos - 1];
990 if (! (*(unsigned char *)&ch__1[0] >= 'A' && *(unsigned char *)&ch__1[
991 0] <= 'Z' || *(unsigned char *)&ch__1[0] >= '0' && *(unsigned
992 char *)&ch__1[0] <= '9' || *(unsigned char *)&ch__1[0] == '_'
993 || *(unsigned char *)&ch__1[0] == '$')) {
994 goto L120;
995 }
996 ++npos;
997 goto L110;
998 L120:
999 --npos;
1000 s_copy(c_id__, c_input__, 32L, npos);
1001
1002 /* The name is now in C_ID. Check to see if it is a function name.
1003 */
1004
1005 ifunc = 1;
1006 s_copy(c_funcname__ + 3936, c_id__, 32L, 32L);
1007 L210:
1008 if (! (s_cmp(c_id__, c_funcname__ + (ifunc - 1 << 5), 32L, 32L) != 0))
1009 {
1010 goto L220;
1011 }
1012 ++ifunc;
1013 goto L210;
1014 L220:
1015 if (ifunc <= 123) {
1016 /* !it is a function */
1017 *ntype = 1008;
1018 *value = (doublereal) ifunc;
1019 *nused = npos;
1020 } else if (s_cmp(c_id__, "PI", npos, 2L) == 0) {
1021 /* !symbolic pi */
1022 *ntype = 1007;
1023 *value = 3.1415926535897932;
1024 *nused = npos;
1025 } else {
1026 /* !must be a symbol */
1027 *ntype = 1009;
1028 s_copy(c8_val__, c_id__, 8L, npos);
1029 *value = *r8_val__;
1030 *nused = npos;
1031 }
1032 /* ...................................................................
1033 .... */
1034 /* try for a number */
1035
1036 } else /* if(complicated condition) */ {
1037 *(unsigned char *)&ch__1[0] = *(unsigned char *)c_first__;
1038 if (*(unsigned char *)&ch__1[0] >= '0' && *(unsigned char *)&ch__1[0]
1039 <= '9' || *(unsigned char *)c_first__ == '.') {
1040 npos = 2;
1041 L310:
1042 *(unsigned char *)&ch__1[0] = *(unsigned char *)&c_input__[npos -
1043 1];
1044 if (! (*(unsigned char *)&ch__1[0] >= '0' && *(unsigned char *)&
1045 ch__1[0] <= '9')) {
1046 goto L320;
1047 }
1048 /* !skip digits */
1049 ++npos;
1050 goto L310;
1051 L320:
1052 if (*(unsigned char *)c_first__ != '.' && *(unsigned char *)&
1053 c_input__[npos - 1] == '.') {
1054 ++npos;
1055 L410:
1056 *(unsigned char *)&ch__1[0] = *(unsigned char *)&c_input__[
1057 npos - 1];
1058 if (! (*(unsigned char *)&ch__1[0] >= '0' && *(unsigned char *
1059 )&ch__1[0] <= '9')) {
1060 goto L420;
1061 }
1062 /* !skip digits after decimal pt */
1063 ++npos;
1064 goto L410;
1065 L420:
1066 ;
1067 }
1068 /* !allow for exponent */
1069 if (*(unsigned char *)&c_input__[npos - 1] == 'E' || *(unsigned
1070 char *)&c_input__[npos - 1] == 'D') {
1071 ipos = npos + 1;
1072 if (*(unsigned char *)&c_input__[ipos - 1] == '+' || *(
1073 unsigned char *)&c_input__[ipos - 1] == '-') {
1074 ++ipos;
1075 }
1076 *(unsigned char *)&ch__1[0] = *(unsigned char *)&c_input__[
1077 ipos - 1];
1078 if (*(unsigned char *)&ch__1[0] >= '0' && *(unsigned char *)&
1079 ch__1[0] <= '9') {
1080 /* !only if a digit follows the E can it be legal */
1081 npos = ipos;
1082 L510:
1083 *(unsigned char *)&ch__1[0] = *(unsigned char *)&
1084 c_input__[npos - 1];
1085 if (! (*(unsigned char *)&ch__1[0] >= '0' && *(unsigned
1086 char *)&ch__1[0] <= '9')) {
1087 goto L520;
1088 }
1089 ++npos;
1090 goto L510;
1091 L520:
1092 ;
1093 }
1094 }
1095 --npos;
1096 /* !number runs from position 1 to NPOS */
1097 *nused = npos;
1098 if (npos <= 9) {
1099 s_wsfi(&io___36);
1100 do_fio(&c__1, (char *)&npos, (ftnlen)sizeof(integer));
1101 e_wsfi();
1102 } else {
1103 s_wsfi(&io___37);
1104 do_fio(&c__1, (char *)&npos, (ftnlen)sizeof(integer));
1105 e_wsfi();
1106 }
1107 *(unsigned char *)&c_val__[31] = '\0';
1108 ici__1.icierr = 1;
1109 ici__1.iciend = 1;
1110 ici__1.icirnum = 1;
1111 ici__1.icirlen = npos;
1112 ici__1.iciunit = c_input__;
1113 ici__1.icifmt = c_val__;
1114 io_code__ = s_rsfi(&ici__1);
1115 if (io_code__ != 0) {
1116 goto L100001;
1117 }
1118 io_code__ = do_fio(&c__1, (char *)&(*value), (ftnlen)sizeof(
1119 doublereal));
1120 if (io_code__ != 0) {
1121 goto L100001;
1122 }
1123 io_code__ = e_rsfi();
1124 L100001:
1125
1126 /* CC WRITE(*,5509) C_INPUT(1:NPOS) , C_VAL , VALUE */
1127 /* CC5509 FORMAT( */
1128 /* CC X ' scanned text ',A/ */
1129 /* CC X ' using format ',A/ */
1130 /* CC X ' giving VALUE ',1PG14.7) */
1131
1132 if (io_code__ == 0) {
1133 *ntype = 1007;
1134 } else {
1135 *ntype = 1999;
1136 }
1137 /* ...............................................................
1138 ........ */
1139 /* If not a number, an error! */
1140
1141 } else {
1142 *ntype = 1999;
1143 *nused = 1;
1144 }
1145 }
1146 /* .......................................................................
1147 */
1148 L8000:
1149 return 0;
1150 } /* get_token__ */
1151
1152 #undef r8_val__
1153 #undef c8_val__
1154
1155
1156
1157
1158
1159 /* (((.................................................................... */
last_nonblank__(char * cline,ftnlen cline_len)1160 integer last_nonblank__(char *cline, ftnlen cline_len)
1161 {
1162 /* System generated locals */
1163 integer ret_val;
1164
1165 /* Builtin functions */
1166 integer i_len(char *, ftnlen);
1167
1168 /* Local variables */
1169 static integer npos;
1170
1171
1172 /* Return the position of the last nonblank character in the input */
1173 /* character string. CLINE is CHARACTER*(*). Even if CLINE is all */
1174 /* blanks, LAST_NONBLANK will be returned as 1 so that operations of the
1175 */
1176 /* form CLINE(1:LAST_NONBLANK) won't be garbage. */
1177 /* )))....................................................................
1178 */
1179
1180 /* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1181 */
1182
1183 /* Start at the end and work backwards until a nonblank is found. */
1184 /* Loop back to 100 to check position # NPOS each time. */
1185
1186 npos = i_len(cline, cline_len);
1187 L100:
1188 /* quit if at the beginning */
1189 if (npos <= 1) {
1190 goto L200;
1191 }
1192 /* quit if not a blank or a null */
1193 if (*(unsigned char *)&cline[npos - 1] != ' ' && *(unsigned char *)&cline[
1194 npos - 1] != '\0') {
1195 goto L200;
1196 }
1197 /* move back one position and try again */
1198 --npos;
1199 goto L100;
1200 /* .......................................................................
1201 */
1202 L200:
1203 ret_val = npos;
1204 return ret_val;
1205 } /* last_nonblank__ */
1206
1207
1208
1209
hassym_(char * sym,integer * num_code__,char * c_code__,ftnlen sym_len,ftnlen c_code_len)1210 integer hassym_(char *sym, integer *num_code__, char *c_code__, ftnlen
1211 sym_len, ftnlen c_code_len)
1212 {
1213 /* System generated locals */
1214 integer ret_val, i__1;
1215
1216 /* Builtin functions */
1217 integer s_cmp(char *, char *, ftnlen, ftnlen);
1218
1219 /* Local variables */
1220 static integer ncode;
1221 static char sss[1];
1222
1223
1224
1225 /* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1226 */
1227
1228 /* Parameter adjustments */
1229 c_code__ -= 8;
1230
1231 /* Function Body */
1232 ret_val = 0;
1233 if (*num_code__ <= 0) {
1234 return ret_val;
1235 }
1236 *(unsigned char *)sss = *(unsigned char *)sym;
1237
1238 i__1 = *num_code__;
1239 for (ncode = 1; ncode <= i__1; ++ncode) {
1240 if (s_cmp(c_code__ + (ncode << 3), "PUSHSYM", 8L, 7L) == 0) {
1241 if (*(unsigned char *)&c_code__[(ncode + 1) * 8] == *(unsigned
1242 char *)sss) {
1243 ret_val = 1;
1244 return ret_val;
1245 }
1246 }
1247 /* L1000: */
1248 }
1249
1250 return ret_val;
1251 } /* hassym_ */
1252
1253
1254
1255
pareval_(integer * num_code__,char * c_code__,doublereal * r8val,ftnlen c_code_len)1256 doublereal pareval_(integer *num_code__, char *c_code__, doublereal *r8val,
1257 ftnlen c_code_len)
1258 {
1259 /* System generated locals */
1260 doublereal ret_val, d__1, d__2;
1261 static doublereal equiv_0[1];
1262
1263 /* Builtin functions */
1264 /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
1265 integer s_cmp(char *, char *, ftnlen, ftnlen);
1266 double d_int(doublereal *), pow_dd(doublereal *, doublereal *), sin(
1267 doublereal), cos(doublereal), tan(doublereal), sqrt(doublereal),
1268 exp(doublereal), log(doublereal), d_lg10(doublereal *), asin(
1269 doublereal), acos(doublereal), atan(doublereal), atan2(doublereal,
1270 doublereal), sinh(doublereal), cosh(doublereal), tanh(doublereal)
1271 ;
1272
1273 /* Local variables */
1274 extern doublereal land_(integer *, doublereal *), mean_(integer *,
1275 doublereal *), derf_(doublereal *), gamp_(doublereal *,
1276 doublereal *), eran_(doublereal *), gamq_(doublereal *,
1277 doublereal *), gran_(doublereal *, doublereal *), iran_(
1278 doublereal *), bool_(doublereal *), lran_(doublereal *), rect_(
1279 doublereal *), legendre_(doublereal *, doublereal *), uran_(
1280 doublereal *), tent_(doublereal *), step_(doublereal *),
1281 minabove_(integer *, doublereal *), maxbelow_(integer *,
1282 doublereal *), bell2_(doublereal *), derfc_(doublereal *);
1283 static integer ncode;
1284 static doublereal x, y;
1285 extern doublereal hmode_(integer *, doublereal *), lmode_(integer *,
1286 doublereal *);
1287 static integer neval;
1288 extern doublereal lmofn_(integer *, integer *, doublereal *), qginv_(
1289 doublereal *), stdev_(integer *, doublereal *), ztone_(doublereal
1290 *), zzmod_(doublereal *, doublereal *), dbesi0_(doublereal *),
1291 dbesi1_(doublereal *), dbesj0_(doublereal *), dbesj1_(doublereal *
1292 ), dbesk0_(doublereal *), dbesk1_(doublereal *);
1293 #define c8_val__ ((char *)equiv_0)
1294 extern doublereal rhddc2_(doublereal *, doublereal *, doublereal *),
1295 hrfbk4_(doublereal *, doublereal *), hrfbk5_(doublereal *,
1296 doublereal *), cdf2st_(doublereal *, doublereal *, doublereal *,
1297 doublereal *, doublereal *), dbesy0_(doublereal *), dbesy1_(
1298 doublereal *), st2cdf_(doublereal *, doublereal *, doublereal *,
1299 doublereal *, doublereal *);
1300 #define r8_val__ (equiv_0)
1301 extern doublereal dgamma_(doublereal *), qg_(doublereal *);
1302 static char cncode[8];
1303 extern doublereal median_(integer *, doublereal *);
1304 static integer ialpha;
1305 extern doublereal cbrtff_(doublereal *), amongf_(integer *, doublereal *),
1306 argmax_(integer *, doublereal *), choose_(integer *, integer *,
1307 doublereal *), fibntp_(doublereal *, doublereal *, doublereal *),
1308 fibnpt_(doublereal *, doublereal *, doublereal *), ficotp_(
1309 doublereal *, doublereal *, doublereal *, doublereal *), acfwxm_(
1310 doublereal *, doublereal *, doublereal *, doublereal *), pairmn_(
1311 integer *, doublereal *), lncosh_(doublereal *), ficopt_(
1312 doublereal *, doublereal *, doublereal *, doublereal *), argnum_(
1313 integer *, doublereal *), ficttp_(doublereal *, doublereal *),
1314 fictpt_(doublereal *, doublereal *), fifttp_(doublereal *,
1315 doublereal *, doublereal *), fiftpt_(doublereal *, doublereal *,
1316 doublereal *), ficotz_(doublereal *, doublereal *, doublereal *,
1317 doublereal *), fibttp_(doublereal *, doublereal *, doublereal *),
1318 pairmx_(integer *, doublereal *), fibtpt_(doublereal *,
1319 doublereal *, doublereal *), fibttz_(doublereal *, doublereal *,
1320 doublereal *), ficttz_(doublereal *, doublereal *), posval_(
1321 doublereal *), fibntz_(doublereal *, doublereal *, doublereal *),
1322 fifttz_(doublereal *, doublereal *, doublereal *), figttp_(
1323 doublereal *, doublereal *, doublereal *), figtpt_(doublereal *,
1324 doublereal *, doublereal *), fitttp_(doublereal *, doublereal *),
1325 fittpt_(doublereal *, doublereal *), orstat_(integer *, integer *,
1326 doublereal *), figttz_(doublereal *, doublereal *, doublereal *),
1327 absextreme_(integer *, doublereal *), fipttp_(doublereal *,
1328 doublereal *), fizttp_(doublereal *), fiztpt_(doublereal *),
1329 fiptpt_(doublereal *, doublereal *), fipttz_(doublereal *,
1330 doublereal *), fitttz_(doublereal *, doublereal *), fizttz_(
1331 doublereal *);
1332 static doublereal r8_eval__[128];
1333 extern doublereal dai_(doublereal *), dbi_(doublereal *, integer *), mad_(
1334 integer *, doublereal *), sem_(integer *, doublereal *);
1335 static integer itm;
1336 extern doublereal lor_(integer *, doublereal *);
1337 static integer ntm;
1338 extern doublereal withinf_(integer *, doublereal *), extreme_(integer *,
1339 doublereal *), isprime_(doublereal *);
1340
1341
1342
1343
1344
1345 /* Internal library functions */
1346
1347
1348 /* External library functions */
1349
1350
1351 /* Statistics functions (01 Mar 1999 - see parser_int.c) */
1352
1353
1354 /* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1355 */
1356
1357 /* Parameter adjustments */
1358 --r8val;
1359 c_code__ -= 8;
1360
1361 /* Function Body */
1362 if (*num_code__ <= 0) {
1363 ret_val = 0.;
1364 goto L8000;
1365 }
1366 /* -----------------------------------------------------------------------
1367 */
1368 ialpha = 'A' - 1;
1369 neval = 0;
1370 ncode = 0;
1371
1372 L1000:
1373 ++ncode;
1374 s_copy(cncode, c_code__ + (ncode << 3), 8L, 8L);
1375 /* .......................................................................
1376 */
1377 if (s_cmp(cncode, "PUSHSYM", 8L, 7L) == 0) {
1378 ++neval;
1379 r8_eval__[neval - 1] = r8val[*(unsigned char *)&c_code__[(ncode + 1) *
1380 8] - ialpha];
1381 ++ncode;
1382 /* ...................................................................
1383 .... */
1384 } else if (s_cmp(cncode, "PUSHNUM", 8L, 7L) == 0) {
1385 ++neval;
1386 s_copy(c8_val__, c_code__ + (ncode + 1 << 3), 8L, 8L);
1387 r8_eval__[neval - 1] = *r8_val__;
1388 ++ncode;
1389 /* ...................................................................
1390 .... */
1391 } else if (s_cmp(cncode, "+", 8L, 1L) == 0) {
1392 --neval;
1393 r8_eval__[neval - 1] += r8_eval__[neval];
1394 /* ...................................................................
1395 .... */
1396 } else if (s_cmp(cncode, "-", 8L, 1L) == 0) {
1397 --neval;
1398 r8_eval__[neval - 1] -= r8_eval__[neval];
1399 /* ...................................................................
1400 .... */
1401 } else if (s_cmp(cncode, "*", 8L, 1L) == 0) {
1402 --neval;
1403 r8_eval__[neval - 1] *= r8_eval__[neval];
1404 /* ...................................................................
1405 .... */
1406 } else if (s_cmp(cncode, "/", 8L, 1L) == 0) {
1407 --neval;
1408 if (r8_eval__[neval] != 0.) {
1409 r8_eval__[neval - 1] /= r8_eval__[neval];
1410 } else {
1411 r8_eval__[neval - 1] = 0.;
1412 }
1413 /* ...................................................................
1414 .... */
1415 } else if (s_cmp(cncode, "**", 8L, 2L) == 0) {
1416 --neval;
1417 if (r8_eval__[neval - 1] > 0. || r8_eval__[neval - 1] != 0. &&
1418 r8_eval__[neval] == d_int(&r8_eval__[neval])) {
1419 r8_eval__[neval - 1] = pow_dd(&r8_eval__[neval - 1], &r8_eval__[
1420 neval]);
1421 }
1422 /* ...................................................................
1423 .... */
1424 } else if (s_cmp(cncode, "--", 8L, 2L) == 0) {
1425 r8_eval__[neval - 1] = -r8_eval__[neval - 1];
1426 /* ...................................................................
1427 .... */
1428 } else if (s_cmp(cncode, "SIN", 8L, 3L) == 0) {
1429 r8_eval__[neval - 1] = sin(r8_eval__[neval - 1]);
1430 /* ...................................................................
1431 .... */
1432 } else if (s_cmp(cncode, "SIND", 8L, 4L) == 0) {
1433 r8_eval__[neval - 1] = sin(r8_eval__[neval - 1] * .01745329251994);
1434 /* ...................................................................
1435 .... */
1436 } else if (s_cmp(cncode, "COS", 8L, 3L) == 0) {
1437 r8_eval__[neval - 1] = cos(r8_eval__[neval - 1]);
1438 /* ...................................................................
1439 .... */
1440 } else if (s_cmp(cncode, "COSD", 8L, 4L) == 0) {
1441 r8_eval__[neval - 1] = cos(r8_eval__[neval - 1] * .01745329251994);
1442 /* ...................................................................
1443 .... */
1444 } else if (s_cmp(cncode, "TAN", 8L, 3L) == 0) {
1445 r8_eval__[neval - 1] = tan(r8_eval__[neval - 1]);
1446 /* ...................................................................
1447 .... */
1448 } else if (s_cmp(cncode, "TAND", 8L, 4L) == 0) {
1449 r8_eval__[neval - 1] = tan(r8_eval__[neval - 1] * .01745329251994);
1450 /* ...................................................................
1451 .... */
1452 } else if (s_cmp(cncode, "SQRT", 8L, 4L) == 0) {
1453 r8_eval__[neval - 1] = sqrt((d__1 = r8_eval__[neval - 1], abs(d__1)));
1454 /* ...................................................................
1455 .... */
1456 } else if (s_cmp(cncode, "CBRT", 8L, 4L) == 0) {
1457 r8_eval__[neval - 1] = cbrtff_(&r8_eval__[neval - 1]);
1458 /* ...................................................................
1459 .... */
1460 } else if (s_cmp(cncode, "ABS", 8L, 3L) == 0) {
1461 r8_eval__[neval - 1] = (d__1 = r8_eval__[neval - 1], abs(d__1));
1462 /* ...................................................................
1463 .... */
1464 } else if (s_cmp(cncode, "EXP", 8L, 3L) == 0) {
1465 /* Computing MIN */
1466 d__1 = 87.5, d__2 = r8_eval__[neval - 1];
1467 r8_eval__[neval - 1] = exp((min(d__1,d__2)));
1468 /* ...................................................................
1469 .... */
1470 } else if (s_cmp(cncode, "LOG", 8L, 3L) == 0) {
1471 if (r8_eval__[neval - 1] != 0.) {
1472 r8_eval__[neval - 1] = log((d__1 = r8_eval__[neval - 1], abs(d__1)
1473 ));
1474 }
1475 /* ...................................................................
1476 .... */
1477 } else if (s_cmp(cncode, "LOG10", 8L, 5L) == 0) {
1478 if (r8_eval__[neval - 1] != 0.) {
1479 d__2 = (d__1 = r8_eval__[neval - 1], abs(d__1));
1480 r8_eval__[neval - 1] = d_lg10(&d__2);
1481 }
1482 /* ...................................................................
1483 .... */
1484 } else if (s_cmp(cncode, "INT", 8L, 3L) == 0) {
1485 r8_eval__[neval - 1] = d_int(&r8_eval__[neval - 1]);
1486 /* ...................................................................
1487 .... */
1488 } else if (s_cmp(cncode, "MAX", 8L, 3L) == 0) {
1489 --neval;
1490 /* Computing MAX */
1491 d__1 = r8_eval__[neval - 1], d__2 = r8_eval__[neval];
1492 r8_eval__[neval - 1] = max(d__1,d__2);
1493 /* ...................................................................
1494 .... */
1495 } else if (s_cmp(cncode, "MIN", 8L, 3L) == 0) {
1496 --neval;
1497 /* Computing MIN */
1498 d__1 = r8_eval__[neval - 1], d__2 = r8_eval__[neval];
1499 r8_eval__[neval - 1] = min(d__1,d__2);
1500 /* ...................................................................
1501 .... */
1502 } else if (s_cmp(cncode, "ASIN", 8L, 4L) == 0) {
1503 if ((d__1 = r8_eval__[neval - 1], abs(d__1)) <= 1.) {
1504 r8_eval__[neval - 1] = asin(r8_eval__[neval - 1]);
1505 }
1506 /* ...................................................................
1507 .... */
1508 } else if (s_cmp(cncode, "ACOS", 8L, 4L) == 0) {
1509 if ((d__1 = r8_eval__[neval - 1], abs(d__1)) <= 1.) {
1510 r8_eval__[neval - 1] = acos(r8_eval__[neval - 1]);
1511 }
1512 /* ...................................................................
1513 .... */
1514 } else if (s_cmp(cncode, "ATAN", 8L, 4L) == 0) {
1515 r8_eval__[neval - 1] = atan(r8_eval__[neval - 1]);
1516 /* ...................................................................
1517 .... */
1518 } else if (s_cmp(cncode, "ATAN2", 8L, 5L) == 0) {
1519 --neval;
1520 if (r8_eval__[neval - 1] != 0. || r8_eval__[neval] != 0.) {
1521 r8_eval__[neval - 1] = atan2(r8_eval__[neval - 1], r8_eval__[
1522 neval]);
1523 }
1524 /* ...................................................................
1525 .... */
1526 } else if (s_cmp(cncode, "GRAN", 8L, 4L) == 0) {
1527 --neval;
1528 r8_eval__[neval - 1] = gran_(&r8_eval__[neval - 1], &r8_eval__[neval])
1529 ;
1530 /* ...................................................................
1531 .... */
1532 } else if (s_cmp(cncode, "MOD", 8L, 3L) == 0) {
1533 --neval;
1534 r8_eval__[neval - 1] = zzmod_(&r8_eval__[neval - 1], &r8_eval__[neval]
1535 );
1536 /* ...................................................................
1537 .... */
1538 } else if (s_cmp(cncode, "URAN", 8L, 4L) == 0) {
1539 r8_eval__[neval - 1] = uran_(&r8_eval__[neval - 1]);
1540 /* ...................................................................
1541 .... */
1542 } else if (s_cmp(cncode, "IRAN", 8L, 4L) == 0) {
1543 r8_eval__[neval - 1] = iran_(&r8_eval__[neval - 1]);
1544 /* ...................................................................
1545 .... */
1546 } else if (s_cmp(cncode, "ERAN", 8L, 4L) == 0) {
1547 r8_eval__[neval - 1] = eran_(&r8_eval__[neval - 1]);
1548 /* ...................................................................
1549 .... */
1550 } else if (s_cmp(cncode, "LRAN", 8L, 4L) == 0) {
1551 r8_eval__[neval - 1] = lran_(&r8_eval__[neval - 1]);
1552 /* ...................................................................
1553 .... */
1554 } else if (s_cmp(cncode, "PLEG", 8L, 4L) == 0) {
1555 --neval;
1556 r8_eval__[neval - 1] = legendre_(&r8_eval__[neval - 1], &r8_eval__[
1557 neval]);
1558 /* ...................................................................
1559 .... */
1560 } else if (s_cmp(cncode, "HRFBK4", 8L, 6L) == 0) {
1561 --neval;
1562 r8_eval__[neval - 1] = hrfbk4_(&r8_eval__[neval - 1], &r8_eval__[
1563 neval]);
1564 /* ...................................................................
1565 .... */
1566 } else if (s_cmp(cncode, "HRFBK5", 8L, 6L) == 0) {
1567 --neval;
1568 r8_eval__[neval - 1] = hrfbk5_(&r8_eval__[neval - 1], &r8_eval__[
1569 neval]);
1570 /* ...................................................................
1571 .... */
1572 } else if (s_cmp(cncode, "RHDDC2", 8L, 6L) == 0) {
1573 neval += -2;
1574 r8_eval__[neval - 1] = rhddc2_(&r8_eval__[neval - 1], &r8_eval__[
1575 neval], &r8_eval__[neval + 1]);
1576 /* ...................................................................
1577 .... */
1578 } else if (s_cmp(cncode, "SINH", 8L, 4L) == 0) {
1579 if ((d__1 = r8_eval__[neval - 1], abs(d__1)) < 87.5f) {
1580 r8_eval__[neval - 1] = sinh(r8_eval__[neval - 1]);
1581 }
1582 /* ...................................................................
1583 .... */
1584 } else if (s_cmp(cncode, "COSH", 8L, 4L) == 0) {
1585 if ((d__1 = r8_eval__[neval - 1], abs(d__1)) < 87.5f) {
1586 r8_eval__[neval - 1] = cosh(r8_eval__[neval - 1]);
1587 }
1588 /* ...................................................................
1589 .... */
1590 } else if (s_cmp(cncode, "LOGCOSH", 8L, 7L) == 0) {
1591 if ((d__1 = r8_eval__[neval - 1], abs(d__1)) < 87.5f) {
1592 r8_eval__[neval - 1] = lncosh_(&r8_eval__[neval - 1]);
1593 }
1594 /* ...................................................................
1595 .... */
1596 } else if (s_cmp(cncode, "ACFWXM", 8L, 6L) == 0) {
1597 neval += -3;
1598 r8_eval__[neval - 1] = acfwxm_(&r8_eval__[neval - 1], &r8_eval__[
1599 neval], &r8_eval__[neval + 1], &r8_eval__[neval + 2]);
1600 /* ...................................................................
1601 .... */
1602 } else if (s_cmp(cncode, "GAMP", 8L, 4L) == 0) {
1603 --neval;
1604 r8_eval__[neval - 1] = gamp_(&r8_eval__[neval - 1], &r8_eval__[neval])
1605 ;
1606 /* ...................................................................
1607 .... */
1608 } else if (s_cmp(cncode, "GAMQ", 8L, 4L) == 0) {
1609 --neval;
1610 r8_eval__[neval - 1] = gamq_(&r8_eval__[neval - 1], &r8_eval__[neval])
1611 ;
1612 /* ...................................................................
1613 .... */
1614 } else if (s_cmp(cncode, "TANH", 8L, 4L) == 0) {
1615 r8_eval__[neval - 1] = tanh(r8_eval__[neval - 1]);
1616 /* ...................................................................
1617 .... */
1618 } else if (s_cmp(cncode, "ASINH", 8L, 5L) == 0) {
1619 x = (d__1 = r8_eval__[neval - 1], abs(d__1));
1620 if (x <= 10.) {
1621 /* Computing 2nd power */
1622 d__1 = x;
1623 y = x + sqrt(d__1 * d__1 + 1.);
1624 } else {
1625 /* Computing 2nd power */
1626 d__1 = 1. / x;
1627 y = x * (sqrt(d__1 * d__1 + 1.) + 1.);
1628 }
1629 y = log(y);
1630 if (r8_eval__[neval - 1] < 0.) {
1631 r8_eval__[neval - 1] = -y;
1632 } else {
1633 r8_eval__[neval - 1] = y;
1634 }
1635 /* ...................................................................
1636 .... */
1637 } else if (s_cmp(cncode, "ACOSH", 8L, 5L) == 0) {
1638 x = r8_eval__[neval - 1];
1639 if (x >= 1.) {
1640 if (x <= 10.) {
1641 /* Computing 2nd power */
1642 d__1 = x;
1643 y = x + sqrt(d__1 * d__1 - 1.);
1644 } else {
1645 /* Computing 2nd power */
1646 d__1 = 1. / x;
1647 y = x * (sqrt(1. - d__1 * d__1) + 1.);
1648 }
1649 r8_eval__[neval - 1] = log(y);
1650 }
1651 /* ...................................................................
1652 .... */
1653 } else if (s_cmp(cncode, "ATANH", 8L, 5L) == 0) {
1654 x = r8_eval__[neval - 1];
1655 if (abs(x) < 1.) {
1656 r8_eval__[neval - 1] = log((x + 1.) / (1. - x)) * .5;
1657 }
1658 /* ...................................................................
1659 .... */
1660 } else if (s_cmp(cncode, "AI", 8L, 2L) == 0) {
1661 r8_eval__[neval - 1] = dai_(&r8_eval__[neval - 1]);
1662 /* ...................................................................
1663 .... */
1664 } else if (s_cmp(cncode, "BI", 8L, 2L) == 0) {
1665 r8_eval__[neval - 1] = dbi_(&r8_eval__[neval - 1], &c__1);
1666 /* ...................................................................
1667 .... */
1668 } else if (s_cmp(cncode, "ERF", 8L, 3L) == 0) {
1669 r8_eval__[neval - 1] = derf_(&r8_eval__[neval - 1]);
1670 } else if (s_cmp(cncode, "ERFC", 8L, 4L) == 0) {
1671 r8_eval__[neval - 1] = derfc_(&r8_eval__[neval - 1]);
1672 /* ...................................................................
1673 .... */
1674 } else if (s_cmp(cncode, "GAMMA", 8L, 5L) == 0) {
1675 r8_eval__[neval - 1] = dgamma_(&r8_eval__[neval - 1]);
1676 /* ...................................................................
1677 .... */
1678 } else if (s_cmp(cncode, "I0", 8L, 2L) == 0) {
1679 r8_eval__[neval - 1] = dbesi0_(&r8_eval__[neval - 1]);
1680 } else if (s_cmp(cncode, "I1", 8L, 2L) == 0) {
1681 r8_eval__[neval - 1] = dbesi1_(&r8_eval__[neval - 1]);
1682 /* ...................................................................
1683 .... */
1684 } else if (s_cmp(cncode, "J0", 8L, 2L) == 0) {
1685 r8_eval__[neval - 1] = dbesj0_(&r8_eval__[neval - 1]);
1686 } else if (s_cmp(cncode, "J1", 8L, 2L) == 0) {
1687 r8_eval__[neval - 1] = dbesj1_(&r8_eval__[neval - 1]);
1688 /* ...................................................................
1689 .... */
1690 } else if (s_cmp(cncode, "K0", 8L, 2L) == 0) {
1691 r8_eval__[neval - 1] = dbesk0_(&r8_eval__[neval - 1]);
1692 } else if (s_cmp(cncode, "K1", 8L, 2L) == 0) {
1693 r8_eval__[neval - 1] = dbesk1_(&r8_eval__[neval - 1]);
1694 /* ...................................................................
1695 .... */
1696 } else if (s_cmp(cncode, "Y0", 8L, 2L) == 0) {
1697 r8_eval__[neval - 1] = dbesy0_(&r8_eval__[neval - 1]);
1698 } else if (s_cmp(cncode, "Y1", 8L, 2L) == 0) {
1699 r8_eval__[neval - 1] = dbesy1_(&r8_eval__[neval - 1]);
1700 /* ...................................................................
1701 .... */
1702 } else if (s_cmp(cncode, "QG", 8L, 2L) == 0) {
1703 r8_eval__[neval - 1] = qg_(&r8_eval__[neval - 1]);
1704 } else if (s_cmp(cncode, "QGINV", 8L, 5L) == 0) {
1705 r8_eval__[neval - 1] = qginv_(&r8_eval__[neval - 1]);
1706 } else if (s_cmp(cncode, "BELL2", 8L, 5L) == 0) {
1707 r8_eval__[neval - 1] = bell2_(&r8_eval__[neval - 1]);
1708 } else if (s_cmp(cncode, "RECT", 8L, 4L) == 0) {
1709 r8_eval__[neval - 1] = rect_(&r8_eval__[neval - 1]);
1710 } else if (s_cmp(cncode, "STEP", 8L, 4L) == 0) {
1711 r8_eval__[neval - 1] = step_(&r8_eval__[neval - 1]);
1712 } else if (s_cmp(cncode, "POSVAL", 8L, 6L) == 0) {
1713 r8_eval__[neval - 1] = posval_(&r8_eval__[neval - 1]);
1714 } else if (s_cmp(cncode, "TENT", 8L, 4L) == 0) {
1715 r8_eval__[neval - 1] = tent_(&r8_eval__[neval - 1]);
1716 } else if (s_cmp(cncode, "BOOL", 8L, 4L) == 0) {
1717 r8_eval__[neval - 1] = bool_(&r8_eval__[neval - 1]);
1718 } else if (s_cmp(cncode, "ZTONE", 8L, 5L) == 0) {
1719 r8_eval__[neval - 1] = ztone_(&r8_eval__[neval - 1]);
1720 /* ...................................................................
1721 .... */
1722 } else if (s_cmp(cncode, "ISPRIME", 8L, 7L) == 0) {
1723 r8_eval__[neval - 1] = isprime_(&r8_eval__[neval - 1]);
1724 /* ...................................................................
1725 .... */
1726 } else if (s_cmp(cncode, "CDF2STAT", 8L, 8L) == 0) {
1727 neval += -4;
1728 r8_eval__[neval - 1] = cdf2st_(&r8_eval__[neval - 1], &r8_eval__[
1729 neval], &r8_eval__[neval + 1], &r8_eval__[neval + 2], &
1730 r8_eval__[neval + 3]);
1731 } else if (s_cmp(cncode, "STAT2CDF", 8L, 8L) == 0) {
1732 neval += -4;
1733 r8_eval__[neval - 1] = st2cdf_(&r8_eval__[neval - 1], &r8_eval__[
1734 neval], &r8_eval__[neval + 1], &r8_eval__[neval + 2], &
1735 r8_eval__[neval + 3]);
1736 /* ...................................................................
1737 .... */
1738 } else if (s_cmp(cncode, "NOTZERO", 8L, 7L) == 0) {
1739 r8_eval__[neval - 1] = bool_(&r8_eval__[neval - 1]);
1740 } else if (s_cmp(cncode, "ISZERO", 8L, 6L) == 0 || s_cmp(cncode, "NOT",
1741 8L, 3L) == 0) {
1742 r8_eval__[neval - 1] = 1. - bool_(&r8_eval__[neval - 1]);
1743 } else if (s_cmp(cncode, "EQUALS", 8L, 6L) == 0) {
1744 --neval;
1745 d__1 = r8_eval__[neval - 1] - r8_eval__[neval];
1746 r8_eval__[neval - 1] = 1. - bool_(&d__1);
1747 } else if (s_cmp(cncode, "ISPOSITI", 8L, 8L) == 0) {
1748 r8_eval__[neval - 1] = step_(&r8_eval__[neval - 1]);
1749 } else if (s_cmp(cncode, "ISNEGATI", 8L, 8L) == 0) {
1750 d__1 = -r8_eval__[neval - 1];
1751 r8_eval__[neval - 1] = step_(&d__1);
1752 /* ...................................................................
1753 .... */
1754 } else if (s_cmp(cncode, "AND", 8L, 3L) == 0) {
1755 ntm = (integer) r8_eval__[neval - 1];
1756 neval -= ntm;
1757 r8_eval__[neval - 1] = land_(&ntm, &r8_eval__[neval - 1]);
1758 } else if (s_cmp(cncode, "MEDIAN", 8L, 6L) == 0) {
1759 ntm = (integer) r8_eval__[neval - 1];
1760 neval -= ntm;
1761 r8_eval__[neval - 1] = median_(&ntm, &r8_eval__[neval - 1]);
1762 } else if (s_cmp(cncode, "MAD", 8L, 3L) == 0) {
1763 ntm = (integer) r8_eval__[neval - 1];
1764 neval -= ntm;
1765 r8_eval__[neval - 1] = mad_(&ntm, &r8_eval__[neval - 1]);
1766 } else if (s_cmp(cncode, "MEAN", 8L, 4L) == 0) {
1767 ntm = (integer) r8_eval__[neval - 1];
1768 neval -= ntm;
1769 r8_eval__[neval - 1] = mean_(&ntm, &r8_eval__[neval - 1]);
1770 } else if (s_cmp(cncode, "STDEV", 8L, 5L) == 0) {
1771 ntm = (integer) r8_eval__[neval - 1];
1772 neval -= ntm;
1773 r8_eval__[neval - 1] = stdev_(&ntm, &r8_eval__[neval - 1]);
1774 } else if (s_cmp(cncode, "SEM", 8L, 3L) == 0) {
1775 ntm = (integer) r8_eval__[neval - 1];
1776 neval -= ntm;
1777 r8_eval__[neval - 1] = sem_(&ntm, &r8_eval__[neval - 1]);
1778 } else if (s_cmp(cncode, "ORSTAT", 8L, 6L) == 0) {
1779 ntm = (integer) r8_eval__[neval - 1];
1780 neval -= ntm;
1781 --ntm;
1782 itm = (integer) r8_eval__[neval - 1];
1783 r8_eval__[neval - 1] = orstat_(&itm, &ntm, &r8_eval__[neval]);
1784 } else if (s_cmp(cncode, "HMODE", 8L, 5L) == 0) {
1785 ntm = (integer) r8_eval__[neval - 1];
1786 neval -= ntm;
1787 r8_eval__[neval - 1] = hmode_(&ntm, &r8_eval__[neval - 1]);
1788 } else if (s_cmp(cncode, "LMODE", 8L, 5L) == 0) {
1789 ntm = (integer) r8_eval__[neval - 1];
1790 neval -= ntm;
1791 r8_eval__[neval - 1] = lmode_(&ntm, &r8_eval__[neval - 1]);
1792 } else if (s_cmp(cncode, "OR", 8L, 2L) == 0) {
1793 ntm = (integer) r8_eval__[neval - 1];
1794 neval -= ntm;
1795 r8_eval__[neval - 1] = lor_(&ntm, &r8_eval__[neval - 1]);
1796 } else if (s_cmp(cncode, "MOFN", 8L, 4L) == 0) {
1797 ntm = (integer) r8_eval__[neval - 1];
1798 neval -= ntm;
1799 --ntm;
1800 itm = (integer) r8_eval__[neval - 1];
1801 r8_eval__[neval - 1] = lmofn_(&itm, &ntm, &r8_eval__[neval]);
1802 } else if (s_cmp(cncode, "ASTEP", 8L, 5L) == 0) {
1803 --neval;
1804 if ((d__1 = r8_eval__[neval - 1], abs(d__1)) > r8_eval__[neval]) {
1805 r8_eval__[neval - 1] = 1.;
1806 } else {
1807 r8_eval__[neval - 1] = 0.;
1808 }
1809 } else if (s_cmp(cncode, "ARGMAX", 8L, 6L) == 0) {
1810 ntm = (integer) r8_eval__[neval - 1];
1811 neval -= ntm;
1812 r8_eval__[neval - 1] = argmax_(&ntm, &r8_eval__[neval - 1]);
1813 } else if (s_cmp(cncode, "ARGNUM", 8L, 6L) == 0) {
1814 ntm = (integer) r8_eval__[neval - 1];
1815 neval -= ntm;
1816 r8_eval__[neval - 1] = argnum_(&ntm, &r8_eval__[neval - 1]);
1817 } else if (s_cmp(cncode, "PAIRMAX", 8L, 7L) == 0) {
1818 ntm = (integer) r8_eval__[neval - 1];
1819 neval -= ntm;
1820 r8_eval__[neval - 1] = pairmx_(&ntm, &r8_eval__[neval - 1]);
1821 } else if (s_cmp(cncode, "PAIRMIN", 8L, 7L) == 0) {
1822 ntm = (integer) r8_eval__[neval - 1];
1823 neval -= ntm;
1824 r8_eval__[neval - 1] = pairmn_(&ntm, &r8_eval__[neval - 1]);
1825 } else if (s_cmp(cncode, "AMONGST", 8L, 7L) == 0) {
1826 ntm = (integer) r8_eval__[neval - 1];
1827 neval -= ntm;
1828 r8_eval__[neval - 1] = amongf_(&ntm, &r8_eval__[neval - 1]);
1829 } else if (s_cmp(cncode, "WITHIN", 8L, 6L) == 0) {
1830 ntm = (integer) r8_eval__[neval - 1];
1831 neval -= ntm;
1832 r8_eval__[neval - 1] = withinf_(&ntm, &r8_eval__[neval - 1]);
1833 } else if (s_cmp(cncode, "MINABOVE", 8L, 8L) == 0) {
1834 ntm = (integer) r8_eval__[neval - 1];
1835 neval -= ntm;
1836 r8_eval__[neval - 1] = minabove_(&ntm, &r8_eval__[neval - 1]);
1837 } else if (s_cmp(cncode, "MAXBELOW", 8L, 8L) == 0) {
1838 ntm = (integer) r8_eval__[neval - 1];
1839 neval -= ntm;
1840 r8_eval__[neval - 1] = maxbelow_(&ntm, &r8_eval__[neval - 1]);
1841 } else if (s_cmp(cncode, "EXTREME", 8L, 7L) == 0) {
1842 ntm = (integer) r8_eval__[neval - 1];
1843 neval -= ntm;
1844 r8_eval__[neval - 1] = extreme_(&ntm, &r8_eval__[neval - 1]);
1845 } else if (s_cmp(cncode, "ABSEXTREME", 8L, 10L) == 0) {
1846 ntm = (integer) r8_eval__[neval - 1];
1847 neval -= ntm;
1848 r8_eval__[neval - 1] = absextreme_(&ntm, &r8_eval__[neval - 1]);
1849 } else if (s_cmp(cncode, "CHOOSE", 8L, 6L) == 0) {
1850 ntm = (integer) r8_eval__[neval - 1];
1851 neval -= ntm;
1852 --ntm;
1853 itm = (integer) r8_eval__[neval - 1];
1854 r8_eval__[neval - 1] = choose_(&itm, &ntm, &r8_eval__[neval]);
1855 } else if (s_cmp(cncode, "IFELSE", 8L, 6L) == 0) {
1856 neval += -2;
1857 if (r8_eval__[neval - 1] != 0.) {
1858 r8_eval__[neval - 1] = r8_eval__[neval];
1859 } else {
1860 r8_eval__[neval - 1] = r8_eval__[neval + 1];
1861 }
1862 /* ...................................................................
1863 .... */
1864 } else if (s_cmp(cncode, "FICO_T2P", 8L, 8L) == 0) {
1865 neval += -3;
1866 d__2 = (d__1 = r8_eval__[neval - 1], abs(d__1));
1867 r8_eval__[neval - 1] = ficotp_(&d__2, &r8_eval__[neval], &r8_eval__[
1868 neval + 1], &r8_eval__[neval + 2]);
1869 } else if (s_cmp(cncode, "FICO_P2T", 8L, 8L) == 0) {
1870 neval += -3;
1871 r8_eval__[neval - 1] = ficopt_(&r8_eval__[neval - 1], &r8_eval__[
1872 neval], &r8_eval__[neval + 1], &r8_eval__[neval + 2]);
1873 } else if (s_cmp(cncode, "FICO_T2Z", 8L, 8L) == 0) {
1874 neval += -3;
1875 r8_eval__[neval - 1] = ficotz_(&r8_eval__[neval - 1], &r8_eval__[
1876 neval], &r8_eval__[neval + 1], &r8_eval__[neval + 2]);
1877 /* ...................................................................
1878 .... */
1879 } else if (s_cmp(cncode, "FITT_T2P", 8L, 8L) == 0) {
1880 --neval;
1881 d__2 = (d__1 = r8_eval__[neval - 1], abs(d__1));
1882 r8_eval__[neval - 1] = fitttp_(&d__2, &r8_eval__[neval]);
1883 } else if (s_cmp(cncode, "FITT_P2T", 8L, 8L) == 0) {
1884 --neval;
1885 r8_eval__[neval - 1] = fittpt_(&r8_eval__[neval - 1], &r8_eval__[
1886 neval]);
1887 } else if (s_cmp(cncode, "FITT_T2Z", 8L, 8L) == 0) {
1888 --neval;
1889 r8_eval__[neval - 1] = fitttz_(&r8_eval__[neval - 1], &r8_eval__[
1890 neval]);
1891 /* ...................................................................
1892 .... */
1893 } else if (s_cmp(cncode, "FIFT_T2P", 8L, 8L) == 0) {
1894 neval += -2;
1895 r8_eval__[neval - 1] = fifttp_(&r8_eval__[neval - 1], &r8_eval__[
1896 neval], &r8_eval__[neval + 1]);
1897 } else if (s_cmp(cncode, "FIFT_P2T", 8L, 8L) == 0) {
1898 neval += -2;
1899 r8_eval__[neval - 1] = fiftpt_(&r8_eval__[neval - 1], &r8_eval__[
1900 neval], &r8_eval__[neval + 1]);
1901 } else if (s_cmp(cncode, "FIFT_T2Z", 8L, 8L) == 0) {
1902 neval += -2;
1903 r8_eval__[neval - 1] = fifttz_(&r8_eval__[neval - 1], &r8_eval__[
1904 neval], &r8_eval__[neval + 1]);
1905 /* ...................................................................
1906 .... */
1907 } else if (s_cmp(cncode, "FIZT_T2P", 8L, 8L) == 0) {
1908 d__2 = (d__1 = r8_eval__[neval - 1], abs(d__1));
1909 r8_eval__[neval - 1] = fizttp_(&d__2);
1910 } else if (s_cmp(cncode, "FIZT_P2T", 8L, 8L) == 0) {
1911 r8_eval__[neval - 1] = fiztpt_(&r8_eval__[neval - 1]);
1912 } else if (s_cmp(cncode, "FIZT_T2Z", 8L, 8L) == 0) {
1913 r8_eval__[neval - 1] = fizttz_(&r8_eval__[neval - 1]);
1914 /* ...................................................................
1915 .... */
1916 } else if (s_cmp(cncode, "FICT_T2P", 8L, 8L) == 0) {
1917 --neval;
1918 r8_eval__[neval - 1] = ficttp_(&r8_eval__[neval - 1], &r8_eval__[
1919 neval]);
1920 } else if (s_cmp(cncode, "FICT_P2T", 8L, 8L) == 0) {
1921 --neval;
1922 r8_eval__[neval - 1] = fictpt_(&r8_eval__[neval - 1], &r8_eval__[
1923 neval]);
1924 } else if (s_cmp(cncode, "FICT_T2Z", 8L, 8L) == 0) {
1925 --neval;
1926 r8_eval__[neval - 1] = ficttz_(&r8_eval__[neval - 1], &r8_eval__[
1927 neval]);
1928 /* ...................................................................
1929 .... */
1930 } else if (s_cmp(cncode, "FIBT_T2P", 8L, 8L) == 0) {
1931 neval += -2;
1932 r8_eval__[neval - 1] = fibttp_(&r8_eval__[neval - 1], &r8_eval__[
1933 neval], &r8_eval__[neval + 1]);
1934 } else if (s_cmp(cncode, "FIBT_P2T", 8L, 8L) == 0) {
1935 neval += -2;
1936 r8_eval__[neval - 1] = fibtpt_(&r8_eval__[neval - 1], &r8_eval__[
1937 neval], &r8_eval__[neval + 1]);
1938 } else if (s_cmp(cncode, "FIBT_T2Z", 8L, 8L) == 0) {
1939 neval += -2;
1940 r8_eval__[neval - 1] = fibttz_(&r8_eval__[neval - 1], &r8_eval__[
1941 neval], &r8_eval__[neval + 1]);
1942 /* ...................................................................
1943 .... */
1944 } else if (s_cmp(cncode, "FIBN_T2P", 8L, 8L) == 0) {
1945 neval += -2;
1946 r8_eval__[neval - 1] = fibntp_(&r8_eval__[neval - 1], &r8_eval__[
1947 neval], &r8_eval__[neval + 1]);
1948 } else if (s_cmp(cncode, "FIBN_P2T", 8L, 8L) == 0) {
1949 neval += -2;
1950 r8_eval__[neval - 1] = fibnpt_(&r8_eval__[neval - 1], &r8_eval__[
1951 neval], &r8_eval__[neval + 1]);
1952 } else if (s_cmp(cncode, "FIBN_T2Z", 8L, 8L) == 0) {
1953 neval += -2;
1954 r8_eval__[neval - 1] = fibntz_(&r8_eval__[neval - 1], &r8_eval__[
1955 neval], &r8_eval__[neval + 1]);
1956 /* ...................................................................
1957 .... */
1958 } else if (s_cmp(cncode, "FIGT_T2P", 8L, 8L) == 0) {
1959 neval += -2;
1960 r8_eval__[neval - 1] = figttp_(&r8_eval__[neval - 1], &r8_eval__[
1961 neval], &r8_eval__[neval + 1]);
1962 } else if (s_cmp(cncode, "FIGT_P2T", 8L, 8L) == 0) {
1963 neval += -2;
1964 r8_eval__[neval - 1] = figtpt_(&r8_eval__[neval - 1], &r8_eval__[
1965 neval], &r8_eval__[neval + 1]);
1966 } else if (s_cmp(cncode, "FIGT_T2Z", 8L, 8L) == 0) {
1967 neval += -2;
1968 r8_eval__[neval - 1] = figttz_(&r8_eval__[neval - 1], &r8_eval__[
1969 neval], &r8_eval__[neval + 1]);
1970 /* ...................................................................
1971 .... */
1972 } else if (s_cmp(cncode, "FIPT_T2P", 8L, 8L) == 0) {
1973 --neval;
1974 r8_eval__[neval - 1] = fipttp_(&r8_eval__[neval - 1], &r8_eval__[
1975 neval]);
1976 } else if (s_cmp(cncode, "FIPT_P2T", 8L, 8L) == 0) {
1977 --neval;
1978 r8_eval__[neval - 1] = fiptpt_(&r8_eval__[neval - 1], &r8_eval__[
1979 neval]);
1980 } else if (s_cmp(cncode, "FIPT_T2Z", 8L, 8L) == 0) {
1981 --neval;
1982 r8_eval__[neval - 1] = fipttz_(&r8_eval__[neval - 1], &r8_eval__[
1983 neval]);
1984 /* ...................................................................
1985 .... */
1986 }
1987 /* .......................................................................
1988 */
1989 if (ncode < *num_code__) {
1990 goto L1000;
1991 }
1992 ret_val = r8_eval__[neval - 1];
1993 /* -----------------------------------------------------------------------
1994 */
1995 L8000:
1996 return ret_val;
1997 } /* pareval_ */
1998
1999 #undef r8_val__
2000 #undef c8_val__
2001
2002
2003
2004
2005
parevec_(integer * num_code__,char * c_code__,doublereal * va,doublereal * vb,doublereal * vc,doublereal * vd,doublereal * ve,doublereal * vf,doublereal * vg,doublereal * vh,doublereal * vi,doublereal * vj,doublereal * vk,doublereal * vl,doublereal * vm,doublereal * vn,doublereal * vo,doublereal * vp,doublereal * vq,doublereal * vr,doublereal * vs,doublereal * vt,doublereal * vu,doublereal * vv,doublereal * vw,doublereal * vx,doublereal * vy,doublereal * vz,integer * lvec,doublereal * vout,ftnlen c_code_len)2006 /* Subroutine */ int parevec_(integer *num_code__, char *c_code__, doublereal
2007 *va, doublereal *vb, doublereal *vc, doublereal *vd, doublereal *ve,
2008 doublereal *vf, doublereal *vg, doublereal *vh, doublereal *vi,
2009 doublereal *vj, doublereal *vk, doublereal *vl, doublereal *vm,
2010 doublereal *vn, doublereal *vo, doublereal *vp, doublereal *vq,
2011 doublereal *vr, doublereal *vs, doublereal *vt, doublereal *vu,
2012 doublereal *vv, doublereal *vw, doublereal *vx, doublereal *vy,
2013 doublereal *vz, integer *lvec, doublereal *vout, ftnlen c_code_len)
2014 {
2015 /* System generated locals */
2016 integer i__1, i__2, i__3;
2017 doublereal d__1, d__2;
2018 static doublereal equiv_0[1];
2019
2020 /* Builtin functions */
2021 /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
2022 integer s_cmp(char *, char *, ftnlen, ftnlen);
2023 double d_int(doublereal *), pow_dd(doublereal *, doublereal *), sin(
2024 doublereal), cos(doublereal), tan(doublereal), sqrt(doublereal),
2025 exp(doublereal), log(doublereal), d_lg10(doublereal *), asin(
2026 doublereal), acos(doublereal), atan(doublereal), atan2(doublereal,
2027 doublereal), sinh(doublereal), cosh(doublereal), tanh(doublereal)
2028 ;
2029
2030 /* Local variables */
2031 extern doublereal land_(integer *, doublereal *), mean_(integer *,
2032 doublereal *), derf_(doublereal *), eran_(doublereal *), gran_(
2033 doublereal *, doublereal *), iran_(doublereal *), bool_(
2034 doublereal *), lran_(doublereal *), rect_(doublereal *);
2035 static doublereal scop[101];
2036 extern doublereal uran_(doublereal *), legendre_(doublereal *, doublereal
2037 *), tent_(doublereal *), step_(doublereal *), minabove_(integer *,
2038 doublereal *), maxbelow_(integer *, doublereal *), bell2_(
2039 doublereal *);
2040 static doublereal r8val[1664] /* was [64][26] */;
2041 extern doublereal derfc_(doublereal *);
2042 static integer ncode;
2043 static doublereal x, y;
2044 extern doublereal hmode_(integer *, doublereal *), lmode_(integer *,
2045 doublereal *);
2046 static integer neval;
2047 extern doublereal lmofn_(integer *, integer *, doublereal *);
2048 static integer ivbot;
2049 extern doublereal qginv_(doublereal *), stdev_(integer *, doublereal *);
2050 static char c2code[8];
2051 extern doublereal ztone_(doublereal *);
2052 static integer ivtop;
2053 extern doublereal zzmod_(doublereal *, doublereal *), dbesi0_(doublereal *
2054 ), dbesi1_(doublereal *), dbesj0_(doublereal *), dbesj1_(
2055 doublereal *), dbesk0_(doublereal *), dbesk1_(doublereal *);
2056 #define c8_val__ ((char *)equiv_0)
2057 extern doublereal rhddc2_(doublereal *, doublereal *, doublereal *),
2058 hrfbk4_(doublereal *, doublereal *), hrfbk5_(doublereal *,
2059 doublereal *), cdf2st_(doublereal *, doublereal *, doublereal *,
2060 doublereal *, doublereal *), dbesy0_(doublereal *), dbesy1_(
2061 doublereal *), st2cdf_(doublereal *, doublereal *, doublereal *,
2062 doublereal *, doublereal *);
2063 #define r8_val__ (equiv_0)
2064 static integer jf;
2065 extern doublereal dgamma_(doublereal *);
2066 static integer ialpha, iv;
2067 static char cncode[8];
2068 extern doublereal qg_(doublereal *), median_(integer *, doublereal *),
2069 argmax_(integer *, doublereal *), pairmn_(integer *, doublereal *)
2070 , amongf_(integer *, doublereal *), argnum_(integer *, doublereal
2071 *), choose_(integer *, integer *, doublereal *), lncosh_(
2072 doublereal *), acfwxm_(doublereal *, doublereal *, doublereal *,
2073 doublereal *), ficotp_(doublereal *, doublereal *, doublereal *,
2074 doublereal *), ficopt_(doublereal *, doublereal *, doublereal *,
2075 doublereal *), ficotz_(doublereal *, doublereal *, doublereal *,
2076 doublereal *), pairmx_(integer *, doublereal *), fifttp_(
2077 doublereal *, doublereal *, doublereal *), fiftpt_(doublereal *,
2078 doublereal *, doublereal *), ficttp_(doublereal *, doublereal *),
2079 posval_(doublereal *), fictpt_(doublereal *, doublereal *),
2080 fifttz_(doublereal *, doublereal *, doublereal *), ficttz_(
2081 doublereal *, doublereal *), fibttp_(doublereal *, doublereal *,
2082 doublereal *), fitttp_(doublereal *, doublereal *), fittpt_(
2083 doublereal *, doublereal *), orstat_(integer *, integer *,
2084 doublereal *), fibtpt_(doublereal *, doublereal *, doublereal *),
2085 absextreme_(integer *, doublereal *), fibttz_(doublereal *,
2086 doublereal *, doublereal *), fizttp_(doublereal *), fiztpt_(
2087 doublereal *), fibntp_(doublereal *, doublereal *, doublereal *),
2088 fibnpt_(doublereal *, doublereal *, doublereal *), fitttz_(
2089 doublereal *, doublereal *), fibntz_(doublereal *, doublereal *,
2090 doublereal *), figttp_(doublereal *, doublereal *, doublereal *),
2091 figtpt_(doublereal *, doublereal *, doublereal *), figttz_(
2092 doublereal *, doublereal *, doublereal *), fipttp_(doublereal *,
2093 doublereal *), fizttz_(doublereal *), fiptpt_(doublereal *,
2094 doublereal *), fipttz_(doublereal *, doublereal *), cbrtff_(
2095 doublereal *);
2096 static doublereal r8_eval__[6464] /* was [64][101] */;
2097 extern doublereal dai_(doublereal *), dbi_(doublereal *, integer *), mad_(
2098 integer *, doublereal *);
2099 static integer ibv;
2100 extern doublereal sem_(integer *, doublereal *);
2101 static integer itm, jtm;
2102 extern doublereal lor_(integer *, doublereal *);
2103 static integer ntm;
2104 extern doublereal withinf_(integer *, doublereal *), extreme_(integer *,
2105 doublereal *), isprime_(doublereal *);
2106
2107
2108 /* Vector version of PAREVAL, where VA..VZ with length LVEC */
2109 /* are supplied as vectors. */
2110 /* [Modified by Raoqiong Tong, August 1997] */
2111
2112
2113
2114
2115 /* 14 Jul 1998: add 1D array for stack copy */
2116
2117
2118 /* Internal library functions */
2119
2120
2121 /* External library functions */
2122
2123
2124 /* Statistics functions (01 Mar 1999 - see parser_int.c) */
2125
2126
2127 /* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
2128 */
2129
2130 /* Parameter adjustments */
2131 c_code__ -= 8;
2132 --vout;
2133 --vz;
2134 --vy;
2135 --vx;
2136 --vw;
2137 --vv;
2138 --vu;
2139 --vt;
2140 --vs;
2141 --vr;
2142 --vq;
2143 --vp;
2144 --vo;
2145 --vn;
2146 --vm;
2147 --vl;
2148 --vk;
2149 --vj;
2150 --vi;
2151 --vh;
2152 --vg;
2153 --vf;
2154 --ve;
2155 --vd;
2156 --vc;
2157 --vb;
2158 --va;
2159
2160 /* Function Body */
2161 if (*num_code__ <= 0 || *lvec <= 0) {
2162 goto L8000;
2163 }
2164
2165 ialpha = 'A' - 1;
2166 /* -----------------------------------------------------------------------
2167 */
2168 i__1 = *lvec - 1;
2169 for (ibv = 0; ibv <= i__1; ibv += 64) {
2170 ivbot = ibv + 1;
2171 ivtop = ibv + 64;
2172 if (ivtop > *lvec) {
2173 ivtop = *lvec;
2174 }
2175
2176 /* cc WRITE(*,9802) IVBOT,IVTOP */
2177 /* cc9802 FORMAT(' .. PAREVEC: loop from',I5,' to',I5) */
2178
2179 i__2 = ivtop;
2180 for (iv = ivbot; iv <= i__2; ++iv) {
2181 r8val[iv - ibv - 1] = va[iv];
2182 /* L100: */
2183 }
2184 i__2 = ivtop;
2185 for (iv = ivbot; iv <= i__2; ++iv) {
2186 r8val[iv - ibv + 63] = vb[iv];
2187 /* L101: */
2188 }
2189 i__2 = ivtop;
2190 for (iv = ivbot; iv <= i__2; ++iv) {
2191 r8val[iv - ibv + 127] = vc[iv];
2192 /* L102: */
2193 }
2194 i__2 = ivtop;
2195 for (iv = ivbot; iv <= i__2; ++iv) {
2196 r8val[iv - ibv + 191] = vd[iv];
2197 /* L103: */
2198 }
2199 i__2 = ivtop;
2200 for (iv = ivbot; iv <= i__2; ++iv) {
2201 r8val[iv - ibv + 255] = ve[iv];
2202 /* L104: */
2203 }
2204 i__2 = ivtop;
2205 for (iv = ivbot; iv <= i__2; ++iv) {
2206 r8val[iv - ibv + 319] = vf[iv];
2207 /* L105: */
2208 }
2209 i__2 = ivtop;
2210 for (iv = ivbot; iv <= i__2; ++iv) {
2211 r8val[iv - ibv + 383] = vg[iv];
2212 /* L106: */
2213 }
2214 i__2 = ivtop;
2215 for (iv = ivbot; iv <= i__2; ++iv) {
2216 r8val[iv - ibv + 447] = vh[iv];
2217 /* L107: */
2218 }
2219 i__2 = ivtop;
2220 for (iv = ivbot; iv <= i__2; ++iv) {
2221 r8val[iv - ibv + 511] = vi[iv];
2222 /* L108: */
2223 }
2224 i__2 = ivtop;
2225 for (iv = ivbot; iv <= i__2; ++iv) {
2226 r8val[iv - ibv + 575] = vj[iv];
2227 /* L109: */
2228 }
2229 i__2 = ivtop;
2230 for (iv = ivbot; iv <= i__2; ++iv) {
2231 r8val[iv - ibv + 639] = vk[iv];
2232 /* L110: */
2233 }
2234 i__2 = ivtop;
2235 for (iv = ivbot; iv <= i__2; ++iv) {
2236 r8val[iv - ibv + 703] = vl[iv];
2237 /* L111: */
2238 }
2239 i__2 = ivtop;
2240 for (iv = ivbot; iv <= i__2; ++iv) {
2241 r8val[iv - ibv + 767] = vm[iv];
2242 /* L112: */
2243 }
2244 i__2 = ivtop;
2245 for (iv = ivbot; iv <= i__2; ++iv) {
2246 r8val[iv - ibv + 831] = vn[iv];
2247 /* L113: */
2248 }
2249 i__2 = ivtop;
2250 for (iv = ivbot; iv <= i__2; ++iv) {
2251 r8val[iv - ibv + 895] = vo[iv];
2252 /* L114: */
2253 }
2254 i__2 = ivtop;
2255 for (iv = ivbot; iv <= i__2; ++iv) {
2256 r8val[iv - ibv + 959] = vp[iv];
2257 /* L115: */
2258 }
2259 i__2 = ivtop;
2260 for (iv = ivbot; iv <= i__2; ++iv) {
2261 r8val[iv - ibv + 1023] = vq[iv];
2262 /* L116: */
2263 }
2264 i__2 = ivtop;
2265 for (iv = ivbot; iv <= i__2; ++iv) {
2266 r8val[iv - ibv + 1087] = vr[iv];
2267 /* L117: */
2268 }
2269 i__2 = ivtop;
2270 for (iv = ivbot; iv <= i__2; ++iv) {
2271 r8val[iv - ibv + 1151] = vs[iv];
2272 /* L118: */
2273 }
2274 i__2 = ivtop;
2275 for (iv = ivbot; iv <= i__2; ++iv) {
2276 r8val[iv - ibv + 1215] = vt[iv];
2277 /* L119: */
2278 }
2279 i__2 = ivtop;
2280 for (iv = ivbot; iv <= i__2; ++iv) {
2281 r8val[iv - ibv + 1279] = vu[iv];
2282 /* L120: */
2283 }
2284 i__2 = ivtop;
2285 for (iv = ivbot; iv <= i__2; ++iv) {
2286 r8val[iv - ibv + 1343] = vv[iv];
2287 /* L121: */
2288 }
2289 i__2 = ivtop;
2290 for (iv = ivbot; iv <= i__2; ++iv) {
2291 r8val[iv - ibv + 1407] = vw[iv];
2292 /* L122: */
2293 }
2294 i__2 = ivtop;
2295 for (iv = ivbot; iv <= i__2; ++iv) {
2296 r8val[iv - ibv + 1471] = vx[iv];
2297 /* L123: */
2298 }
2299 i__2 = ivtop;
2300 for (iv = ivbot; iv <= i__2; ++iv) {
2301 r8val[iv - ibv + 1535] = vy[iv];
2302 /* L124: */
2303 }
2304 i__2 = ivtop;
2305 for (iv = ivbot; iv <= i__2; ++iv) {
2306 r8val[iv - ibv + 1599] = vz[iv];
2307 /* L125: */
2308 }
2309
2310 neval = 0;
2311 ncode = 0;
2312
2313 L1000:
2314 ++ncode;
2315 s_copy(cncode, c_code__ + (ncode << 3), 8L, 8L);
2316 /* cc WRITE(*,9803) CNCODE */
2317 /* cc9803 FORMAT(' .. PAREVEC: opcode=',A) */
2318 /* ...................................................................
2319 .... */
2320 if (s_cmp(cncode, "PUSHSYM", 8L, 7L) == 0) {
2321 jf = *(unsigned char *)&c_code__[(ncode + 1) * 8] - ialpha;
2322 if (ncode + 2 <= *num_code__) {
2323 s_copy(c2code, c_code__ + (ncode + 2 << 3), 8L, 8L);
2324 } else {
2325 s_copy(c2code, "q", 8L, 1L);
2326 }
2327 if (s_cmp(c2code, "+", 8L, 1L) == 0) {
2328 ncode += 2;
2329 i__2 = ivtop;
2330 for (iv = ivbot; iv <= i__2; ++iv) {
2331 r8_eval__[iv - ibv + (neval << 6) - 65] += r8val[iv - ibv
2332 + (jf << 6) - 65];
2333 }
2334 } else if (s_cmp(c2code, "-", 8L, 1L) == 0) {
2335 ncode += 2;
2336 i__2 = ivtop;
2337 for (iv = ivbot; iv <= i__2; ++iv) {
2338 r8_eval__[iv - ibv + (neval << 6) - 65] -= r8val[iv - ibv
2339 + (jf << 6) - 65];
2340 }
2341 } else if (s_cmp(c2code, "*", 8L, 1L) == 0) {
2342 ncode += 2;
2343 i__2 = ivtop;
2344 for (iv = ivbot; iv <= i__2; ++iv) {
2345 r8_eval__[iv - ibv + (neval << 6) - 65] *= r8val[iv - ibv
2346 + (jf << 6) - 65];
2347 }
2348 } else if (s_cmp(c2code, "/", 8L, 1L) == 0) {
2349 ncode += 2;
2350 i__2 = ivtop;
2351 for (iv = ivbot; iv <= i__2; ++iv) {
2352 if (r8val[iv - ibv + (jf << 6) - 65] != 0.) {
2353 r8_eval__[iv - ibv + (neval << 6) - 65] /= r8val[iv -
2354 ibv + (jf << 6) - 65];
2355 } else {
2356 r8_eval__[iv - ibv + (neval << 6) - 65] = 0.;
2357 }
2358 }
2359 } else {
2360 ++neval;
2361 ++ncode;
2362 i__2 = ivtop;
2363 for (iv = ivbot; iv <= i__2; ++iv) {
2364 r8_eval__[iv - ibv + (neval << 6) - 65] = r8val[iv - ibv
2365 + (jf << 6) - 65];
2366 }
2367 }
2368 /* ...............................................................
2369 ........ */
2370 } else if (s_cmp(cncode, "PUSHNUM", 8L, 7L) == 0) {
2371 s_copy(c8_val__, c_code__ + (ncode + 1 << 3), 8L, 8L);
2372 if (ncode + 2 <= *num_code__) {
2373 s_copy(c2code, c_code__ + (ncode + 2 << 3), 8L, 8L);
2374 } else {
2375 s_copy(c2code, "q", 8L, 1L);
2376 }
2377 if (s_cmp(c2code, "+", 8L, 1L) == 0) {
2378 ncode += 2;
2379 i__2 = ivtop;
2380 for (iv = ivbot; iv <= i__2; ++iv) {
2381 r8_eval__[iv - ibv + (neval << 6) - 65] += *r8_val__;
2382 }
2383 } else if (s_cmp(c2code, "-", 8L, 1L) == 0) {
2384 ncode += 2;
2385 i__2 = ivtop;
2386 for (iv = ivbot; iv <= i__2; ++iv) {
2387 r8_eval__[iv - ibv + (neval << 6) - 65] -= *r8_val__;
2388 }
2389 } else if (s_cmp(c2code, "*", 8L, 1L) == 0) {
2390 ncode += 2;
2391 i__2 = ivtop;
2392 for (iv = ivbot; iv <= i__2; ++iv) {
2393 r8_eval__[iv - ibv + (neval << 6) - 65] *= *r8_val__;
2394 }
2395 } else if (s_cmp(c2code, "/", 8L, 1L) == 0) {
2396 ncode += 2;
2397 if (*r8_val__ != 0.) {
2398 *r8_val__ = 1. / *r8_val__;
2399 i__2 = ivtop;
2400 for (iv = ivbot; iv <= i__2; ++iv) {
2401 r8_eval__[iv - ibv + (neval << 6) - 65] *= *r8_val__;
2402 }
2403 } else {
2404 i__2 = ivtop;
2405 for (iv = ivbot; iv <= i__2; ++iv) {
2406 r8_eval__[iv - ibv + (neval << 6) - 65] = 0.;
2407 }
2408 }
2409 } else {
2410 ++ncode;
2411 ++neval;
2412 i__2 = ivtop;
2413 for (iv = ivbot; iv <= i__2; ++iv) {
2414 r8_eval__[iv - ibv + (neval << 6) - 65] = *r8_val__;
2415 }
2416 }
2417 /* ...............................................................
2418 ........ */
2419 } else if (s_cmp(cncode, "+", 8L, 1L) == 0) {
2420 --neval;
2421 i__2 = ivtop;
2422 for (iv = ivbot; iv <= i__2; ++iv) {
2423 r8_eval__[iv - ibv + (neval << 6) - 65] += r8_eval__[iv - ibv
2424 + (neval + 1 << 6) - 65];
2425 }
2426 /* ...............................................................
2427 ........ */
2428 } else if (s_cmp(cncode, "-", 8L, 1L) == 0) {
2429 --neval;
2430 i__2 = ivtop;
2431 for (iv = ivbot; iv <= i__2; ++iv) {
2432 r8_eval__[iv - ibv + (neval << 6) - 65] -= r8_eval__[iv - ibv
2433 + (neval + 1 << 6) - 65];
2434 }
2435 /* ...............................................................
2436 ........ */
2437 } else if (s_cmp(cncode, "*", 8L, 1L) == 0) {
2438 --neval;
2439 i__2 = ivtop;
2440 for (iv = ivbot; iv <= i__2; ++iv) {
2441 r8_eval__[iv - ibv + (neval << 6) - 65] *= r8_eval__[iv - ibv
2442 + (neval + 1 << 6) - 65];
2443 }
2444 /* ...............................................................
2445 ........ */
2446 } else if (s_cmp(cncode, "/", 8L, 1L) == 0) {
2447 --neval;
2448 i__2 = ivtop;
2449 for (iv = ivbot; iv <= i__2; ++iv) {
2450 if (r8_eval__[iv - ibv + (neval + 1 << 6) - 65] != 0.) {
2451 r8_eval__[iv - ibv + (neval << 6) - 65] /= r8_eval__[iv -
2452 ibv + (neval + 1 << 6) - 65];
2453 } else {
2454 r8_eval__[iv - ibv + (neval << 6) - 65] = 0.;
2455 }
2456 }
2457 /* ...............................................................
2458 ........ */
2459 } else if (s_cmp(cncode, "**", 8L, 2L) == 0) {
2460 --neval;
2461 i__2 = ivtop;
2462 for (iv = ivbot; iv <= i__2; ++iv) {
2463 if (r8_eval__[iv - ibv + (neval << 6) - 65] > 0. || r8_eval__[
2464 iv - ibv + (neval << 6) - 65] != 0. && r8_eval__[iv -
2465 ibv + (neval + 1 << 6) - 65] == d_int(&r8_eval__[iv -
2466 ibv + (neval + 1 << 6) - 65])) {
2467 r8_eval__[iv - ibv + (neval << 6) - 65] = pow_dd(&
2468 r8_eval__[iv - ibv + (neval << 6) - 65], &
2469 r8_eval__[iv - ibv + (neval + 1 << 6) - 65]);
2470 }
2471 }
2472 /* ...............................................................
2473 ........ */
2474 } else if (s_cmp(cncode, "--", 8L, 2L) == 0) {
2475 i__2 = ivtop;
2476 for (iv = ivbot; iv <= i__2; ++iv) {
2477 r8_eval__[iv - ibv + (neval << 6) - 65] = -r8_eval__[iv - ibv
2478 + (neval << 6) - 65];
2479 }
2480 /* ...............................................................
2481 ........ */
2482 } else if (s_cmp(cncode, "SIN", 8L, 3L) == 0) {
2483 i__2 = ivtop;
2484 for (iv = ivbot; iv <= i__2; ++iv) {
2485 r8_eval__[iv - ibv + (neval << 6) - 65] = sin(r8_eval__[iv -
2486 ibv + (neval << 6) - 65]);
2487 }
2488 /* ...............................................................
2489 ........ */
2490 } else if (s_cmp(cncode, "SIND", 8L, 4L) == 0) {
2491 i__2 = ivtop;
2492 for (iv = ivbot; iv <= i__2; ++iv) {
2493 r8_eval__[iv - ibv + (neval << 6) - 65] = sin(r8_eval__[iv -
2494 ibv + (neval << 6) - 65] * .01745329251994);
2495 }
2496 /* ...............................................................
2497 ........ */
2498 } else if (s_cmp(cncode, "COS", 8L, 3L) == 0) {
2499 i__2 = ivtop;
2500 for (iv = ivbot; iv <= i__2; ++iv) {
2501 r8_eval__[iv - ibv + (neval << 6) - 65] = cos(r8_eval__[iv -
2502 ibv + (neval << 6) - 65]);
2503 }
2504 /* ...............................................................
2505 ........ */
2506 } else if (s_cmp(cncode, "COSD", 8L, 4L) == 0) {
2507 i__2 = ivtop;
2508 for (iv = ivbot; iv <= i__2; ++iv) {
2509 r8_eval__[iv - ibv + (neval << 6) - 65] = cos(r8_eval__[iv -
2510 ibv + (neval << 6) - 65] * .01745329251994);
2511 }
2512 /* ...............................................................
2513 ........ */
2514 } else if (s_cmp(cncode, "TAN", 8L, 3L) == 0) {
2515 i__2 = ivtop;
2516 for (iv = ivbot; iv <= i__2; ++iv) {
2517 r8_eval__[iv - ibv + (neval << 6) - 65] = tan(r8_eval__[iv -
2518 ibv + (neval << 6) - 65]);
2519 }
2520 /* ...............................................................
2521 ........ */
2522 } else if (s_cmp(cncode, "TAND", 8L, 4L) == 0) {
2523 i__2 = ivtop;
2524 for (iv = ivbot; iv <= i__2; ++iv) {
2525 r8_eval__[iv - ibv + (neval << 6) - 65] = tan(r8_eval__[iv -
2526 ibv + (neval << 6) - 65] * .01745329251994);
2527 }
2528 /* ...............................................................
2529 ........ */
2530 } else if (s_cmp(cncode, "SQRT", 8L, 4L) == 0) {
2531 i__2 = ivtop;
2532 for (iv = ivbot; iv <= i__2; ++iv) {
2533 r8_eval__[iv - ibv + (neval << 6) - 65] = sqrt((d__1 =
2534 r8_eval__[iv - ibv + (neval << 6) - 65], abs(d__1)));
2535 }
2536 /* ...............................................................
2537 ........ */
2538 } else if (s_cmp(cncode, "CBRT", 8L, 4L) == 0) {
2539 i__2 = ivtop;
2540 for (iv = ivbot; iv <= i__2; ++iv) {
2541 r8_eval__[iv - ibv + (neval << 6) - 65] = cbrtff_(&r8_eval__[
2542 iv - ibv + (neval << 6) - 65]);
2543 }
2544 /* ...............................................................
2545 ........ */
2546 } else if (s_cmp(cncode, "ABS", 8L, 3L) == 0) {
2547 i__2 = ivtop;
2548 for (iv = ivbot; iv <= i__2; ++iv) {
2549 /* cc WRITE(*,9809) IV */
2550 /* cc9809 FORMAT(' about to ABS #',I5) */
2551 r8_eval__[iv - ibv + (neval << 6) - 65] = (d__1 = r8_eval__[
2552 iv - ibv + (neval << 6) - 65], abs(d__1));
2553 }
2554 /* ...............................................................
2555 ........ */
2556 } else if (s_cmp(cncode, "EXP", 8L, 3L) == 0) {
2557 i__2 = ivtop;
2558 for (iv = ivbot; iv <= i__2; ++iv) {
2559 /* Computing MIN */
2560 d__1 = 87.5f, d__2 = r8_eval__[iv - ibv + (neval << 6) - 65];
2561 r8_eval__[iv - ibv + (neval << 6) - 65] = exp((min(d__1,d__2))
2562 );
2563 }
2564 /* ...............................................................
2565 ........ */
2566 } else if (s_cmp(cncode, "LOG", 8L, 3L) == 0) {
2567 i__2 = ivtop;
2568 for (iv = ivbot; iv <= i__2; ++iv) {
2569 if (r8_eval__[iv - ibv + (neval << 6) - 65] != 0.) {
2570 r8_eval__[iv - ibv + (neval << 6) - 65] = log((d__1 =
2571 r8_eval__[iv - ibv + (neval << 6) - 65], abs(d__1)
2572 ));
2573 }
2574 }
2575 /* ...............................................................
2576 ........ */
2577 } else if (s_cmp(cncode, "LOG10", 8L, 5L) == 0) {
2578 i__2 = ivtop;
2579 for (iv = ivbot; iv <= i__2; ++iv) {
2580 if (r8_eval__[iv - ibv + (neval << 6) - 65] != 0.) {
2581 d__2 = (d__1 = r8_eval__[iv - ibv + (neval << 6) - 65],
2582 abs(d__1));
2583 r8_eval__[iv - ibv + (neval << 6) - 65] = d_lg10(&d__2);
2584 }
2585 }
2586 /* ...............................................................
2587 ........ */
2588 } else if (s_cmp(cncode, "INT", 8L, 3L) == 0) {
2589 i__2 = ivtop;
2590 for (iv = ivbot; iv <= i__2; ++iv) {
2591 r8_eval__[iv - ibv + (neval << 6) - 65] = d_int(&r8_eval__[iv
2592 - ibv + (neval << 6) - 65]);
2593 }
2594 /* ...............................................................
2595 ........ */
2596 } else if (s_cmp(cncode, "MAX", 8L, 3L) == 0) {
2597 --neval;
2598 i__2 = ivtop;
2599 for (iv = ivbot; iv <= i__2; ++iv) {
2600 /* Computing MAX */
2601 d__1 = r8_eval__[iv - ibv + (neval << 6) - 65], d__2 =
2602 r8_eval__[iv - ibv + (neval + 1 << 6) - 65];
2603 r8_eval__[iv - ibv + (neval << 6) - 65] = max(d__1,d__2);
2604 }
2605 /* ...............................................................
2606 ........ */
2607 } else if (s_cmp(cncode, "MIN", 8L, 3L) == 0) {
2608 --neval;
2609 i__2 = ivtop;
2610 for (iv = ivbot; iv <= i__2; ++iv) {
2611 /* Computing MIN */
2612 d__1 = r8_eval__[iv - ibv + (neval << 6) - 65], d__2 =
2613 r8_eval__[iv - ibv + (neval + 1 << 6) - 65];
2614 r8_eval__[iv - ibv + (neval << 6) - 65] = min(d__1,d__2);
2615 }
2616 /* ...............................................................
2617 ........ */
2618 } else if (s_cmp(cncode, "ASIN", 8L, 4L) == 0) {
2619 i__2 = ivtop;
2620 for (iv = ivbot; iv <= i__2; ++iv) {
2621 if ((d__1 = r8_eval__[iv - ibv + (neval << 6) - 65], abs(d__1)
2622 ) <= 1.) {
2623 r8_eval__[iv - ibv + (neval << 6) - 65] = asin(r8_eval__[
2624 iv - ibv + (neval << 6) - 65]);
2625 }
2626 }
2627 /* ...............................................................
2628 ........ */
2629 } else if (s_cmp(cncode, "ACOS", 8L, 4L) == 0) {
2630 i__2 = ivtop;
2631 for (iv = ivbot; iv <= i__2; ++iv) {
2632 if ((d__1 = r8_eval__[iv - ibv + (neval << 6) - 65], abs(d__1)
2633 ) <= 1.) {
2634 r8_eval__[iv - ibv + (neval << 6) - 65] = acos(r8_eval__[
2635 iv - ibv + (neval << 6) - 65]);
2636 }
2637 }
2638 /* ...............................................................
2639 ........ */
2640 } else if (s_cmp(cncode, "ATAN", 8L, 4L) == 0) {
2641 i__2 = ivtop;
2642 for (iv = ivbot; iv <= i__2; ++iv) {
2643 r8_eval__[iv - ibv + (neval << 6) - 65] = atan(r8_eval__[iv -
2644 ibv + (neval << 6) - 65]);
2645 }
2646 /* ...............................................................
2647 ........ */
2648 } else if (s_cmp(cncode, "ATAN2", 8L, 5L) == 0) {
2649 --neval;
2650 i__2 = ivtop;
2651 for (iv = ivbot; iv <= i__2; ++iv) {
2652 if (r8_eval__[iv - ibv + (neval << 6) - 65] != 0. ||
2653 r8_eval__[iv - ibv + (neval + 1 << 6) - 65] != 0.) {
2654 r8_eval__[iv - ibv + (neval << 6) - 65] = atan2(r8_eval__[
2655 iv - ibv + (neval << 6) - 65], r8_eval__[iv - ibv
2656 + (neval + 1 << 6) - 65]);
2657 }
2658 }
2659 /* ...............................................................
2660 ........ */
2661 } else if (s_cmp(cncode, "GRAN", 8L, 4L) == 0) {
2662 --neval;
2663 i__2 = ivtop;
2664 for (iv = ivbot; iv <= i__2; ++iv) {
2665 r8_eval__[iv - ibv + (neval << 6) - 65] = gran_(&r8_eval__[iv
2666 - ibv + (neval << 6) - 65], &r8_eval__[iv - ibv + (
2667 neval + 1 << 6) - 65]);
2668 }
2669 /* ...............................................................
2670 ........ */
2671 } else if (s_cmp(cncode, "MOD", 8L, 3L) == 0) {
2672 --neval;
2673 i__2 = ivtop;
2674 for (iv = ivbot; iv <= i__2; ++iv) {
2675 r8_eval__[iv - ibv + (neval << 6) - 65] = zzmod_(&r8_eval__[
2676 iv - ibv + (neval << 6) - 65], &r8_eval__[iv - ibv + (
2677 neval + 1 << 6) - 65]);
2678 }
2679 /* ...............................................................
2680 ........ */
2681 } else if (s_cmp(cncode, "URAN", 8L, 4L) == 0) {
2682 i__2 = ivtop;
2683 for (iv = ivbot; iv <= i__2; ++iv) {
2684 r8_eval__[iv - ibv + (neval << 6) - 65] = uran_(&r8_eval__[iv
2685 - ibv + (neval << 6) - 65]);
2686 }
2687 /* ...............................................................
2688 ........ */
2689 } else if (s_cmp(cncode, "IRAN", 8L, 4L) == 0) {
2690 i__2 = ivtop;
2691 for (iv = ivbot; iv <= i__2; ++iv) {
2692 r8_eval__[iv - ibv + (neval << 6) - 65] = iran_(&r8_eval__[iv
2693 - ibv + (neval << 6) - 65]);
2694 }
2695 /* ...............................................................
2696 ........ */
2697 } else if (s_cmp(cncode, "ERAN", 8L, 4L) == 0) {
2698 i__2 = ivtop;
2699 for (iv = ivbot; iv <= i__2; ++iv) {
2700 r8_eval__[iv - ibv + (neval << 6) - 65] = eran_(&r8_eval__[iv
2701 - ibv + (neval << 6) - 65]);
2702 }
2703 /* ...............................................................
2704 ........ */
2705 } else if (s_cmp(cncode, "LRAN", 8L, 4L) == 0) {
2706 i__2 = ivtop;
2707 for (iv = ivbot; iv <= i__2; ++iv) {
2708 r8_eval__[iv - ibv + (neval << 6) - 65] = lran_(&r8_eval__[iv
2709 - ibv + (neval << 6) - 65]);
2710 }
2711 /* ...............................................................
2712 ........ */
2713 } else if (s_cmp(cncode, "PLEG", 8L, 4L) == 0) {
2714 --neval;
2715 i__2 = ivtop;
2716 for (iv = ivbot; iv <= i__2; ++iv) {
2717 r8_eval__[iv - ibv + (neval << 6) - 65] = legendre_(&
2718 r8_eval__[iv - ibv + (neval << 6) - 65], &r8_eval__[
2719 iv - ibv + (neval + 1 << 6) - 65]);
2720 }
2721 /* ...............................................................
2722 ........ */
2723 } else if (s_cmp(cncode, "HRFBK4", 8L, 6L) == 0) {
2724 --neval;
2725 i__2 = ivtop;
2726 for (iv = ivbot; iv <= i__2; ++iv) {
2727 r8_eval__[iv - ibv + (neval << 6) - 65] = hrfbk4_(&r8_eval__[
2728 iv - ibv + (neval << 6) - 65], &r8_eval__[iv - ibv + (
2729 neval + 1 << 6) - 65]);
2730 }
2731 /* ...............................................................
2732 ........ */
2733 } else if (s_cmp(cncode, "HRFBK5", 8L, 6L) == 0) {
2734 --neval;
2735 i__2 = ivtop;
2736 for (iv = ivbot; iv <= i__2; ++iv) {
2737 r8_eval__[iv - ibv + (neval << 6) - 65] = hrfbk5_(&r8_eval__[
2738 iv - ibv + (neval << 6) - 65], &r8_eval__[iv - ibv + (
2739 neval + 1 << 6) - 65]);
2740 }
2741 /* ...............................................................
2742 ........ */
2743 } else if (s_cmp(cncode, "RHDDC2", 8L, 6L) == 0) {
2744 neval += -2;
2745 i__2 = ivtop;
2746 for (iv = ivbot; iv <= i__2; ++iv) {
2747 r8_eval__[iv - ibv + (neval << 6) - 65] = rhddc2_(&r8_eval__[
2748 iv - ibv + (neval << 6) - 65], &r8_eval__[iv - ibv + (
2749 neval + 1 << 6) - 65], &r8_eval__[iv - ibv + (neval +
2750 2 << 6) - 65]);
2751 }
2752 /* ...............................................................
2753 ........ */
2754 } else if (s_cmp(cncode, "SINH", 8L, 4L) == 0) {
2755 i__2 = ivtop;
2756 for (iv = ivbot; iv <= i__2; ++iv) {
2757 if ((d__1 = r8_eval__[iv - ibv + (neval << 6) - 65], abs(d__1)
2758 ) < 87.5f) {
2759 r8_eval__[iv - ibv + (neval << 6) - 65] = sinh(r8_eval__[
2760 iv - ibv + (neval << 6) - 65]);
2761 }
2762 }
2763 /* ...............................................................
2764 ........ */
2765 } else if (s_cmp(cncode, "COSH", 8L, 4L) == 0) {
2766 i__2 = ivtop;
2767 for (iv = ivbot; iv <= i__2; ++iv) {
2768 if ((d__1 = r8_eval__[iv - ibv + (neval << 6) - 65], abs(d__1)
2769 ) < 87.5f) {
2770 r8_eval__[iv - ibv + (neval << 6) - 65] = cosh(r8_eval__[
2771 iv - ibv + (neval << 6) - 65]);
2772 }
2773 }
2774 /* ...............................................................
2775 ........ */
2776 } else if (s_cmp(cncode, "LOGCOSH", 8L, 7L) == 0) {
2777 i__2 = ivtop;
2778 for (iv = ivbot; iv <= i__2; ++iv) {
2779 if ((d__1 = r8_eval__[iv - ibv + (neval << 6) - 65], abs(d__1)
2780 ) < 87.5f) {
2781 r8_eval__[iv - ibv + (neval << 6) - 65] = lncosh_(&
2782 r8_eval__[iv - ibv + (neval << 6) - 65]);
2783 }
2784 }
2785 /* ...............................................................
2786 ........ */
2787 } else if (s_cmp(cncode, "ACFWXM", 8L, 6L) == 0) {
2788 neval += -3;
2789 i__2 = ivtop;
2790 for (iv = ivbot; iv <= i__2; ++iv) {
2791 r8_eval__[iv - ibv + (neval << 6) - 65] = acfwxm_(&r8_eval__[
2792 iv - ibv + (neval << 6) - 65], &r8_eval__[iv - ibv + (
2793 neval + 1 << 6) - 65], &r8_eval__[iv - ibv + (neval +
2794 2 << 6) - 65], &r8_eval__[iv - ibv + (neval + 3 << 6)
2795 - 65]);
2796 }
2797 /* ...............................................................
2798 ........ */
2799 } else if (s_cmp(cncode, "TANH", 8L, 4L) == 0) {
2800 i__2 = ivtop;
2801 for (iv = ivbot; iv <= i__2; ++iv) {
2802 r8_eval__[iv - ibv + (neval << 6) - 65] = tanh(r8_eval__[iv -
2803 ibv + (neval << 6) - 65]);
2804 }
2805 /* ...............................................................
2806 ........ */
2807 } else if (s_cmp(cncode, "ASINH", 8L, 5L) == 0) {
2808 i__2 = ivtop;
2809 for (iv = ivbot; iv <= i__2; ++iv) {
2810 x = (d__1 = r8_eval__[iv - ibv + (neval << 6) - 65], abs(d__1)
2811 );
2812 if (x <= 10.) {
2813 /* Computing 2nd power */
2814 d__1 = x;
2815 y = x + sqrt(d__1 * d__1 + 1.);
2816 } else {
2817 /* Computing 2nd power */
2818 d__1 = 1. / x;
2819 y = x * (sqrt(d__1 * d__1 + 1.) + 1.);
2820 }
2821 y = log(y);
2822 if (r8_eval__[iv - ibv + (neval << 6) - 65] < 0.) {
2823 r8_eval__[iv - ibv + (neval << 6) - 65] = -y;
2824 } else {
2825 r8_eval__[iv - ibv + (neval << 6) - 65] = y;
2826 }
2827 }
2828 /* ...............................................................
2829 ........ */
2830 } else if (s_cmp(cncode, "ACOSH", 8L, 5L) == 0) {
2831 i__2 = ivtop;
2832 for (iv = ivbot; iv <= i__2; ++iv) {
2833 x = r8_eval__[iv - ibv + (neval << 6) - 65];
2834 if (x >= 1.) {
2835 if (x <= 10.) {
2836 /* Computing 2nd power */
2837 d__1 = x;
2838 y = x + sqrt(d__1 * d__1 - 1.);
2839 } else {
2840 /* Computing 2nd power */
2841 d__1 = 1. / x;
2842 y = x * (sqrt(1. - d__1 * d__1) + 1.);
2843 }
2844 r8_eval__[iv - ibv + (neval << 6) - 65] = log(y);
2845 }
2846 }
2847 /* ...............................................................
2848 ........ */
2849 } else if (s_cmp(cncode, "ATANH", 8L, 5L) == 0) {
2850 i__2 = ivtop;
2851 for (iv = ivbot; iv <= i__2; ++iv) {
2852 x = r8_eval__[iv - ibv + (neval << 6) - 65];
2853 if (abs(x) < 1.) {
2854 r8_eval__[iv - ibv + (neval << 6) - 65] = log((x + 1.) / (
2855 1. - x)) * .5;
2856 }
2857 }
2858 /* ...............................................................
2859 ........ */
2860 } else if (s_cmp(cncode, "AI", 8L, 2L) == 0) {
2861 i__2 = ivtop;
2862 for (iv = ivbot; iv <= i__2; ++iv) {
2863 r8_eval__[iv - ibv + (neval << 6) - 65] = dai_(&r8_eval__[iv
2864 - ibv + (neval << 6) - 65]);
2865 }
2866 /* ...............................................................
2867 ........ */
2868 } else if (s_cmp(cncode, "BI", 8L, 2L) == 0) {
2869 i__2 = ivtop;
2870 for (iv = ivbot; iv <= i__2; ++iv) {
2871 r8_eval__[iv - ibv + (neval << 6) - 65] = dbi_(&r8_eval__[iv
2872 - ibv + (neval << 6) - 65], &c__1);
2873 }
2874 /* ...............................................................
2875 ........ */
2876 } else if (s_cmp(cncode, "ERF", 8L, 3L) == 0) {
2877 i__2 = ivtop;
2878 for (iv = ivbot; iv <= i__2; ++iv) {
2879 r8_eval__[iv - ibv + (neval << 6) - 65] = derf_(&r8_eval__[iv
2880 - ibv + (neval << 6) - 65]);
2881 }
2882 } else if (s_cmp(cncode, "ERFC", 8L, 4L) == 0) {
2883 i__2 = ivtop;
2884 for (iv = ivbot; iv <= i__2; ++iv) {
2885 r8_eval__[iv - ibv + (neval << 6) - 65] = derfc_(&r8_eval__[
2886 iv - ibv + (neval << 6) - 65]);
2887 }
2888 /* ...............................................................
2889 ........ */
2890 } else if (s_cmp(cncode, "GAMMA", 8L, 5L) == 0) {
2891 i__2 = ivtop;
2892 for (iv = ivbot; iv <= i__2; ++iv) {
2893 r8_eval__[iv - ibv + (neval << 6) - 65] = dgamma_(&r8_eval__[
2894 iv - ibv + (neval << 6) - 65]);
2895 }
2896 /* ...............................................................
2897 ........ */
2898 } else if (s_cmp(cncode, "I0", 8L, 2L) == 0) {
2899 i__2 = ivtop;
2900 for (iv = ivbot; iv <= i__2; ++iv) {
2901 r8_eval__[iv - ibv + (neval << 6) - 65] = dbesi0_(&r8_eval__[
2902 iv - ibv + (neval << 6) - 65]);
2903 }
2904 } else if (s_cmp(cncode, "I1", 8L, 2L) == 0) {
2905 i__2 = ivtop;
2906 for (iv = ivbot; iv <= i__2; ++iv) {
2907 r8_eval__[iv - ibv + (neval << 6) - 65] = dbesi1_(&r8_eval__[
2908 iv - ibv + (neval << 6) - 65]);
2909 }
2910 /* ...............................................................
2911 ........ */
2912 } else if (s_cmp(cncode, "J0", 8L, 2L) == 0) {
2913 i__2 = ivtop;
2914 for (iv = ivbot; iv <= i__2; ++iv) {
2915 r8_eval__[iv - ibv + (neval << 6) - 65] = dbesj0_(&r8_eval__[
2916 iv - ibv + (neval << 6) - 65]);
2917 }
2918 } else if (s_cmp(cncode, "J1", 8L, 2L) == 0) {
2919 i__2 = ivtop;
2920 for (iv = ivbot; iv <= i__2; ++iv) {
2921 r8_eval__[iv - ibv + (neval << 6) - 65] = dbesj1_(&r8_eval__[
2922 iv - ibv + (neval << 6) - 65]);
2923 }
2924 /* ...............................................................
2925 ........ */
2926 } else if (s_cmp(cncode, "K0", 8L, 2L) == 0) {
2927 i__2 = ivtop;
2928 for (iv = ivbot; iv <= i__2; ++iv) {
2929 r8_eval__[iv - ibv + (neval << 6) - 65] = dbesk0_(&r8_eval__[
2930 iv - ibv + (neval << 6) - 65]);
2931 }
2932 } else if (s_cmp(cncode, "K1", 8L, 2L) == 0) {
2933 i__2 = ivtop;
2934 for (iv = ivbot; iv <= i__2; ++iv) {
2935 r8_eval__[iv - ibv + (neval << 6) - 65] = dbesk1_(&r8_eval__[
2936 iv - ibv + (neval << 6) - 65]);
2937 }
2938 /* ...............................................................
2939 ........ */
2940 } else if (s_cmp(cncode, "Y0", 8L, 2L) == 0) {
2941 i__2 = ivtop;
2942 for (iv = ivbot; iv <= i__2; ++iv) {
2943 r8_eval__[iv - ibv + (neval << 6) - 65] = dbesy0_(&r8_eval__[
2944 iv - ibv + (neval << 6) - 65]);
2945 }
2946 } else if (s_cmp(cncode, "Y1", 8L, 2L) == 0) {
2947 i__2 = ivtop;
2948 for (iv = ivbot; iv <= i__2; ++iv) {
2949 r8_eval__[iv - ibv + (neval << 6) - 65] = dbesy1_(&r8_eval__[
2950 iv - ibv + (neval << 6) - 65]);
2951 }
2952 /* ...............................................................
2953 ........ */
2954 } else if (s_cmp(cncode, "QG", 8L, 2L) == 0) {
2955 i__2 = ivtop;
2956 for (iv = ivbot; iv <= i__2; ++iv) {
2957 r8_eval__[iv - ibv + (neval << 6) - 65] = qg_(&r8_eval__[iv -
2958 ibv + (neval << 6) - 65]);
2959 }
2960 } else if (s_cmp(cncode, "QGINV", 8L, 5L) == 0) {
2961 i__2 = ivtop;
2962 for (iv = ivbot; iv <= i__2; ++iv) {
2963 r8_eval__[iv - ibv + (neval << 6) - 65] = qginv_(&r8_eval__[
2964 iv - ibv + (neval << 6) - 65]);
2965 }
2966 } else if (s_cmp(cncode, "BELL2", 8L, 5L) == 0) {
2967 i__2 = ivtop;
2968 for (iv = ivbot; iv <= i__2; ++iv) {
2969 r8_eval__[iv - ibv + (neval << 6) - 65] = bell2_(&r8_eval__[
2970 iv - ibv + (neval << 6) - 65]);
2971 }
2972 } else if (s_cmp(cncode, "RECT", 8L, 4L) == 0) {
2973 i__2 = ivtop;
2974 for (iv = ivbot; iv <= i__2; ++iv) {
2975 r8_eval__[iv - ibv + (neval << 6) - 65] = rect_(&r8_eval__[iv
2976 - ibv + (neval << 6) - 65]);
2977 }
2978 } else if (s_cmp(cncode, "STEP", 8L, 4L) == 0) {
2979 i__2 = ivtop;
2980 for (iv = ivbot; iv <= i__2; ++iv) {
2981 r8_eval__[iv - ibv + (neval << 6) - 65] = step_(&r8_eval__[iv
2982 - ibv + (neval << 6) - 65]);
2983 }
2984 } else if (s_cmp(cncode, "POSVAL", 8L, 6L) == 0) {
2985 i__2 = ivtop;
2986 for (iv = ivbot; iv <= i__2; ++iv) {
2987 r8_eval__[iv - ibv + (neval << 6) - 65] = posval_(&r8_eval__[
2988 iv - ibv + (neval << 6) - 65]);
2989 }
2990 } else if (s_cmp(cncode, "TENT", 8L, 4L) == 0) {
2991 i__2 = ivtop;
2992 for (iv = ivbot; iv <= i__2; ++iv) {
2993 r8_eval__[iv - ibv + (neval << 6) - 65] = tent_(&r8_eval__[iv
2994 - ibv + (neval << 6) - 65]);
2995 }
2996 } else if (s_cmp(cncode, "BOOL", 8L, 4L) == 0) {
2997 i__2 = ivtop;
2998 for (iv = ivbot; iv <= i__2; ++iv) {
2999 r8_eval__[iv - ibv + (neval << 6) - 65] = bool_(&r8_eval__[iv
3000 - ibv + (neval << 6) - 65]);
3001 }
3002 } else if (s_cmp(cncode, "ZTONE", 8L, 5L) == 0) {
3003 i__2 = ivtop;
3004 for (iv = ivbot; iv <= i__2; ++iv) {
3005 r8_eval__[iv - ibv + (neval << 6) - 65] = ztone_(&r8_eval__[
3006 iv - ibv + (neval << 6) - 65]);
3007 }
3008 /* ...............................................................
3009 ........ */
3010 } else if (s_cmp(cncode, "ISPRIME", 8L, 7L) == 0) {
3011 i__2 = ivtop;
3012 for (iv = ivbot; iv <= i__2; ++iv) {
3013 r8_eval__[iv - ibv + (neval << 6) - 65] = isprime_(&r8_eval__[
3014 iv - ibv + (neval << 6) - 65]);
3015 }
3016 /* ...............................................................
3017 ........ */
3018 } else if (s_cmp(cncode, "CDF2STAT", 8L, 8L) == 0) {
3019 neval += -4;
3020 i__2 = ivtop;
3021 for (iv = ivbot; iv <= i__2; ++iv) {
3022 r8_eval__[iv - ibv + (neval << 6) - 65] = cdf2st_(&r8_eval__[
3023 iv - ibv + (neval << 6) - 65], &r8_eval__[iv - ibv + (
3024 neval + 1 << 6) - 65], &r8_eval__[iv - ibv + (neval +
3025 2 << 6) - 65], &r8_eval__[iv - ibv + (neval + 3 << 6)
3026 - 65], &r8_eval__[iv - ibv + (neval + 4 << 6) - 65]);
3027 }
3028 } else if (s_cmp(cncode, "STAT2CDF", 8L, 8L) == 0) {
3029 neval += -4;
3030 i__2 = ivtop;
3031 for (iv = ivbot; iv <= i__2; ++iv) {
3032 r8_eval__[iv - ibv + (neval << 6) - 65] = st2cdf_(&r8_eval__[
3033 iv - ibv + (neval << 6) - 65], &r8_eval__[iv - ibv + (
3034 neval + 1 << 6) - 65], &r8_eval__[iv - ibv + (neval +
3035 2 << 6) - 65], &r8_eval__[iv - ibv + (neval + 3 << 6)
3036 - 65], &r8_eval__[iv - ibv + (neval + 4 << 6) - 65]);
3037 }
3038 /* ...............................................................
3039 ........ */
3040 } else if (s_cmp(cncode, "NOTZERO", 8L, 7L) == 0) {
3041 i__2 = ivtop;
3042 for (iv = ivbot; iv <= i__2; ++iv) {
3043 r8_eval__[iv - ibv + (neval << 6) - 65] = bool_(&r8_eval__[iv
3044 - ibv + (neval << 6) - 65]);
3045 }
3046 } else if (s_cmp(cncode, "ISZERO", 8L, 6L) == 0 || s_cmp(cncode,
3047 "NOT", 8L, 3L) == 0) {
3048 i__2 = ivtop;
3049 for (iv = ivbot; iv <= i__2; ++iv) {
3050 r8_eval__[iv - ibv + (neval << 6) - 65] = 1. - bool_(&
3051 r8_eval__[iv - ibv + (neval << 6) - 65]);
3052 }
3053 } else if (s_cmp(cncode, "EQUALS", 8L, 6L) == 0) {
3054 --neval;
3055 i__2 = ivtop;
3056 for (iv = ivbot; iv <= i__2; ++iv) {
3057 d__1 = r8_eval__[iv - ibv + (neval << 6) - 65] - r8_eval__[iv
3058 - ibv + (neval + 1 << 6) - 65];
3059 r8_eval__[iv - ibv + (neval << 6) - 65] = 1. - bool_(&d__1);
3060 }
3061 } else if (s_cmp(cncode, "ISPOSITI", 8L, 8L) == 0) {
3062 i__2 = ivtop;
3063 for (iv = ivbot; iv <= i__2; ++iv) {
3064 r8_eval__[iv - ibv + (neval << 6) - 65] = step_(&r8_eval__[iv
3065 - ibv + (neval << 6) - 65]);
3066 }
3067 } else if (s_cmp(cncode, "ISNEGATI", 8L, 8L) == 0) {
3068 i__2 = ivtop;
3069 for (iv = ivbot; iv <= i__2; ++iv) {
3070 d__1 = -r8_eval__[iv - ibv + (neval << 6) - 65];
3071 r8_eval__[iv - ibv + (neval << 6) - 65] = step_(&d__1);
3072 }
3073 /* ...............................................................
3074 ........ */
3075 } else if (s_cmp(cncode, "AND", 8L, 3L) == 0) {
3076 ntm = (integer) r8_eval__[(neval << 6) - 64];
3077 neval -= ntm;
3078 i__2 = ivtop;
3079 for (iv = ivbot; iv <= i__2; ++iv) {
3080 i__3 = ntm;
3081 for (jtm = 1; jtm <= i__3; ++jtm) {
3082 scop[jtm - 1] = r8_eval__[iv - ibv + (neval + jtm - 1 <<
3083 6) - 65];
3084 }
3085 r8_eval__[iv - ibv + (neval << 6) - 65] = land_(&ntm, scop);
3086 }
3087 } else if (s_cmp(cncode, "MEDIAN", 8L, 6L) == 0) {
3088 ntm = (integer) r8_eval__[(neval << 6) - 64];
3089 neval -= ntm;
3090 i__2 = ivtop;
3091 for (iv = ivbot; iv <= i__2; ++iv) {
3092 i__3 = ntm;
3093 for (jtm = 1; jtm <= i__3; ++jtm) {
3094 scop[jtm - 1] = r8_eval__[iv - ibv + (neval + jtm - 1 <<
3095 6) - 65];
3096 }
3097 r8_eval__[iv - ibv + (neval << 6) - 65] = median_(&ntm, scop);
3098 }
3099 } else if (s_cmp(cncode, "MAD", 8L, 3L) == 0) {
3100 ntm = (integer) r8_eval__[(neval << 6) - 64];
3101 neval -= ntm;
3102 i__2 = ivtop;
3103 for (iv = ivbot; iv <= i__2; ++iv) {
3104 i__3 = ntm;
3105 for (jtm = 1; jtm <= i__3; ++jtm) {
3106 scop[jtm - 1] = r8_eval__[iv - ibv + (neval + jtm - 1 <<
3107 6) - 65];
3108 }
3109 r8_eval__[iv - ibv + (neval << 6) - 65] = mad_(&ntm, scop);
3110 }
3111 } else if (s_cmp(cncode, "MEAN", 8L, 4L) == 0) {
3112 ntm = (integer) r8_eval__[(neval << 6) - 64];
3113 neval -= ntm;
3114 i__2 = ivtop;
3115 for (iv = ivbot; iv <= i__2; ++iv) {
3116 i__3 = ntm;
3117 for (jtm = 1; jtm <= i__3; ++jtm) {
3118 scop[jtm - 1] = r8_eval__[iv - ibv + (neval + jtm - 1 <<
3119 6) - 65];
3120 }
3121 r8_eval__[iv - ibv + (neval << 6) - 65] = mean_(&ntm, scop);
3122 }
3123 } else if (s_cmp(cncode, "STDEV", 8L, 5L) == 0) {
3124 ntm = (integer) r8_eval__[(neval << 6) - 64];
3125 neval -= ntm;
3126 i__2 = ivtop;
3127 for (iv = ivbot; iv <= i__2; ++iv) {
3128 i__3 = ntm;
3129 for (jtm = 1; jtm <= i__3; ++jtm) {
3130 scop[jtm - 1] = r8_eval__[iv - ibv + (neval + jtm - 1 <<
3131 6) - 65];
3132 }
3133 r8_eval__[iv - ibv + (neval << 6) - 65] = stdev_(&ntm, scop);
3134 }
3135 } else if (s_cmp(cncode, "SEM", 8L, 3L) == 0) {
3136 ntm = (integer) r8_eval__[(neval << 6) - 64];
3137 neval -= ntm;
3138 i__2 = ivtop;
3139 for (iv = ivbot; iv <= i__2; ++iv) {
3140 i__3 = ntm;
3141 for (jtm = 1; jtm <= i__3; ++jtm) {
3142 scop[jtm - 1] = r8_eval__[iv - ibv + (neval + jtm - 1 <<
3143 6) - 65];
3144 }
3145 r8_eval__[iv - ibv + (neval << 6) - 65] = sem_(&ntm, scop);
3146 }
3147 } else if (s_cmp(cncode, "ORSTAT", 8L, 6L) == 0) {
3148 ntm = (integer) r8_eval__[(neval << 6) - 64];
3149 neval -= ntm;
3150 --ntm;
3151 i__2 = ivtop;
3152 for (iv = ivbot; iv <= i__2; ++iv) {
3153 itm = (integer) r8_eval__[iv - ibv + (neval << 6) - 65];
3154 i__3 = ntm;
3155 for (jtm = 1; jtm <= i__3; ++jtm) {
3156 scop[jtm - 1] = r8_eval__[iv - ibv + (neval + jtm << 6) -
3157 65];
3158 }
3159 r8_eval__[iv - ibv + (neval << 6) - 65] = orstat_(&itm, &ntm,
3160 scop);
3161 }
3162 } else if (s_cmp(cncode, "HMODE", 8L, 5L) == 0) {
3163 ntm = (integer) r8_eval__[(neval << 6) - 64];
3164 neval -= ntm;
3165 i__2 = ivtop;
3166 for (iv = ivbot; iv <= i__2; ++iv) {
3167 i__3 = ntm;
3168 for (jtm = 1; jtm <= i__3; ++jtm) {
3169 scop[jtm - 1] = r8_eval__[iv - ibv + (neval + jtm - 1 <<
3170 6) - 65];
3171 }
3172 r8_eval__[iv - ibv + (neval << 6) - 65] = hmode_(&ntm, scop);
3173 }
3174 } else if (s_cmp(cncode, "LMODE", 8L, 5L) == 0) {
3175 ntm = (integer) r8_eval__[(neval << 6) - 64];
3176 neval -= ntm;
3177 i__2 = ivtop;
3178 for (iv = ivbot; iv <= i__2; ++iv) {
3179 i__3 = ntm;
3180 for (jtm = 1; jtm <= i__3; ++jtm) {
3181 scop[jtm - 1] = r8_eval__[iv - ibv + (neval + jtm - 1 <<
3182 6) - 65];
3183 }
3184 r8_eval__[iv - ibv + (neval << 6) - 65] = lmode_(&ntm, scop);
3185 }
3186 } else if (s_cmp(cncode, "OR", 8L, 2L) == 0) {
3187 ntm = (integer) r8_eval__[(neval << 6) - 64];
3188 neval -= ntm;
3189 i__2 = ivtop;
3190 for (iv = ivbot; iv <= i__2; ++iv) {
3191 i__3 = ntm;
3192 for (jtm = 1; jtm <= i__3; ++jtm) {
3193 scop[jtm - 1] = r8_eval__[iv - ibv + (neval + jtm - 1 <<
3194 6) - 65];
3195 }
3196 r8_eval__[iv - ibv + (neval << 6) - 65] = lor_(&ntm, scop);
3197 }
3198 } else if (s_cmp(cncode, "MOFN", 8L, 4L) == 0) {
3199 ntm = (integer) r8_eval__[(neval << 6) - 64];
3200 neval -= ntm;
3201 --ntm;
3202 i__2 = ivtop;
3203 for (iv = ivbot; iv <= i__2; ++iv) {
3204 itm = (integer) r8_eval__[iv - ibv + (neval << 6) - 65];
3205 i__3 = ntm;
3206 for (jtm = 1; jtm <= i__3; ++jtm) {
3207 scop[jtm - 1] = r8_eval__[iv - ibv + (neval + jtm << 6) -
3208 65];
3209 }
3210 r8_eval__[iv - ibv + (neval << 6) - 65] = lmofn_(&itm, &ntm,
3211 scop);
3212 }
3213 } else if (s_cmp(cncode, "ASTEP", 8L, 5L) == 0) {
3214 --neval;
3215 i__2 = ivtop;
3216 for (iv = ivbot; iv <= i__2; ++iv) {
3217 if ((d__1 = r8_eval__[iv - ibv + (neval << 6) - 65], abs(d__1)
3218 ) > r8_eval__[iv - ibv + (neval + 1 << 6) - 65]) {
3219 r8_eval__[iv - ibv + (neval << 6) - 65] = 1.;
3220 } else {
3221 r8_eval__[iv - ibv + (neval << 6) - 65] = 0.;
3222 }
3223 }
3224 } else if (s_cmp(cncode, "ARGMAX", 8L, 6L) == 0) {
3225 ntm = (integer) r8_eval__[(neval << 6) - 64];
3226 neval -= ntm;
3227 i__2 = ivtop;
3228 for (iv = ivbot; iv <= i__2; ++iv) {
3229 i__3 = ntm;
3230 for (jtm = 1; jtm <= i__3; ++jtm) {
3231 scop[jtm - 1] = r8_eval__[iv - ibv + (neval + jtm - 1 <<
3232 6) - 65];
3233 }
3234 r8_eval__[iv - ibv + (neval << 6) - 65] = argmax_(&ntm, scop);
3235 }
3236 } else if (s_cmp(cncode, "ARGNUM", 8L, 6L) == 0) {
3237 ntm = (integer) r8_eval__[(neval << 6) - 64];
3238 neval -= ntm;
3239 i__2 = ivtop;
3240 for (iv = ivbot; iv <= i__2; ++iv) {
3241 i__3 = ntm;
3242 for (jtm = 1; jtm <= i__3; ++jtm) {
3243 scop[jtm - 1] = r8_eval__[iv - ibv + (neval + jtm - 1 <<
3244 6) - 65];
3245 }
3246 r8_eval__[iv - ibv + (neval << 6) - 65] = argnum_(&ntm, scop);
3247 }
3248 } else if (s_cmp(cncode, "PAIRMAX", 8L, 7L) == 0) {
3249 ntm = (integer) r8_eval__[(neval << 6) - 64];
3250 neval -= ntm;
3251 i__2 = ivtop;
3252 for (iv = ivbot; iv <= i__2; ++iv) {
3253 i__3 = ntm;
3254 for (jtm = 1; jtm <= i__3; ++jtm) {
3255 scop[jtm - 1] = r8_eval__[iv - ibv + (neval + jtm - 1 <<
3256 6) - 65];
3257 }
3258 r8_eval__[iv - ibv + (neval << 6) - 65] = pairmx_(&ntm, scop);
3259 }
3260 } else if (s_cmp(cncode, "PAIRMIN", 8L, 7L) == 0) {
3261 ntm = (integer) r8_eval__[(neval << 6) - 64];
3262 neval -= ntm;
3263 i__2 = ivtop;
3264 for (iv = ivbot; iv <= i__2; ++iv) {
3265 i__3 = ntm;
3266 for (jtm = 1; jtm <= i__3; ++jtm) {
3267 scop[jtm - 1] = r8_eval__[iv - ibv + (neval + jtm - 1 <<
3268 6) - 65];
3269 }
3270 r8_eval__[iv - ibv + (neval << 6) - 65] = pairmn_(&ntm, scop);
3271 }
3272 } else if (s_cmp(cncode, "AMONGST", 8L, 7L) == 0) {
3273 ntm = (integer) r8_eval__[(neval << 6) - 64];
3274 neval -= ntm;
3275 i__2 = ivtop;
3276 for (iv = ivbot; iv <= i__2; ++iv) {
3277 i__3 = ntm;
3278 for (jtm = 1; jtm <= i__3; ++jtm) {
3279 scop[jtm - 1] = r8_eval__[iv - ibv + (neval + jtm - 1 <<
3280 6) - 65];
3281 }
3282 r8_eval__[iv - ibv + (neval << 6) - 65] = amongf_(&ntm, scop);
3283 }
3284 } else if (s_cmp(cncode, "WITHIN", 8L, 6L) == 0) {
3285 ntm = (integer) r8_eval__[(neval << 6) - 64];
3286 neval -= ntm;
3287 i__2 = ivtop;
3288 for (iv = ivbot; iv <= i__2; ++iv) {
3289 i__3 = ntm;
3290 for (jtm = 1; jtm <= i__3; ++jtm) {
3291 scop[jtm - 1] = r8_eval__[iv - ibv + (neval + jtm - 1 <<
3292 6) - 65];
3293 }
3294 r8_eval__[iv - ibv + (neval << 6) - 65] = withinf_(&ntm, scop)
3295 ;
3296 }
3297 } else if (s_cmp(cncode, "MINABOVE", 8L, 8L) == 0) {
3298 ntm = (integer) r8_eval__[(neval << 6) - 64];
3299 neval -= ntm;
3300 i__2 = ivtop;
3301 for (iv = ivbot; iv <= i__2; ++iv) {
3302 i__3 = ntm;
3303 for (jtm = 1; jtm <= i__3; ++jtm) {
3304 scop[jtm - 1] = r8_eval__[iv - ibv + (neval + jtm - 1 <<
3305 6) - 65];
3306 }
3307 r8_eval__[iv - ibv + (neval << 6) - 65] = minabove_(&ntm,
3308 scop);
3309 }
3310 } else if (s_cmp(cncode, "MAXBELOW", 8L, 8L) == 0) {
3311 ntm = (integer) r8_eval__[(neval << 6) - 64];
3312 neval -= ntm;
3313 i__2 = ivtop;
3314 for (iv = ivbot; iv <= i__2; ++iv) {
3315 i__3 = ntm;
3316 for (jtm = 1; jtm <= i__3; ++jtm) {
3317 scop[jtm - 1] = r8_eval__[iv - ibv + (neval + jtm - 1 <<
3318 6) - 65];
3319 }
3320 r8_eval__[iv - ibv + (neval << 6) - 65] = maxbelow_(&ntm,
3321 scop);
3322 }
3323 } else if (s_cmp(cncode, "EXTREME", 8L, 7L) == 0) {
3324 ntm = (integer) r8_eval__[(neval << 6) - 64];
3325 neval -= ntm;
3326 i__2 = ivtop;
3327 for (iv = ivbot; iv <= i__2; ++iv) {
3328 i__3 = ntm;
3329 for (jtm = 1; jtm <= i__3; ++jtm) {
3330 scop[jtm - 1] = r8_eval__[iv - ibv + (neval + jtm - 1 <<
3331 6) - 65];
3332 }
3333 r8_eval__[iv - ibv + (neval << 6) - 65] = extreme_(&ntm, scop)
3334 ;
3335 }
3336 } else if (s_cmp(cncode, "ABSEXTREME", 8L, 10L) == 0) {
3337 ntm = (integer) r8_eval__[(neval << 6) - 64];
3338 neval -= ntm;
3339 i__2 = ivtop;
3340 for (iv = ivbot; iv <= i__2; ++iv) {
3341 i__3 = ntm;
3342 for (jtm = 1; jtm <= i__3; ++jtm) {
3343 scop[jtm - 1] = r8_eval__[iv - ibv + (neval + jtm - 1 <<
3344 6) - 65];
3345 }
3346 r8_eval__[iv - ibv + (neval << 6) - 65] = absextreme_(&ntm,
3347 scop);
3348 }
3349 } else if (s_cmp(cncode, "CHOOSE", 8L, 6L) == 0) {
3350 ntm = (integer) r8_eval__[(neval << 6) - 64];
3351 neval -= ntm;
3352 --ntm;
3353 i__2 = ivtop;
3354 for (iv = ivbot; iv <= i__2; ++iv) {
3355 itm = (integer) r8_eval__[iv - ibv + (neval << 6) - 65];
3356 i__3 = ntm;
3357 for (jtm = 1; jtm <= i__3; ++jtm) {
3358 scop[jtm - 1] = r8_eval__[iv - ibv + (neval + jtm << 6) -
3359 65];
3360 }
3361 r8_eval__[iv - ibv + (neval << 6) - 65] = choose_(&itm, &ntm,
3362 scop);
3363 }
3364 } else if (s_cmp(cncode, "IFELSE", 8L, 6L) == 0) {
3365 neval += -2;
3366 i__2 = ivtop;
3367 for (iv = ivbot; iv <= i__2; ++iv) {
3368 if (r8_eval__[iv - ibv + (neval << 6) - 65] != 0.) {
3369 r8_eval__[iv - ibv + (neval << 6) - 65] = r8_eval__[iv -
3370 ibv + (neval + 1 << 6) - 65];
3371 } else {
3372 r8_eval__[iv - ibv + (neval << 6) - 65] = r8_eval__[iv -
3373 ibv + (neval + 2 << 6) - 65];
3374 }
3375 }
3376 /* ...............................................................
3377 ........ */
3378 } else if (s_cmp(cncode, "FICO_T2P", 8L, 8L) == 0) {
3379 neval += -3;
3380 i__2 = ivtop;
3381 for (iv = ivbot; iv <= i__2; ++iv) {
3382 d__2 = (d__1 = r8_eval__[iv - ibv + (neval << 6) - 65], abs(
3383 d__1));
3384 r8_eval__[iv - ibv + (neval << 6) - 65] = ficotp_(&d__2, &
3385 r8_eval__[iv - ibv + (neval + 1 << 6) - 65], &
3386 r8_eval__[iv - ibv + (neval + 2 << 6) - 65], &
3387 r8_eval__[iv - ibv + (neval + 3 << 6) - 65]);
3388 }
3389 } else if (s_cmp(cncode, "FICO_P2T", 8L, 8L) == 0) {
3390 neval += -3;
3391 i__2 = ivtop;
3392 for (iv = ivbot; iv <= i__2; ++iv) {
3393 r8_eval__[iv - ibv + (neval << 6) - 65] = ficopt_(&r8_eval__[
3394 iv - ibv + (neval << 6) - 65], &r8_eval__[iv - ibv + (
3395 neval + 1 << 6) - 65], &r8_eval__[iv - ibv + (neval +
3396 2 << 6) - 65], &r8_eval__[iv - ibv + (neval + 3 << 6)
3397 - 65]);
3398 }
3399 } else if (s_cmp(cncode, "FICO_T2Z", 8L, 8L) == 0) {
3400 neval += -3;
3401 i__2 = ivtop;
3402 for (iv = ivbot; iv <= i__2; ++iv) {
3403 r8_eval__[iv - ibv + (neval << 6) - 65] = ficotz_(&r8_eval__[
3404 iv - ibv + (neval << 6) - 65], &r8_eval__[iv - ibv + (
3405 neval + 1 << 6) - 65], &r8_eval__[iv - ibv + (neval +
3406 2 << 6) - 65], &r8_eval__[iv - ibv + (neval + 3 << 6)
3407 - 65]);
3408 }
3409 /* ...............................................................
3410 ........ */
3411 } else if (s_cmp(cncode, "FITT_T2P", 8L, 8L) == 0) {
3412 --neval;
3413 i__2 = ivtop;
3414 for (iv = ivbot; iv <= i__2; ++iv) {
3415 d__2 = (d__1 = r8_eval__[iv - ibv + (neval << 6) - 65], abs(
3416 d__1));
3417 r8_eval__[iv - ibv + (neval << 6) - 65] = fitttp_(&d__2, &
3418 r8_eval__[iv - ibv + (neval + 1 << 6) - 65]);
3419 }
3420 } else if (s_cmp(cncode, "FITT_P2T", 8L, 8L) == 0) {
3421 --neval;
3422 i__2 = ivtop;
3423 for (iv = ivbot; iv <= i__2; ++iv) {
3424 r8_eval__[iv - ibv + (neval << 6) - 65] = fittpt_(&r8_eval__[
3425 iv - ibv + (neval << 6) - 65], &r8_eval__[iv - ibv + (
3426 neval + 1 << 6) - 65]);
3427 }
3428 } else if (s_cmp(cncode, "FITT_T2Z", 8L, 8L) == 0) {
3429 --neval;
3430 i__2 = ivtop;
3431 for (iv = ivbot; iv <= i__2; ++iv) {
3432 r8_eval__[iv - ibv + (neval << 6) - 65] = fitttz_(&r8_eval__[
3433 iv - ibv + (neval << 6) - 65], &r8_eval__[iv - ibv + (
3434 neval + 1 << 6) - 65]);
3435 }
3436 /* ...............................................................
3437 ........ */
3438 } else if (s_cmp(cncode, "FIFT_T2P", 8L, 8L) == 0) {
3439 neval += -2;
3440 i__2 = ivtop;
3441 for (iv = ivbot; iv <= i__2; ++iv) {
3442 r8_eval__[iv - ibv + (neval << 6) - 65] = fifttp_(&r8_eval__[
3443 iv - ibv + (neval << 6) - 65], &r8_eval__[iv - ibv + (
3444 neval + 1 << 6) - 65], &r8_eval__[iv - ibv + (neval +
3445 2 << 6) - 65]);
3446 }
3447 } else if (s_cmp(cncode, "FIFT_P2T", 8L, 8L) == 0) {
3448 neval += -2;
3449 i__2 = ivtop;
3450 for (iv = ivbot; iv <= i__2; ++iv) {
3451 r8_eval__[iv - ibv + (neval << 6) - 65] = fiftpt_(&r8_eval__[
3452 iv - ibv + (neval << 6) - 65], &r8_eval__[iv - ibv + (
3453 neval + 1 << 6) - 65], &r8_eval__[iv - ibv + (neval +
3454 2 << 6) - 65]);
3455 }
3456 } else if (s_cmp(cncode, "FIFT_T2Z", 8L, 8L) == 0) {
3457 neval += -2;
3458 i__2 = ivtop;
3459 for (iv = ivbot; iv <= i__2; ++iv) {
3460 r8_eval__[iv - ibv + (neval << 6) - 65] = fifttz_(&r8_eval__[
3461 iv - ibv + (neval << 6) - 65], &r8_eval__[iv - ibv + (
3462 neval + 1 << 6) - 65], &r8_eval__[iv - ibv + (neval +
3463 2 << 6) - 65]);
3464 }
3465 /* ...............................................................
3466 ........ */
3467 } else if (s_cmp(cncode, "FIZT_T2P", 8L, 8L) == 0) {
3468 i__2 = ivtop;
3469 for (iv = ivbot; iv <= i__2; ++iv) {
3470 d__2 = (d__1 = r8_eval__[iv - ibv + (neval << 6) - 65], abs(
3471 d__1));
3472 r8_eval__[iv - ibv + (neval << 6) - 65] = fizttp_(&d__2);
3473 }
3474 } else if (s_cmp(cncode, "FIZT_P2T", 8L, 8L) == 0) {
3475 i__2 = ivtop;
3476 for (iv = ivbot; iv <= i__2; ++iv) {
3477 r8_eval__[iv - ibv + (neval << 6) - 65] = fiztpt_(&r8_eval__[
3478 iv - ibv + (neval << 6) - 65]);
3479 }
3480 } else if (s_cmp(cncode, "FIZT_T2Z", 8L, 8L) == 0) {
3481 i__2 = ivtop;
3482 for (iv = ivbot; iv <= i__2; ++iv) {
3483 r8_eval__[iv - ibv + (neval << 6) - 65] = fizttz_(&r8_eval__[
3484 iv - ibv + (neval << 6) - 65]);
3485 }
3486 /* ...............................................................
3487 ........ */
3488 } else if (s_cmp(cncode, "FICT_T2P", 8L, 8L) == 0) {
3489 --neval;
3490 i__2 = ivtop;
3491 for (iv = ivbot; iv <= i__2; ++iv) {
3492 r8_eval__[iv - ibv + (neval << 6) - 65] = ficttp_(&r8_eval__[
3493 iv - ibv + (neval << 6) - 65], &r8_eval__[iv - ibv + (
3494 neval + 1 << 6) - 65]);
3495 }
3496 } else if (s_cmp(cncode, "FICT_P2T", 8L, 8L) == 0) {
3497 --neval;
3498 i__2 = ivtop;
3499 for (iv = ivbot; iv <= i__2; ++iv) {
3500 r8_eval__[iv - ibv + (neval << 6) - 65] = fictpt_(&r8_eval__[
3501 iv - ibv + (neval << 6) - 65], &r8_eval__[iv - ibv + (
3502 neval + 1 << 6) - 65]);
3503 }
3504 } else if (s_cmp(cncode, "FICT_T2Z", 8L, 8L) == 0) {
3505 --neval;
3506 i__2 = ivtop;
3507 for (iv = ivbot; iv <= i__2; ++iv) {
3508 r8_eval__[iv - ibv + (neval << 6) - 65] = ficttz_(&r8_eval__[
3509 iv - ibv + (neval << 6) - 65], &r8_eval__[iv - ibv + (
3510 neval + 1 << 6) - 65]);
3511 }
3512 /* ...............................................................
3513 ........ */
3514 } else if (s_cmp(cncode, "FIBT_T2P", 8L, 8L) == 0) {
3515 neval += -2;
3516 i__2 = ivtop;
3517 for (iv = ivbot; iv <= i__2; ++iv) {
3518 r8_eval__[iv - ibv + (neval << 6) - 65] = fibttp_(&r8_eval__[
3519 iv - ibv + (neval << 6) - 65], &r8_eval__[iv - ibv + (
3520 neval + 1 << 6) - 65], &r8_eval__[iv - ibv + (neval +
3521 2 << 6) - 65]);
3522 }
3523 } else if (s_cmp(cncode, "FIBT_P2T", 8L, 8L) == 0) {
3524 neval += -2;
3525 i__2 = ivtop;
3526 for (iv = ivbot; iv <= i__2; ++iv) {
3527 r8_eval__[iv - ibv + (neval << 6) - 65] = fibtpt_(&r8_eval__[
3528 iv - ibv + (neval << 6) - 65], &r8_eval__[iv - ibv + (
3529 neval + 1 << 6) - 65], &r8_eval__[iv - ibv + (neval +
3530 2 << 6) - 65]);
3531 }
3532 } else if (s_cmp(cncode, "FIBT_T2Z", 8L, 8L) == 0) {
3533 neval += -2;
3534 i__2 = ivtop;
3535 for (iv = ivbot; iv <= i__2; ++iv) {
3536 r8_eval__[iv - ibv + (neval << 6) - 65] = fibttz_(&r8_eval__[
3537 iv - ibv + (neval << 6) - 65], &r8_eval__[iv - ibv + (
3538 neval + 1 << 6) - 65], &r8_eval__[iv - ibv + (neval +
3539 2 << 6) - 65]);
3540 }
3541 /* ...............................................................
3542 ........ */
3543 } else if (s_cmp(cncode, "FIBN_T2P", 8L, 8L) == 0) {
3544 neval += -2;
3545 i__2 = ivtop;
3546 for (iv = ivbot; iv <= i__2; ++iv) {
3547 r8_eval__[iv - ibv + (neval << 6) - 65] = fibntp_(&r8_eval__[
3548 iv - ibv + (neval << 6) - 65], &r8_eval__[iv - ibv + (
3549 neval + 1 << 6) - 65], &r8_eval__[iv - ibv + (neval +
3550 2 << 6) - 65]);
3551 }
3552 } else if (s_cmp(cncode, "FIBN_P2T", 8L, 8L) == 0) {
3553 neval += -2;
3554 i__2 = ivtop;
3555 for (iv = ivbot; iv <= i__2; ++iv) {
3556 r8_eval__[iv - ibv + (neval << 6) - 65] = fibnpt_(&r8_eval__[
3557 iv - ibv + (neval << 6) - 65], &r8_eval__[iv - ibv + (
3558 neval + 1 << 6) - 65], &r8_eval__[iv - ibv + (neval +
3559 2 << 6) - 65]);
3560 }
3561 } else if (s_cmp(cncode, "FIBN_T2Z", 8L, 8L) == 0) {
3562 neval += -2;
3563 i__2 = ivtop;
3564 for (iv = ivbot; iv <= i__2; ++iv) {
3565 r8_eval__[iv - ibv + (neval << 6) - 65] = fibntz_(&r8_eval__[
3566 iv - ibv + (neval << 6) - 65], &r8_eval__[iv - ibv + (
3567 neval + 1 << 6) - 65], &r8_eval__[iv - ibv + (neval +
3568 2 << 6) - 65]);
3569 }
3570 /* ...............................................................
3571 ........ */
3572 } else if (s_cmp(cncode, "FIGT_T2P", 8L, 8L) == 0) {
3573 neval += -2;
3574 i__2 = ivtop;
3575 for (iv = ivbot; iv <= i__2; ++iv) {
3576 r8_eval__[iv - ibv + (neval << 6) - 65] = figttp_(&r8_eval__[
3577 iv - ibv + (neval << 6) - 65], &r8_eval__[iv - ibv + (
3578 neval + 1 << 6) - 65], &r8_eval__[iv - ibv + (neval +
3579 2 << 6) - 65]);
3580 }
3581 } else if (s_cmp(cncode, "FIGT_P2T", 8L, 8L) == 0) {
3582 neval += -2;
3583 i__2 = ivtop;
3584 for (iv = ivbot; iv <= i__2; ++iv) {
3585 r8_eval__[iv - ibv + (neval << 6) - 65] = figtpt_(&r8_eval__[
3586 iv - ibv + (neval << 6) - 65], &r8_eval__[iv - ibv + (
3587 neval + 1 << 6) - 65], &r8_eval__[iv - ibv + (neval +
3588 2 << 6) - 65]);
3589 }
3590 } else if (s_cmp(cncode, "FIGT_T2Z", 8L, 8L) == 0) {
3591 neval += -2;
3592 i__2 = ivtop;
3593 for (iv = ivbot; iv <= i__2; ++iv) {
3594 r8_eval__[iv - ibv + (neval << 6) - 65] = figttz_(&r8_eval__[
3595 iv - ibv + (neval << 6) - 65], &r8_eval__[iv - ibv + (
3596 neval + 1 << 6) - 65], &r8_eval__[iv - ibv + (neval +
3597 2 << 6) - 65]);
3598 }
3599 /* ...............................................................
3600 ........ */
3601 } else if (s_cmp(cncode, "FIPT_T2P", 8L, 8L) == 0) {
3602 --neval;
3603 i__2 = ivtop;
3604 for (iv = ivbot; iv <= i__2; ++iv) {
3605 r8_eval__[iv - ibv + (neval << 6) - 65] = fipttp_(&r8_eval__[
3606 iv - ibv + (neval << 6) - 65], &r8_eval__[iv - ibv + (
3607 neval + 1 << 6) - 65]);
3608 }
3609 } else if (s_cmp(cncode, "FIPT_P2T", 8L, 8L) == 0) {
3610 --neval;
3611 i__2 = ivtop;
3612 for (iv = ivbot; iv <= i__2; ++iv) {
3613 r8_eval__[iv - ibv + (neval << 6) - 65] = fiptpt_(&r8_eval__[
3614 iv - ibv + (neval << 6) - 65], &r8_eval__[iv - ibv + (
3615 neval + 1 << 6) - 65]);
3616 }
3617 } else if (s_cmp(cncode, "FIPT_T2Z", 8L, 8L) == 0) {
3618 --neval;
3619 i__2 = ivtop;
3620 for (iv = ivbot; iv <= i__2; ++iv) {
3621 r8_eval__[iv - ibv + (neval << 6) - 65] = fipttz_(&r8_eval__[
3622 iv - ibv + (neval << 6) - 65], &r8_eval__[iv - ibv + (
3623 neval + 1 << 6) - 65]);
3624 }
3625 /* ...............................................................
3626 ........ */
3627 }
3628 /* ------------------------------------------------------------------
3629 ---- */
3630 if (ncode < *num_code__) {
3631 goto L1000;
3632 }
3633
3634 i__2 = ivtop;
3635 for (iv = ivbot; iv <= i__2; ++iv) {
3636 vout[iv] = r8_eval__[iv - ibv + (neval << 6) - 65];
3637 /* L4990: */
3638 }
3639
3640 /* L5000: */
3641 }
3642 /* -----------------------------------------------------------------------
3643 */
3644 L8000:
3645 return 0;
3646 } /* parevec_ */
3647
3648 #undef r8_val__
3649 #undef c8_val__
3650
3651
3652
3653
3654
ztone_(doublereal * x)3655 doublereal ztone_(doublereal *x)
3656 {
3657 /* System generated locals */
3658 doublereal ret_val;
3659
3660 /* Builtin functions */
3661 double tan(doublereal), tanh(doublereal);
3662
3663 /* Local variables */
3664 static doublereal y;
3665
3666 /* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
3667 */
3668
3669 if (*x <= 0.) {
3670 ret_val = 0.;
3671 } else if (*x >= 1.f) {
3672 ret_val = 1.;
3673 } else {
3674 y = (*x * 1.6 - .8) * 1.5707963267948966;
3675 ret_val = (tanh(tan(y)) + .99576486) * .50212657;
3676 }
3677 return ret_val;
3678 } /* ztone_ */
3679
3680
3681
3682
qg_(doublereal * x)3683 doublereal qg_(doublereal *x)
3684 {
3685 /* System generated locals */
3686 doublereal ret_val, d__1;
3687
3688 /* Local variables */
3689 extern doublereal derfc_(doublereal *);
3690
3691
3692 /* Compute the reversed cdf of a Gaussian. */
3693
3694 /* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
3695 */
3696
3697 d__1 = *x / 1.414213562373095;
3698 ret_val = derfc_(&d__1) * .5;
3699 return ret_val;
3700 } /* qg_ */
3701
3702
3703
3704
3705 /* CC The UNIF() function is now in parser_int.c, */
3706 /* CC where it calls upon the C library to do the dirty work. */
3707
3708 /* CC FUNCTION UNIF( XJUNK ) */
3709 /* CC IMPLICIT REAL*8 (A-H,O-Z) */
3710 /* CC PARAMETER ( IA = 99992 , IB = 12345 , IT = 99991 ) */
3711 /* CC PARAMETER ( F = 1.00009D-05 ) */
3712 /* CC DATA IX / 271 / */
3713 /*CCC+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*/
3714 /* CC IX = MOD( IA*IX+IB , IT ) */
3715 /* CC UNIF = F * IX */
3716 /* CC RETURN */
3717 /* CC END */
3718
3719
3720
3721 /* CC FUNCTION UNIF( XJUNK ) */
3722 /* CC IMPLICIT REAL*8 (A-H,O-Z) */
3723 /* CCC */
3724 /* CCC FACTOR - INTEGER OF THE FORM 8*K+5 AS CLOSE AS POSSIBLE */
3725 /* CCC TO 2**26 * (SQRT(5)-1)/2 (GOLDEN SECTION) */
3726 /* CCC TWO28 = 2**28 (I.E. 28 SIGNIFICANT BITS FOR DEVIATES) */
3727 /* CCC */
3728 /* CC PARAMETER ( FACTOR = 41475557.0D+00 , TWO28 = 268435456.0D+00 ) */
3729 /* CCC */
3730 /* CC DATA R / 0.D+00 / */
3731 /* CCC */
3732 /* CCC RETURNS SAMPLE U FROM THE 0,1 -UNIFORM DISTRIBUTION */
3733 /* CCC BY A MULTIPLICATIVE CONGRUENTIAL GENERATOR OF THE FORM */
3734 /* CCC R := R * FACTOR (MOD 1) . */
3735 /* CCC IN THE FIRST CALL R IS INITIALIZED TO */
3736 /* CCC R := IR / 2**28 , */
3737 /* CCC WHERE IR MUST BE OF THE FORM IR = 4*K+1. */
3738 /* CCC THEN R ASSUMES ALL VALUES 0 < (4*K+1)/2**28 < 1 DURING */
3739 /* CCC A FULL PERIOD 2**26 OF SUNIF. */
3740 /*CCC+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*/
3741 /* CCC */
3742 /* CC IF( R .EQ. 0.D+00 ) R = 4000001.D+00 / TWO28 */
3743 /* CC R = DMOD(R*FACTOR,1.0D+00) */
3744 /* CC UNIF = R */
3745 /* CC RETURN */
3746 /* CC END */
3747
3748
3749
iran_(doublereal * top)3750 doublereal iran_(doublereal *top)
3751 {
3752 /* System generated locals */
3753 doublereal ret_val, d__1;
3754
3755 /* Builtin functions */
3756 double d_int(doublereal *);
3757
3758 /* Local variables */
3759 extern doublereal unif_(doublereal *);
3760
3761
3762 /* Return an integer uniformly distributed among 0..TOP */
3763 /* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
3764 */
3765 d__1 = (*top + 1.) * unif_(&c_b433);
3766 ret_val = d_int(&d__1);
3767 return ret_val;
3768 } /* iran_ */
3769
3770
3771
3772
eran_(doublereal * top)3773 doublereal eran_(doublereal *top)
3774 {
3775 /* System generated locals */
3776 doublereal ret_val;
3777
3778 /* Builtin functions */
3779 double log(doublereal);
3780
3781 /* Local variables */
3782 extern doublereal unif_(doublereal *);
3783 static doublereal u1;
3784
3785
3786 /* Return an exponentially distributed deviate: F(x) = 1-exp(-x/top) */
3787 /* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
3788 */
3789 L100:
3790 u1 = unif_(&c_b433);
3791 if (u1 <= 0.) {
3792 goto L100;
3793 }
3794 ret_val = -(*top) * log(u1);
3795 return ret_val;
3796 } /* eran_ */
3797
3798
3799
3800
lran_(doublereal * top)3801 doublereal lran_(doublereal *top)
3802 {
3803 /* System generated locals */
3804 doublereal ret_val;
3805
3806 /* Builtin functions */
3807 double log(doublereal);
3808
3809 /* Local variables */
3810 extern doublereal unif_(doublereal *);
3811 static doublereal u1;
3812
3813
3814 /* Return a logistically distributed deviate: F(x) = 1/[1+exp(-x/top)] */
3815 /* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
3816 */
3817 L100:
3818 u1 = unif_(&c_b433);
3819 if (u1 <= 0. || u1 >= 1.) {
3820 goto L100;
3821 }
3822 ret_val = *top * log(1. / u1 - 1.);
3823 return ret_val;
3824 } /* lran_ */
3825
3826
3827
3828
uran_(doublereal * x)3829 doublereal uran_(doublereal *x)
3830 {
3831 /* System generated locals */
3832 doublereal ret_val;
3833
3834 /* Local variables */
3835 extern doublereal unif_(doublereal *);
3836
3837
3838 /* Return a U(0,X) random variable. */
3839 /* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
3840 */
3841
3842 ret_val = *x * unif_(&c_b433);
3843 return ret_val;
3844 } /* uran_ */
3845
3846
3847
3848
gran2_(doublereal * b,doublereal * s)3849 doublereal gran2_(doublereal *b, doublereal *s)
3850 {
3851 /* Initialized data */
3852
3853 static integer ip = 0;
3854
3855 /* System generated locals */
3856 doublereal ret_val;
3857
3858 /* Builtin functions */
3859 double log(doublereal), sqrt(doublereal), sin(doublereal), cos(doublereal)
3860 ;
3861
3862 /* Local variables */
3863 extern doublereal unif_(doublereal *);
3864 static doublereal u1, u2;
3865
3866
3867 /* Compute a Gaussian random deviate with mean B and stdev S */
3868
3869 /* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
3870 */
3871
3872 if (ip == 0) {
3873 L100:
3874 u1 = unif_(&c_b433);
3875 if (u1 <= 0.) {
3876 goto L100;
3877 }
3878 u2 = unif_(&c_b433);
3879 ret_val = *b + *s * sqrt(log(u1) * -2.) * sin(u2 * 6.2831853);
3880 ip = 1;
3881 } else {
3882 ret_val = *b + *s * sqrt(log(u1) * -2.) * cos(u2 * 6.2831853);
3883 ip = 0;
3884 }
3885 return ret_val;
3886 } /* gran2_ */
3887
3888
3889
3890
gran1_(doublereal * b,doublereal * s)3891 doublereal gran1_(doublereal *b, doublereal *s)
3892 {
3893 /* System generated locals */
3894 doublereal ret_val;
3895
3896 /* Local variables */
3897 extern doublereal unif_(doublereal *);
3898 static doublereal g;
3899
3900 /* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
3901 */
3902
3903 g = unif_(&c_b447) - 6. + unif_(&c_b448) + unif_(&c_b449) + unif_(&c_b450)
3904 + unif_(&c_b451) + unif_(&c_b452) + unif_(&c_b453) + unif_(&
3905 c_b454) + unif_(&c_b455) + unif_(&c_b456) + unif_(&c_b457) +
3906 unif_(&c_b458);
3907 ret_val = *b + *s * g;
3908 return ret_val;
3909 } /* gran1_ */
3910
3911
3912
3913
gran_(doublereal * b,doublereal * s)3914 doublereal gran_(doublereal *b, doublereal *s)
3915 {
3916 /* System generated locals */
3917 doublereal ret_val;
3918
3919 /* Local variables */
3920 extern doublereal unif_(doublereal *), gran1_(doublereal *, doublereal *),
3921 gran2_(doublereal *, doublereal *);
3922 static doublereal uu;
3923
3924 /* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
3925 */
3926
3927 uu = unif_(&c_b433);
3928 if (uu <= .5) {
3929 ret_val = gran1_(b, s);
3930 } else {
3931 ret_val = gran2_(b, s);
3932 }
3933 return ret_val;
3934 } /* gran_ */
3935
3936
3937
3938
zzmod_(doublereal * a,doublereal * b)3939 doublereal zzmod_(doublereal *a, doublereal *b)
3940 {
3941 /* System generated locals */
3942 doublereal ret_val, d__1;
3943
3944 /* Builtin functions */
3945 double d_int(doublereal *);
3946
3947 /* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
3948 */
3949
3950 if (*b != 0.) {
3951 d__1 = *a / *b;
3952 ret_val = *a - *b * d_int(&d__1);
3953 } else {
3954 ret_val = 0.;
3955 }
3956 return ret_val;
3957 } /* zzmod_ */
3958
3959
3960
3961
qginv_(doublereal * p)3962 doublereal qginv_(doublereal *p)
3963 {
3964 /* System generated locals */
3965 doublereal ret_val, d__1;
3966
3967 /* Builtin functions */
3968 double log(doublereal), sqrt(doublereal), exp(doublereal);
3969
3970 /* Local variables */
3971 static integer newt;
3972 extern doublereal derfc_(doublereal *);
3973 static doublereal dp, dq, dt, dx, ddq;
3974
3975
3976 /* Return x such that Q(x)=P, for 0 < P < 1. Q=reversed Gaussian cdf. */
3977
3978 /* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
3979 */
3980
3981 dp = *p;
3982 if (dp > .5) {
3983 dp = 1. - dp;
3984 }
3985 if (dp <= 0.) {
3986 dx = 13.;
3987 goto L8000;
3988 }
3989
3990 /* Step 1: use 26.2.23 from Abramowitz and Stegun */
3991
3992 dt = sqrt(log(dp) * -2.);
3993 dx = dt - ((dt * .010328 + .802853) * dt + 2.525517) / (((dt * .001308 +
3994 .189269) * dt + 1.432788) * dt + 1.);
3995
3996 /* Step 2: do 3 Newton steps to improve this */
3997
3998 for (newt = 1; newt <= 3; ++newt) {
3999 d__1 = dx / 1.414213562373095;
4000 dq = derfc_(&d__1) * .5 - dp;
4001 ddq = exp(dx * -.5 * dx) / 2.506628274631;
4002 dx += dq / ddq;
4003 /* L100: */
4004 }
4005
4006 L8000:
4007 if (*p > .5) {
4008 ret_val = -dx;
4009 } else {
4010 ret_val = dx;
4011 }
4012
4013 return ret_val;
4014 } /* qginv_ */
4015
4016
4017
4018
bell2_(doublereal * x)4019 doublereal bell2_(doublereal *x)
4020 {
4021 /* System generated locals */
4022 doublereal ret_val, d__1;
4023
4024 /* Local variables */
4025 static doublereal ax;
4026
4027 /* ... */
4028 ax = abs(*x);
4029 if (ax <= .5) {
4030 ret_val = 1. - ax * 1.3333333333333333 * ax;
4031 } else if (ax <= 1.5) {
4032 /* Computing 2nd power */
4033 d__1 = 1.5 - ax;
4034 ret_val = d__1 * d__1 * .666666666666667;
4035 } else {
4036 ret_val = 0.;
4037 }
4038 return ret_val;
4039 } /* bell2_ */
4040
4041
4042
4043
rect_(doublereal * x)4044 doublereal rect_(doublereal *x)
4045 {
4046 /* System generated locals */
4047 doublereal ret_val;
4048
4049 /* Local variables */
4050 static doublereal ax;
4051
4052 ax = abs(*x);
4053 if (ax <= .5) {
4054 ret_val = 1.;
4055 } else {
4056 ret_val = 0.;
4057 }
4058 return ret_val;
4059 } /* rect_ */
4060
4061
4062
4063
step_(doublereal * x)4064 doublereal step_(doublereal *x)
4065 {
4066 /* System generated locals */
4067 doublereal ret_val;
4068
4069 if (*x <= 0.) {
4070 ret_val = 0.;
4071 } else {
4072 ret_val = 1.;
4073 }
4074 return ret_val;
4075 } /* step_ */
4076
4077
4078
4079
posval_(doublereal * x)4080 doublereal posval_(doublereal *x)
4081 {
4082 /* System generated locals */
4083 doublereal ret_val;
4084
4085 if (*x <= 0.) {
4086 ret_val = 0.;
4087 } else {
4088 ret_val = *x;
4089 }
4090 return ret_val;
4091 } /* posval_ */
4092
4093
4094
4095
tent_(doublereal * x)4096 doublereal tent_(doublereal *x)
4097 {
4098 /* System generated locals */
4099 doublereal ret_val;
4100
4101 /* Local variables */
4102 static doublereal ax;
4103
4104 ax = abs(*x);
4105 if (ax >= 1.) {
4106 ret_val = 0.;
4107 } else {
4108 ret_val = 1. - ax;
4109 }
4110 return ret_val;
4111 } /* tent_ */
4112
4113
4114
4115
bool_(doublereal * x)4116 doublereal bool_(doublereal *x)
4117 {
4118 /* System generated locals */
4119 doublereal ret_val;
4120
4121 if (*x == 0.) {
4122 ret_val = 0.;
4123 } else {
4124 ret_val = 1.;
4125 }
4126 return ret_val;
4127 } /* bool_ */
4128
4129
4130
4131
land_(integer * n,doublereal * x)4132 doublereal land_(integer *n, doublereal *x)
4133 {
4134 /* System generated locals */
4135 integer i__1;
4136 doublereal ret_val;
4137
4138 /* Local variables */
4139 static integer i__;
4140
4141 /* Parameter adjustments */
4142 --x;
4143
4144 /* Function Body */
4145 ret_val = 0.;
4146 i__1 = *n;
4147 for (i__ = 1; i__ <= i__1; ++i__) {
4148 if (x[i__] == 0.) {
4149 return ret_val;
4150 }
4151 /* L100: */
4152 }
4153 ret_val = 1.;
4154 return ret_val;
4155 } /* land_ */
4156
4157
4158
4159
bsort_(integer * n,doublereal * x)4160 /* Subroutine */ int bsort_(integer *n, doublereal *x)
4161 {
4162 /* System generated locals */
4163 integer i__1;
4164
4165 /* Local variables */
4166 static integer i__, it;
4167 static doublereal tmp;
4168
4169 /* ------------------------------------ Bubble sort */
4170 /* Parameter adjustments */
4171 --x;
4172
4173 /* Function Body */
4174 L50:
4175 it = 0;
4176 i__1 = *n;
4177 for (i__ = 2; i__ <= i__1; ++i__) {
4178 if (x[i__ - 1] > x[i__]) {
4179 tmp = x[i__];
4180 x[i__] = x[i__ - 1];
4181 x[i__ - 1] = tmp;
4182 it = 1;
4183 }
4184 /* L100: */
4185 }
4186 if (it != 0) {
4187 goto L50;
4188 }
4189 return 0;
4190 } /* bsort_ */
4191
4192
4193
4194
orstat_(integer * m,integer * n,doublereal * x)4195 doublereal orstat_(integer *m, integer *n, doublereal *x)
4196 {
4197 /* System generated locals */
4198 doublereal ret_val;
4199
4200 /* Local variables */
4201 static integer i__;
4202 extern /* Subroutine */ int bsort_(integer *, doublereal *);
4203
4204
4205 /* Parameter adjustments */
4206 --x;
4207
4208 /* Function Body */
4209 if (*n <= 1) {
4210 ret_val = x[1];
4211 return ret_val;
4212 }
4213
4214 i__ = *m;
4215 if (i__ <= 0) {
4216 i__ = 1;
4217 } else if (i__ > *n) {
4218 i__ = *n;
4219 }
4220 bsort_(n, &x[1]);
4221 ret_val = x[i__];
4222 return ret_val;
4223 } /* orstat_ */
4224
4225
4226
4227
pairmx_(integer * n,doublereal * x)4228 doublereal pairmx_(integer *n, doublereal *x)
4229 {
4230 /* System generated locals */
4231 integer i__1;
4232 doublereal ret_val;
4233
4234 /* Local variables */
4235 static integer i__, m;
4236 static doublereal pp, tt;
4237
4238
4239 /* Parameter adjustments */
4240 --x;
4241
4242 /* Function Body */
4243 if (*n <= 2) {
4244 ret_val = x[2];
4245 return ret_val;
4246 }
4247
4248 m = *n / 2;
4249 tt = x[1];
4250 pp = x[m + 1];
4251 i__1 = m;
4252 for (i__ = 2; i__ <= i__1; ++i__) {
4253 if (x[i__] > tt) {
4254 tt = x[i__];
4255 pp = x[m + i__];
4256 }
4257 }
4258 ret_val = pp;
4259 return ret_val;
4260 } /* pairmx_ */
4261
4262
4263
4264
pairmn_(integer * n,doublereal * x)4265 doublereal pairmn_(integer *n, doublereal *x)
4266 {
4267 /* System generated locals */
4268 integer i__1;
4269 doublereal ret_val;
4270
4271 /* Local variables */
4272 static integer i__, m;
4273 static doublereal bb, pp;
4274
4275
4276 /* Parameter adjustments */
4277 --x;
4278
4279 /* Function Body */
4280 if (*n <= 2) {
4281 ret_val = x[2];
4282 return ret_val;
4283 }
4284
4285 m = *n / 2;
4286 bb = x[1];
4287 pp = x[m + 1];
4288 i__1 = m;
4289 for (i__ = 2; i__ <= i__1; ++i__) {
4290 if (x[i__] < bb) {
4291 bb = x[i__];
4292 pp = x[m + i__];
4293 }
4294 }
4295 ret_val = pp;
4296 return ret_val;
4297 } /* pairmn_ */
4298
4299
4300
4301
amongf_(integer * n,doublereal * x)4302 doublereal amongf_(integer *n, doublereal *x)
4303 {
4304 /* System generated locals */
4305 integer i__1;
4306 doublereal ret_val;
4307
4308 /* Local variables */
4309 static integer i__;
4310
4311 /* Parameter adjustments */
4312 --x;
4313
4314 /* Function Body */
4315 i__1 = *n;
4316 for (i__ = 2; i__ <= i__1; ++i__) {
4317 if (x[1] == x[i__]) {
4318 ret_val = 1.;
4319 return ret_val;
4320 }
4321 }
4322 ret_val = 0.;
4323 return ret_val;
4324 } /* amongf_ */
4325
4326
4327
4328
withinf_(integer * n,doublereal * x)4329 doublereal withinf_(integer *n, doublereal *x)
4330 {
4331 /* System generated locals */
4332 doublereal ret_val;
4333
4334
4335 /* Parameter adjustments */
4336 --x;
4337
4338 /* Function Body */
4339 if (*n < 1) {
4340 ret_val = 0.;
4341 return ret_val;
4342 }
4343 if (x[1] < x[2]) {
4344 ret_val = 0.;
4345 return ret_val;
4346 }
4347 if (x[1] > x[3]) {
4348 ret_val = 0.;
4349 return ret_val;
4350 }
4351 ret_val = 1.;
4352 return ret_val;
4353 } /* withinf_ */
4354
4355
4356
4357
minabove_(integer * n,doublereal * x)4358 doublereal minabove_(integer *n, doublereal *x)
4359 {
4360 /* System generated locals */
4361 integer i__1;
4362 doublereal ret_val;
4363
4364 /* Local variables */
4365 static integer i__;
4366 static doublereal aaa, bbb;
4367
4368
4369 /* Parameter adjustments */
4370 --x;
4371
4372 /* Function Body */
4373 if (*n < 1) {
4374 ret_val = 0.;
4375 return ret_val;
4376 }
4377 aaa = x[1];
4378 if (*n == 1) {
4379 ret_val = aaa;
4380 return ret_val;
4381 }
4382 bbb = 1e38;
4383 i__1 = *n;
4384 for (i__ = 2; i__ <= i__1; ++i__) {
4385 if (x[i__] > aaa && x[i__] < bbb) {
4386 bbb = x[i__];
4387 }
4388 }
4389 if (bbb == 1e38) {
4390 bbb = aaa;
4391 }
4392 ret_val = bbb;
4393 return ret_val;
4394 } /* minabove_ */
4395
4396
4397
4398
maxbelow_(integer * n,doublereal * x)4399 doublereal maxbelow_(integer *n, doublereal *x)
4400 {
4401 /* System generated locals */
4402 integer i__1;
4403 doublereal ret_val;
4404
4405 /* Local variables */
4406 static integer i__;
4407 static doublereal aaa, bbb;
4408
4409
4410 /* Parameter adjustments */
4411 --x;
4412
4413 /* Function Body */
4414 if (*n < 1) {
4415 ret_val = 0.;
4416 return ret_val;
4417 }
4418 aaa = x[1];
4419 if (*n == 1) {
4420 ret_val = aaa;
4421 return ret_val;
4422 }
4423 bbb = -1e38;
4424 i__1 = *n;
4425 for (i__ = 2; i__ <= i__1; ++i__) {
4426 if (x[i__] < aaa && x[i__] > bbb) {
4427 bbb = x[i__];
4428 }
4429 }
4430 if (bbb == -1e38) {
4431 bbb = aaa;
4432 }
4433 ret_val = bbb;
4434 return ret_val;
4435 } /* maxbelow_ */
4436
4437
4438
4439
extreme_(integer * n,doublereal * x)4440 doublereal extreme_(integer *n, doublereal *x)
4441 {
4442 /* System generated locals */
4443 integer i__1;
4444 doublereal ret_val, d__1;
4445
4446 /* Local variables */
4447 static integer i__;
4448 static doublereal aaa, bbb;
4449
4450
4451 /* Parameter adjustments */
4452 --x;
4453
4454 /* Function Body */
4455 if (*n < 1) {
4456 ret_val = 0.;
4457 return ret_val;
4458 }
4459 aaa = x[1];
4460 if (*n == 1) {
4461 ret_val = aaa;
4462 return ret_val;
4463 }
4464 bbb = 0.f;
4465 i__1 = *n;
4466 for (i__ = 1; i__ <= i__1; ++i__) {
4467 if ((d__1 = x[i__], abs(d__1)) > bbb) {
4468 bbb = x[i__];
4469 }
4470 }
4471 if (bbb == 0.f) {
4472 bbb = aaa;
4473 }
4474 ret_val = bbb;
4475 return ret_val;
4476 } /* extreme_ */
4477
4478
4479
4480
absextreme_(integer * n,doublereal * x)4481 doublereal absextreme_(integer *n, doublereal *x)
4482 {
4483 /* System generated locals */
4484 integer i__1;
4485 doublereal ret_val, d__1, d__2;
4486
4487 /* Local variables */
4488 static integer i__;
4489 static doublereal aaa, bbb;
4490
4491
4492 /* Parameter adjustments */
4493 --x;
4494
4495 /* Function Body */
4496 if (*n < 1) {
4497 ret_val = 0.;
4498 return ret_val;
4499 }
4500 aaa = x[1];
4501 if (*n == 1) {
4502 ret_val = aaa;
4503 return ret_val;
4504 }
4505 bbb = 0.f;
4506 i__1 = *n;
4507 for (i__ = 1; i__ <= i__1; ++i__) {
4508 if ((d__1 = x[i__], abs(d__1)) > bbb) {
4509 bbb = (d__2 = x[i__], abs(d__2));
4510 }
4511 }
4512 if (bbb == 0.f) {
4513 bbb = aaa;
4514 }
4515 ret_val = bbb;
4516 return ret_val;
4517 } /* absextreme_ */
4518
4519
4520
4521
choose_(integer * m,integer * n,doublereal * x)4522 doublereal choose_(integer *m, integer *n, doublereal *x)
4523 {
4524 /* System generated locals */
4525 doublereal ret_val;
4526
4527
4528 /* Parameter adjustments */
4529 --x;
4530
4531 /* Function Body */
4532 if (*m < 1 || *n < *m) {
4533 ret_val = 0.;
4534 return ret_val;
4535 }
4536 ret_val = x[*m];
4537 return ret_val;
4538 } /* choose_ */
4539
4540
4541
4542
mean_(integer * n,doublereal * x)4543 doublereal mean_(integer *n, doublereal *x)
4544 {
4545 /* System generated locals */
4546 integer i__1;
4547 doublereal ret_val;
4548
4549 /* Local variables */
4550 static integer it;
4551 static doublereal tmp;
4552
4553
4554 /* Parameter adjustments */
4555 --x;
4556
4557 /* Function Body */
4558 if (*n == 1) {
4559 ret_val = x[1];
4560 return ret_val;
4561 } else if (*n == 2) {
4562 ret_val = (x[1] + x[2]) * .5;
4563 return ret_val;
4564 }
4565 tmp = 0.;
4566 i__1 = *n;
4567 for (it = 1; it <= i__1; ++it) {
4568 tmp += x[it];
4569 }
4570 ret_val = tmp / *n;
4571 return ret_val;
4572 } /* mean_ */
4573
4574
4575
4576
stdev_(integer * n,doublereal * x)4577 doublereal stdev_(integer *n, doublereal *x)
4578 {
4579 /* System generated locals */
4580 integer i__1;
4581 doublereal ret_val, d__1;
4582
4583 /* Builtin functions */
4584 double sqrt(doublereal);
4585
4586 /* Local variables */
4587 static doublereal xbar;
4588 static integer it;
4589 static doublereal tmp;
4590
4591
4592 /* Parameter adjustments */
4593 --x;
4594
4595 /* Function Body */
4596 if (*n == 1) {
4597 ret_val = 0.;
4598 return ret_val;
4599 }
4600 tmp = 0.;
4601 i__1 = *n;
4602 for (it = 1; it <= i__1; ++it) {
4603 tmp += x[it];
4604 }
4605 xbar = tmp / *n;
4606 tmp = 0.;
4607 i__1 = *n;
4608 for (it = 1; it <= i__1; ++it) {
4609 /* Computing 2nd power */
4610 d__1 = x[it] - xbar;
4611 tmp += d__1 * d__1;
4612 }
4613 ret_val = sqrt(tmp / (*n - 1.));
4614 return ret_val;
4615 } /* stdev_ */
4616
4617
4618
4619
sem_(integer * n,doublereal * x)4620 doublereal sem_(integer *n, doublereal *x)
4621 {
4622 /* System generated locals */
4623 doublereal ret_val;
4624
4625 /* Builtin functions */
4626 double sqrt(doublereal);
4627
4628 /* Local variables */
4629 extern doublereal stdev_(integer *, doublereal *);
4630
4631
4632 /* Parameter adjustments */
4633 --x;
4634
4635 /* Function Body */
4636 ret_val = stdev_(n, &x[1]) / sqrt(*n + 1e-6);
4637 return ret_val;
4638 } /* sem_ */
4639
4640
4641
4642
median_(integer * n,doublereal * x)4643 doublereal median_(integer *n, doublereal *x)
4644 {
4645 /* System generated locals */
4646 doublereal ret_val;
4647
4648 /* Local variables */
4649 extern /* Subroutine */ int bsort_(integer *, doublereal *);
4650 static integer it;
4651 static doublereal tmp;
4652
4653
4654 /* Parameter adjustments */
4655 --x;
4656
4657 /* Function Body */
4658 if (*n == 1) {
4659 ret_val = x[1];
4660 return ret_val;
4661 } else if (*n == 2) {
4662 ret_val = (x[1] + x[2]) * .5;
4663 return ret_val;
4664 } else if (*n == 3) {
4665 if (x[1] > x[2]) {
4666 tmp = x[2];
4667 x[2] = x[1];
4668 x[1] = tmp;
4669 }
4670 if (x[1] > x[3]) {
4671 ret_val = x[1];
4672 } else if (x[2] > x[3]) {
4673 ret_val = x[3];
4674 } else {
4675 ret_val = x[2];
4676 }
4677 return ret_val;
4678 }
4679
4680 /* --- sort it */
4681
4682 bsort_(n, &x[1]);
4683
4684 /* --- Even N --> average of middle 2 */
4685 /* --- Odd N --> middle 1 */
4686
4687 it = *n / 2;
4688 if (it << 1 == *n) {
4689 ret_val = (x[it] + x[it + 1]) * .5;
4690 } else {
4691 ret_val = x[it + 1];
4692 }
4693 return ret_val;
4694 } /* median_ */
4695
4696
4697
4698
mad_(integer * n,doublereal * x)4699 doublereal mad_(integer *n, doublereal *x)
4700 {
4701 /* System generated locals */
4702 integer i__1;
4703 doublereal ret_val, d__1;
4704
4705 /* Local variables */
4706 extern doublereal median_(integer *, doublereal *);
4707 static integer it;
4708 static doublereal tmp;
4709
4710
4711 /* Parameter adjustments */
4712 --x;
4713
4714 /* Function Body */
4715 if (*n == 1) {
4716 ret_val = 0.;
4717 return ret_val;
4718 } else if (*n == 2) {
4719 ret_val = (d__1 = x[1] - x[2], abs(d__1)) * .5;
4720 return ret_val;
4721 }
4722
4723 tmp = median_(n, &x[1]);
4724 i__1 = *n;
4725 for (it = 1; it <= i__1; ++it) {
4726 x[it] = (d__1 = x[it] - tmp, abs(d__1));
4727 /* L100: */
4728 }
4729 ret_val = median_(n, &x[1]);
4730 return ret_val;
4731 } /* mad_ */
4732
4733
4734
4735
argmax_(integer * n,doublereal * x)4736 doublereal argmax_(integer *n, doublereal *x)
4737 {
4738 /* System generated locals */
4739 integer i__1;
4740 doublereal ret_val;
4741
4742 /* Local variables */
4743 static integer i__, it, nz;
4744 static doublereal tmp;
4745
4746
4747 /* Parameter adjustments */
4748 --x;
4749
4750 /* Function Body */
4751 tmp = x[1];
4752 it = 1;
4753 nz = 0;
4754 if (tmp == 0.) {
4755 nz = 1;
4756 }
4757 i__1 = *n;
4758 for (i__ = 2; i__ <= i__1; ++i__) {
4759 if (x[i__] > tmp) {
4760 it = i__;
4761 tmp = x[i__];
4762 }
4763 if (x[i__] == 0.) {
4764 ++nz;
4765 }
4766 /* L100: */
4767 }
4768 if (nz == *n) {
4769 ret_val = 0.;
4770 } else {
4771 ret_val = (doublereal) it;
4772 }
4773 return ret_val;
4774 } /* argmax_ */
4775
4776
4777
4778
argnum_(integer * n,doublereal * x)4779 doublereal argnum_(integer *n, doublereal *x)
4780 {
4781 /* System generated locals */
4782 integer i__1;
4783 doublereal ret_val;
4784
4785 /* Local variables */
4786 static integer i__, nz;
4787
4788
4789 /* Parameter adjustments */
4790 --x;
4791
4792 /* Function Body */
4793 nz = 0;
4794 i__1 = *n;
4795 for (i__ = 1; i__ <= i__1; ++i__) {
4796 if (x[i__] != 0.) {
4797 ++nz;
4798 }
4799 /* L100: */
4800 }
4801 ret_val = (doublereal) nz;
4802 return ret_val;
4803 } /* argnum_ */
4804
4805
4806
4807
hmode_(integer * n,doublereal * x)4808 doublereal hmode_(integer *n, doublereal *x)
4809 {
4810 /* System generated locals */
4811 integer i__1;
4812 doublereal ret_val;
4813
4814 /* Local variables */
4815 static integer i__;
4816 extern /* Subroutine */ int bsort_(integer *, doublereal *);
4817 static integer ib;
4818 static doublereal vb;
4819 static integer iv;
4820 static doublereal val;
4821
4822
4823 /* Parameter adjustments */
4824 --x;
4825
4826 /* Function Body */
4827 if (*n == 1) {
4828 ret_val = x[1];
4829 return ret_val;
4830 }
4831
4832 bsort_(n, &x[1]);
4833
4834 val = x[1];
4835 iv = 1;
4836 ib = 0;
4837 i__1 = *n;
4838 for (i__ = 2; i__ <= i__1; ++i__) {
4839 if (x[i__] != val) {
4840 if (iv >= ib) {
4841 vb = val;
4842 ib = iv;
4843 }
4844 val = x[i__];
4845 iv = 1;
4846 } else {
4847 ++iv;
4848 }
4849 /* L100: */
4850 }
4851 if (iv >= ib) {
4852 vb = val;
4853 }
4854 ret_val = vb;
4855 return ret_val;
4856 } /* hmode_ */
4857
4858
4859
4860
lmode_(integer * n,doublereal * x)4861 doublereal lmode_(integer *n, doublereal *x)
4862 {
4863 /* System generated locals */
4864 integer i__1;
4865 doublereal ret_val;
4866
4867 /* Local variables */
4868 static integer i__;
4869 extern /* Subroutine */ int bsort_(integer *, doublereal *);
4870 static integer ib;
4871 static doublereal vb;
4872 static integer iv;
4873 static doublereal val;
4874
4875
4876 /* Parameter adjustments */
4877 --x;
4878
4879 /* Function Body */
4880 if (*n == 1) {
4881 ret_val = x[1];
4882 return ret_val;
4883 }
4884
4885 bsort_(n, &x[1]);
4886
4887 val = x[1];
4888 iv = 1;
4889 ib = 0;
4890 i__1 = *n;
4891 for (i__ = 2; i__ <= i__1; ++i__) {
4892 if (x[i__] != val) {
4893 if (iv > ib) {
4894 vb = val;
4895 ib = iv;
4896 }
4897 val = x[i__];
4898 iv = 1;
4899 } else {
4900 ++iv;
4901 }
4902 /* L100: */
4903 }
4904 if (iv > ib) {
4905 vb = val;
4906 }
4907 ret_val = vb;
4908 return ret_val;
4909 } /* lmode_ */
4910
4911
4912
4913
lor_(integer * n,doublereal * x)4914 doublereal lor_(integer *n, doublereal *x)
4915 {
4916 /* System generated locals */
4917 integer i__1;
4918 doublereal ret_val;
4919
4920 /* Local variables */
4921 static integer i__;
4922
4923 /* Parameter adjustments */
4924 --x;
4925
4926 /* Function Body */
4927 ret_val = 1.;
4928 i__1 = *n;
4929 for (i__ = 1; i__ <= i__1; ++i__) {
4930 if (x[i__] != 0.) {
4931 return ret_val;
4932 }
4933 /* L100: */
4934 }
4935 ret_val = 0.;
4936 return ret_val;
4937 } /* lor_ */
4938
4939
4940
4941
lmofn_(integer * m,integer * n,doublereal * x)4942 doublereal lmofn_(integer *m, integer *n, doublereal *x)
4943 {
4944 /* System generated locals */
4945 integer i__1;
4946 doublereal ret_val;
4947
4948 /* Local variables */
4949 static integer c__, i__;
4950
4951 /* Parameter adjustments */
4952 --x;
4953
4954 /* Function Body */
4955 c__ = 0;
4956 i__1 = *n;
4957 for (i__ = 1; i__ <= i__1; ++i__) {
4958 if (x[i__] != 0.) {
4959 ++c__;
4960 }
4961 /* L100: */
4962 }
4963 if (c__ >= *m) {
4964 ret_val = 1.;
4965 } else {
4966 ret_val = 0.;
4967 }
4968 return ret_val;
4969 } /* lmofn_ */
4970
4971
4972
4973
lncosh_(doublereal * x)4974 doublereal lncosh_(doublereal *x)
4975 {
4976 /* System generated locals */
4977 doublereal ret_val;
4978
4979 /* Builtin functions */
4980 double exp(doublereal), log(doublereal);
4981
4982 /* Local variables */
4983 static doublereal ax;
4984
4985 ax = abs(*x);
4986 ret_val = ax + log(exp(ax * -2.) * .5 + .5);
4987 return ret_val;
4988 } /* lncosh_ */
4989
4990
4991
4992
dai_(doublereal * x)4993 doublereal dai_(doublereal *x)
4994 {
4995 /* System generated locals */
4996 doublereal ret_val;
4997
4998 /* Local variables */
4999 extern /* Subroutine */ int qqqerr_(void);
5000
5001 qqqerr_();
5002 ret_val = 0.;
5003 return ret_val;
5004 } /* dai_ */
5005
dbi_(doublereal * x,integer * i__)5006 doublereal dbi_(doublereal *x, integer *i__)
5007 {
5008 /* System generated locals */
5009 doublereal ret_val;
5010
5011 /* Local variables */
5012 extern /* Subroutine */ int qqqerr_(void);
5013
5014 qqqerr_();
5015 ret_val = 0.;
5016 return ret_val;
5017 } /* dbi_ */
5018
5019 /* cc REAL*8 FUNCTION DGAMMA( X ) */
5020 /* cc REAL*8 X */
5021 /* cc CALL QQQERR */
5022 /* cc DGAMMA = 0.D+0 */
5023 /* cc RETURN */
5024 /* cc END */
dbesi0_(doublereal * x)5025 doublereal dbesi0_(doublereal *x)
5026 {
5027 /* System generated locals */
5028 doublereal ret_val;
5029
5030 /* Local variables */
5031 extern /* Subroutine */ int qqqerr_(void);
5032
5033 qqqerr_();
5034 ret_val = 0.;
5035 return ret_val;
5036 } /* dbesi0_ */
5037
dbesi1_(doublereal * x)5038 doublereal dbesi1_(doublereal *x)
5039 {
5040 /* System generated locals */
5041 doublereal ret_val;
5042
5043 /* Local variables */
5044 extern /* Subroutine */ int qqqerr_(void);
5045
5046 qqqerr_();
5047 ret_val = 0.;
5048 return ret_val;
5049 } /* dbesi1_ */
5050
5051 /* cc REAL*8 FUNCTION DBESJ0( X ) */
5052 /* cc REAL*8 X */
5053 /* cc CALL QQQERR */
5054 /* cc END */
5055 /* cc REAL*8 FUNCTION DBESJ1( X ) */
5056 /* cc REAL*8 X */
5057 /* cc CALL QQQERR */
5058 /* cc END */
dbesk0_(doublereal * x)5059 doublereal dbesk0_(doublereal *x)
5060 {
5061 /* System generated locals */
5062 doublereal ret_val;
5063
5064 /* Local variables */
5065 extern /* Subroutine */ int qqqerr_(void);
5066
5067 qqqerr_();
5068 ret_val = 0.;
5069 return ret_val;
5070 } /* dbesk0_ */
5071
dbesk1_(doublereal * x)5072 doublereal dbesk1_(doublereal *x)
5073 {
5074 /* System generated locals */
5075 doublereal ret_val;
5076
5077 /* Local variables */
5078 extern /* Subroutine */ int qqqerr_(void);
5079
5080 qqqerr_();
5081 ret_val = 0.;
5082 return ret_val;
5083 } /* dbesk1_ */
5084
5085 /* cc REAL*8 FUNCTION DBESY0( X ) */
5086 /* cc REAL*8 X */
5087 /* cc CALL QQQERR */
5088 /* cc END */
5089 /* cc REAL*8 FUNCTION DBESY1( X ) */
5090 /* cc REAL*8 X */
5091 /* cc CALL QQQERR */
5092 /* cc END */
5093 /* cc REAL*8 FUNCTION DERF( X ) */
5094 /* cc REAL*8 X */
5095 /* cc CALL QQQERR */
5096 /* cc END */
5097 /* cc REAL*8 FUNCTION DERFC( X ) */
5098 /* cc REAL*8 X */
5099 /* cc CALL QQQERR */
5100 /* cc END */
5101
qqqerr_(void)5102 /* Subroutine */ int qqqerr_(void)
5103 {
5104 /* Format strings */
5105 static char fmt_999[] = "(\002*** PARSER: unimplemented function ***\002)"
5106 ;
5107
5108 /* Builtin functions */
5109 integer s_wsfe(cilist *), e_wsfe(void);
5110
5111 /* Fortran I/O blocks */
5112 static cilist io___145 = { 0, 6, 0, fmt_999, 0 };
5113
5114
5115 s_wsfe(&io___145);
5116 e_wsfe();
5117 return 0;
5118 } /* qqqerr_ */
5119
5120