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