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