diff options
| author | Shashank | 2017-05-29 12:40:26 +0530 |
|---|---|---|
| committer | Shashank | 2017-05-29 12:40:26 +0530 |
| commit | 0345245e860375a32c9a437c4a9d9cae807134e9 (patch) | |
| tree | ad51ecbfa7bcd3cc5f09834f1bb8c08feaa526a4 /modules/statistics/src/dcdflib | |
| download | scilab_for_xcos_on_cloud-0345245e860375a32c9a437c4a9d9cae807134e9.tar.gz scilab_for_xcos_on_cloud-0345245e860375a32c9a437c4a9d9cae807134e9.tar.bz2 scilab_for_xcos_on_cloud-0345245e860375a32c9a437c4a9d9cae807134e9.zip | |
CMSCOPE changed
Diffstat (limited to 'modules/statistics/src/dcdflib')
200 files changed, 12064 insertions, 0 deletions
diff --git a/modules/statistics/src/dcdflib/.deps/.dirstamp b/modules/statistics/src/dcdflib/.deps/.dirstamp new file mode 100755 index 000000000..e69de29bb --- /dev/null +++ b/modules/statistics/src/dcdflib/.deps/.dirstamp diff --git a/modules/statistics/src/dcdflib/.dirstamp b/modules/statistics/src/dcdflib/.dirstamp new file mode 100755 index 000000000..e69de29bb --- /dev/null +++ b/modules/statistics/src/dcdflib/.dirstamp diff --git a/modules/statistics/src/dcdflib/.libs/algdiv.o b/modules/statistics/src/dcdflib/.libs/algdiv.o Binary files differnew file mode 100755 index 000000000..06f799784 --- /dev/null +++ b/modules/statistics/src/dcdflib/.libs/algdiv.o diff --git a/modules/statistics/src/dcdflib/.libs/alngam.o b/modules/statistics/src/dcdflib/.libs/alngam.o Binary files differnew file mode 100755 index 000000000..41d9a9315 --- /dev/null +++ b/modules/statistics/src/dcdflib/.libs/alngam.o diff --git a/modules/statistics/src/dcdflib/.libs/alnrel.o b/modules/statistics/src/dcdflib/.libs/alnrel.o Binary files differnew file mode 100755 index 000000000..16bdb9277 --- /dev/null +++ b/modules/statistics/src/dcdflib/.libs/alnrel.o diff --git a/modules/statistics/src/dcdflib/.libs/apser.o b/modules/statistics/src/dcdflib/.libs/apser.o Binary files differnew file mode 100755 index 000000000..b2ee83b2d --- /dev/null +++ b/modules/statistics/src/dcdflib/.libs/apser.o diff --git a/modules/statistics/src/dcdflib/.libs/basym.o b/modules/statistics/src/dcdflib/.libs/basym.o Binary files differnew file mode 100755 index 000000000..c6977a125 --- /dev/null +++ b/modules/statistics/src/dcdflib/.libs/basym.o diff --git a/modules/statistics/src/dcdflib/.libs/bcorr.o b/modules/statistics/src/dcdflib/.libs/bcorr.o Binary files differnew file mode 100755 index 000000000..cb1ac0af1 --- /dev/null +++ b/modules/statistics/src/dcdflib/.libs/bcorr.o diff --git a/modules/statistics/src/dcdflib/.libs/betaln.o b/modules/statistics/src/dcdflib/.libs/betaln.o Binary files differnew file mode 100755 index 000000000..9e4949335 --- /dev/null +++ b/modules/statistics/src/dcdflib/.libs/betaln.o diff --git a/modules/statistics/src/dcdflib/.libs/bfrac.o b/modules/statistics/src/dcdflib/.libs/bfrac.o Binary files differnew file mode 100755 index 000000000..2f6254817 --- /dev/null +++ b/modules/statistics/src/dcdflib/.libs/bfrac.o diff --git a/modules/statistics/src/dcdflib/.libs/bgrat.o b/modules/statistics/src/dcdflib/.libs/bgrat.o Binary files differnew file mode 100755 index 000000000..658902588 --- /dev/null +++ b/modules/statistics/src/dcdflib/.libs/bgrat.o diff --git a/modules/statistics/src/dcdflib/.libs/bpser.o b/modules/statistics/src/dcdflib/.libs/bpser.o Binary files differnew file mode 100755 index 000000000..2880aac5a --- /dev/null +++ b/modules/statistics/src/dcdflib/.libs/bpser.o diff --git a/modules/statistics/src/dcdflib/.libs/bratio.o b/modules/statistics/src/dcdflib/.libs/bratio.o Binary files differnew file mode 100755 index 000000000..f0025c236 --- /dev/null +++ b/modules/statistics/src/dcdflib/.libs/bratio.o diff --git a/modules/statistics/src/dcdflib/.libs/brcmp1.o b/modules/statistics/src/dcdflib/.libs/brcmp1.o Binary files differnew file mode 100755 index 000000000..44024e2b2 --- /dev/null +++ b/modules/statistics/src/dcdflib/.libs/brcmp1.o diff --git a/modules/statistics/src/dcdflib/.libs/brcomp.o b/modules/statistics/src/dcdflib/.libs/brcomp.o Binary files differnew file mode 100755 index 000000000..8fc831bc0 --- /dev/null +++ b/modules/statistics/src/dcdflib/.libs/brcomp.o diff --git a/modules/statistics/src/dcdflib/.libs/bup.o b/modules/statistics/src/dcdflib/.libs/bup.o Binary files differnew file mode 100755 index 000000000..0ee3e30d7 --- /dev/null +++ b/modules/statistics/src/dcdflib/.libs/bup.o diff --git a/modules/statistics/src/dcdflib/.libs/cdfbet.o b/modules/statistics/src/dcdflib/.libs/cdfbet.o Binary files differnew file mode 100755 index 000000000..ad5f51657 --- /dev/null +++ b/modules/statistics/src/dcdflib/.libs/cdfbet.o diff --git a/modules/statistics/src/dcdflib/.libs/cdfbin.o b/modules/statistics/src/dcdflib/.libs/cdfbin.o Binary files differnew file mode 100755 index 000000000..12e44b36a --- /dev/null +++ b/modules/statistics/src/dcdflib/.libs/cdfbin.o diff --git a/modules/statistics/src/dcdflib/.libs/cdfchi.o b/modules/statistics/src/dcdflib/.libs/cdfchi.o Binary files differnew file mode 100755 index 000000000..8bb3ec850 --- /dev/null +++ b/modules/statistics/src/dcdflib/.libs/cdfchi.o diff --git a/modules/statistics/src/dcdflib/.libs/cdfchn.o b/modules/statistics/src/dcdflib/.libs/cdfchn.o Binary files differnew file mode 100755 index 000000000..c69a0e1bf --- /dev/null +++ b/modules/statistics/src/dcdflib/.libs/cdfchn.o diff --git a/modules/statistics/src/dcdflib/.libs/cdff.o b/modules/statistics/src/dcdflib/.libs/cdff.o Binary files differnew file mode 100755 index 000000000..2527241a2 --- /dev/null +++ b/modules/statistics/src/dcdflib/.libs/cdff.o diff --git a/modules/statistics/src/dcdflib/.libs/cdffnc.o b/modules/statistics/src/dcdflib/.libs/cdffnc.o Binary files differnew file mode 100755 index 000000000..312429875 --- /dev/null +++ b/modules/statistics/src/dcdflib/.libs/cdffnc.o diff --git a/modules/statistics/src/dcdflib/.libs/cdfgam.o b/modules/statistics/src/dcdflib/.libs/cdfgam.o Binary files differnew file mode 100755 index 000000000..de3791069 --- /dev/null +++ b/modules/statistics/src/dcdflib/.libs/cdfgam.o diff --git a/modules/statistics/src/dcdflib/.libs/cdfnbn.o b/modules/statistics/src/dcdflib/.libs/cdfnbn.o Binary files differnew file mode 100755 index 000000000..3a647e96e --- /dev/null +++ b/modules/statistics/src/dcdflib/.libs/cdfnbn.o diff --git a/modules/statistics/src/dcdflib/.libs/cdfnor.o b/modules/statistics/src/dcdflib/.libs/cdfnor.o Binary files differnew file mode 100755 index 000000000..8ad42325b --- /dev/null +++ b/modules/statistics/src/dcdflib/.libs/cdfnor.o diff --git a/modules/statistics/src/dcdflib/.libs/cdfpoi.o b/modules/statistics/src/dcdflib/.libs/cdfpoi.o Binary files differnew file mode 100755 index 000000000..66331c924 --- /dev/null +++ b/modules/statistics/src/dcdflib/.libs/cdfpoi.o diff --git a/modules/statistics/src/dcdflib/.libs/cdft.o b/modules/statistics/src/dcdflib/.libs/cdft.o Binary files differnew file mode 100755 index 000000000..fef35be4f --- /dev/null +++ b/modules/statistics/src/dcdflib/.libs/cdft.o diff --git a/modules/statistics/src/dcdflib/.libs/cumbet.o b/modules/statistics/src/dcdflib/.libs/cumbet.o Binary files differnew file mode 100755 index 000000000..0f09713ef --- /dev/null +++ b/modules/statistics/src/dcdflib/.libs/cumbet.o diff --git a/modules/statistics/src/dcdflib/.libs/cumbin.o b/modules/statistics/src/dcdflib/.libs/cumbin.o Binary files differnew file mode 100755 index 000000000..279e3ad7e --- /dev/null +++ b/modules/statistics/src/dcdflib/.libs/cumbin.o diff --git a/modules/statistics/src/dcdflib/.libs/cumchi.o b/modules/statistics/src/dcdflib/.libs/cumchi.o Binary files differnew file mode 100755 index 000000000..aa392023e --- /dev/null +++ b/modules/statistics/src/dcdflib/.libs/cumchi.o diff --git a/modules/statistics/src/dcdflib/.libs/cumchn.o b/modules/statistics/src/dcdflib/.libs/cumchn.o Binary files differnew file mode 100755 index 000000000..71506d459 --- /dev/null +++ b/modules/statistics/src/dcdflib/.libs/cumchn.o diff --git a/modules/statistics/src/dcdflib/.libs/cumf.o b/modules/statistics/src/dcdflib/.libs/cumf.o Binary files differnew file mode 100755 index 000000000..ecfe03baf --- /dev/null +++ b/modules/statistics/src/dcdflib/.libs/cumf.o diff --git a/modules/statistics/src/dcdflib/.libs/cumfnc.o b/modules/statistics/src/dcdflib/.libs/cumfnc.o Binary files differnew file mode 100755 index 000000000..d053e775d --- /dev/null +++ b/modules/statistics/src/dcdflib/.libs/cumfnc.o diff --git a/modules/statistics/src/dcdflib/.libs/cumgam.o b/modules/statistics/src/dcdflib/.libs/cumgam.o Binary files differnew file mode 100755 index 000000000..56cb47ef4 --- /dev/null +++ b/modules/statistics/src/dcdflib/.libs/cumgam.o diff --git a/modules/statistics/src/dcdflib/.libs/cumnbn.o b/modules/statistics/src/dcdflib/.libs/cumnbn.o Binary files differnew file mode 100755 index 000000000..2787827d6 --- /dev/null +++ b/modules/statistics/src/dcdflib/.libs/cumnbn.o diff --git a/modules/statistics/src/dcdflib/.libs/cumnor.o b/modules/statistics/src/dcdflib/.libs/cumnor.o Binary files differnew file mode 100755 index 000000000..f5bb1ba11 --- /dev/null +++ b/modules/statistics/src/dcdflib/.libs/cumnor.o diff --git a/modules/statistics/src/dcdflib/.libs/cumpoi.o b/modules/statistics/src/dcdflib/.libs/cumpoi.o Binary files differnew file mode 100755 index 000000000..df838cc7c --- /dev/null +++ b/modules/statistics/src/dcdflib/.libs/cumpoi.o diff --git a/modules/statistics/src/dcdflib/.libs/cumt.o b/modules/statistics/src/dcdflib/.libs/cumt.o Binary files differnew file mode 100755 index 000000000..07e419735 --- /dev/null +++ b/modules/statistics/src/dcdflib/.libs/cumt.o diff --git a/modules/statistics/src/dcdflib/.libs/devlpl.o b/modules/statistics/src/dcdflib/.libs/devlpl.o Binary files differnew file mode 100755 index 000000000..ba7b0fb61 --- /dev/null +++ b/modules/statistics/src/dcdflib/.libs/devlpl.o diff --git a/modules/statistics/src/dcdflib/.libs/dinvnr.o b/modules/statistics/src/dcdflib/.libs/dinvnr.o Binary files differnew file mode 100755 index 000000000..68adaea1b --- /dev/null +++ b/modules/statistics/src/dcdflib/.libs/dinvnr.o diff --git a/modules/statistics/src/dcdflib/.libs/dinvr.o b/modules/statistics/src/dcdflib/.libs/dinvr.o Binary files differnew file mode 100755 index 000000000..f233242fa --- /dev/null +++ b/modules/statistics/src/dcdflib/.libs/dinvr.o diff --git a/modules/statistics/src/dcdflib/.libs/dt1.o b/modules/statistics/src/dcdflib/.libs/dt1.o Binary files differnew file mode 100755 index 000000000..e0132480d --- /dev/null +++ b/modules/statistics/src/dcdflib/.libs/dt1.o diff --git a/modules/statistics/src/dcdflib/.libs/dzror.o b/modules/statistics/src/dcdflib/.libs/dzror.o Binary files differnew file mode 100755 index 000000000..86e856f8e --- /dev/null +++ b/modules/statistics/src/dcdflib/.libs/dzror.o diff --git a/modules/statistics/src/dcdflib/.libs/erf.o b/modules/statistics/src/dcdflib/.libs/erf.o Binary files differnew file mode 100755 index 000000000..eb624f6ed --- /dev/null +++ b/modules/statistics/src/dcdflib/.libs/erf.o diff --git a/modules/statistics/src/dcdflib/.libs/erfc1.o b/modules/statistics/src/dcdflib/.libs/erfc1.o Binary files differnew file mode 100755 index 000000000..7acb3c353 --- /dev/null +++ b/modules/statistics/src/dcdflib/.libs/erfc1.o diff --git a/modules/statistics/src/dcdflib/.libs/esum.o b/modules/statistics/src/dcdflib/.libs/esum.o Binary files differnew file mode 100755 index 000000000..6ed589a91 --- /dev/null +++ b/modules/statistics/src/dcdflib/.libs/esum.o diff --git a/modules/statistics/src/dcdflib/.libs/exparg.o b/modules/statistics/src/dcdflib/.libs/exparg.o Binary files differnew file mode 100755 index 000000000..e72b18a67 --- /dev/null +++ b/modules/statistics/src/dcdflib/.libs/exparg.o diff --git a/modules/statistics/src/dcdflib/.libs/fpser.o b/modules/statistics/src/dcdflib/.libs/fpser.o Binary files differnew file mode 100755 index 000000000..7c08cacc9 --- /dev/null +++ b/modules/statistics/src/dcdflib/.libs/fpser.o diff --git a/modules/statistics/src/dcdflib/.libs/gam1.o b/modules/statistics/src/dcdflib/.libs/gam1.o Binary files differnew file mode 100755 index 000000000..16a45b3a1 --- /dev/null +++ b/modules/statistics/src/dcdflib/.libs/gam1.o diff --git a/modules/statistics/src/dcdflib/.libs/gaminv.o b/modules/statistics/src/dcdflib/.libs/gaminv.o Binary files differnew file mode 100755 index 000000000..d7d779e61 --- /dev/null +++ b/modules/statistics/src/dcdflib/.libs/gaminv.o diff --git a/modules/statistics/src/dcdflib/.libs/gamln.o b/modules/statistics/src/dcdflib/.libs/gamln.o Binary files differnew file mode 100755 index 000000000..237f1c491 --- /dev/null +++ b/modules/statistics/src/dcdflib/.libs/gamln.o diff --git a/modules/statistics/src/dcdflib/.libs/gamln1.o b/modules/statistics/src/dcdflib/.libs/gamln1.o Binary files differnew file mode 100755 index 000000000..f4036c459 --- /dev/null +++ b/modules/statistics/src/dcdflib/.libs/gamln1.o diff --git a/modules/statistics/src/dcdflib/.libs/gamma.o b/modules/statistics/src/dcdflib/.libs/gamma.o Binary files differnew file mode 100755 index 000000000..52dfd59f4 --- /dev/null +++ b/modules/statistics/src/dcdflib/.libs/gamma.o diff --git a/modules/statistics/src/dcdflib/.libs/grat1.o b/modules/statistics/src/dcdflib/.libs/grat1.o Binary files differnew file mode 100755 index 000000000..cac18e399 --- /dev/null +++ b/modules/statistics/src/dcdflib/.libs/grat1.o diff --git a/modules/statistics/src/dcdflib/.libs/gratio.o b/modules/statistics/src/dcdflib/.libs/gratio.o Binary files differnew file mode 100755 index 000000000..09a467dac --- /dev/null +++ b/modules/statistics/src/dcdflib/.libs/gratio.o diff --git a/modules/statistics/src/dcdflib/.libs/gsumln.o b/modules/statistics/src/dcdflib/.libs/gsumln.o Binary files differnew file mode 100755 index 000000000..01780a7f9 --- /dev/null +++ b/modules/statistics/src/dcdflib/.libs/gsumln.o diff --git a/modules/statistics/src/dcdflib/.libs/ipmpar.o b/modules/statistics/src/dcdflib/.libs/ipmpar.o Binary files differnew file mode 100755 index 000000000..877e5142e --- /dev/null +++ b/modules/statistics/src/dcdflib/.libs/ipmpar.o diff --git a/modules/statistics/src/dcdflib/.libs/psi.o b/modules/statistics/src/dcdflib/.libs/psi.o Binary files differnew file mode 100755 index 000000000..56508edde --- /dev/null +++ b/modules/statistics/src/dcdflib/.libs/psi.o diff --git a/modules/statistics/src/dcdflib/.libs/rcomp.o b/modules/statistics/src/dcdflib/.libs/rcomp.o Binary files differnew file mode 100755 index 000000000..f4770ddcc --- /dev/null +++ b/modules/statistics/src/dcdflib/.libs/rcomp.o diff --git a/modules/statistics/src/dcdflib/.libs/rexp.o b/modules/statistics/src/dcdflib/.libs/rexp.o Binary files differnew file mode 100755 index 000000000..ee2466b0e --- /dev/null +++ b/modules/statistics/src/dcdflib/.libs/rexp.o diff --git a/modules/statistics/src/dcdflib/.libs/rlog.o b/modules/statistics/src/dcdflib/.libs/rlog.o Binary files differnew file mode 100755 index 000000000..dd04b4a66 --- /dev/null +++ b/modules/statistics/src/dcdflib/.libs/rlog.o diff --git a/modules/statistics/src/dcdflib/.libs/rlog1.o b/modules/statistics/src/dcdflib/.libs/rlog1.o Binary files differnew file mode 100755 index 000000000..3fa7a9f7b --- /dev/null +++ b/modules/statistics/src/dcdflib/.libs/rlog1.o diff --git a/modules/statistics/src/dcdflib/.libs/spmpar.o b/modules/statistics/src/dcdflib/.libs/spmpar.o Binary files differnew file mode 100755 index 000000000..a0f89bfbc --- /dev/null +++ b/modules/statistics/src/dcdflib/.libs/spmpar.o diff --git a/modules/statistics/src/dcdflib/.libs/stvaln.o b/modules/statistics/src/dcdflib/.libs/stvaln.o Binary files differnew file mode 100755 index 000000000..ef61c2acf --- /dev/null +++ b/modules/statistics/src/dcdflib/.libs/stvaln.o diff --git a/modules/statistics/src/dcdflib/README b/modules/statistics/src/dcdflib/README new file mode 100755 index 000000000..8133163a5 --- /dev/null +++ b/modules/statistics/src/dcdflib/README @@ -0,0 +1,318 @@ + + + + + + + + + + + + DCDFLIB + + Library of Fortran Routines for Cumulative Distribution + Functions, Inverses, and Other Parameters + + (February, 1994) + + + + + + + Summary Documentation of Each Routine + + + + + + + + + Compiled and Written by: + + Barry W. Brown + James Lovato + Kathy Russell + + + + + + + + + + Department of Biomathematics, Box 237 + The University of Texas, M.D. Anderson Cancer Center + 1515 Holcombe Boulevard + Houston, TX 77030 + + + This work was supported by grant CA-16672 from the National Cancer Institute. + + + SUMMARY OF DCDFLIB + +This library contains routines to compute cumulative distribution +functions, inverses, and parameters of the distribution for the +following set of statistical distributions: + + (1) Beta + (2) Binomial + (3) Chi-square + (4) Noncentral Chi-square + (5) F + (6) Noncentral F + (7) Gamma + (8) Negative Binomial + (9) Normal + (10) Poisson + (11) Student's t + +Given values of all but one parameter of a distribution, the other is +computed. These calculations are done with FORTRAN Double Precision +variables. + + -------------------- WARNINGS -------------------- + +The F and Noncentral F distribution are not necessarily monotone in +either degree of freedom argument. Consequently, there may be two +degree of freedom arguments that satisfy the specified condition. An +arbitrary one of these will be found by the cdf routines. + +The amount of computation required for the noncentral chisquare and +noncentral F distribution is proportional to the value of the +noncentrality parameter. Very large values of this parameter can +require immense numbers of computation. Consequently, when the +noncentrality parameter is to be calculated, the upper limit searched +is 10,000. + + -------------------- END WARNINGS -------------------- + + DOCUMENTATION + +This file contains an overview of the library and is the primary +documentation. + +Other documentation is in directory 'doc' on the distribution as +character (ASCII) files. A summary of all of the available routines +is contained in dcdflib.chs (chs is an abbreviation of 'cheat sheet'). +The 'chs' file will probably be the primary reference. The file, +dcdflib.fdoc, contains the header comments for each routine intended +for direct use. + + INSTALLATION + +The Fortran source routines are contained in directory src. + +A few routines use machine dependent constants. Lists of such +constants for different machines are found in ipmpar.f. Uncomment the +ones appropriate to your machine. The distributed version uses the +IEEE arithmetic that is used by the IBM PC, Macintosh, and most Unix +workstations. + +Ignore compilation warnings that lines of code are not reachable. We +write in a Fortran structured preprocessor (FLECS) that is similar in +spirit to Ratfor. Sometimes our coding practices in FLECS lead to +unreachable lines. Also, FLECS inserts lines of code: STOP "CODE +FLOWING INTO FLECS PROCEEDURES". All such lines should be +unreachable. + + SOURCES + +The following routines, written by others, are incorporated into +DCDFLIB. + + Beta Distribution + +DiDinato, A. R. and Morris, A. H. Algorithm 708: Significant Digit +Computation of the Incomplete Beta Function Ratios. ACM Trans. Math. +Softw. 18 (1993), 360-373. + + Gamma Distribution and It's Inverse + +DiDinato, A. R. and Morris, A. H. Computation of the Incomplete Gamma +Function Ratios and their Inverse. ACM Trans. Math. Softw. 12 +(1986), 377-393. + + Normal Distribution + +Kennedy and Gentle, Statistical Computing, Marcel Dekker, NY, 1980. +The rational function approximations from pages 90-95 are used during +the calculation of the inverse normal. + +Cody, W.D. (1993). "ALGORITHM 715: SPECFUN - A Portabel FORTRAN +Package of Special Function Routines and Test Drivers", acm +Transactions on Mathematical Software. 19, 22-32. A slightly modified +version of Cody's function anorm is used for the cumultive normal. + + Zero Finder + +J. C. P. Bus and T. J. Dekker. Two Efficient Algorithms with +Guaranteed Convergence for Finding a Zero of a Function. ACM Trans. +Math. Softw. 4 (1975), 330. + +We transliterated Algoritm R of this paper from Algol to Fortran. + + General Reference + +Abramowitz, M. and Stegun, I. A. Handbook of Mathematical Functions +With Formulas, Graphs, and Mathematical Tables. (1964) National +Bureau of Standards. + +This book has been reprinted by Dover and others. + + + LEGALITIES + +Code that appeared in an ACM publication is subject to their +algorithms policy: + + Submittal of an algorithm for publication in one of the ACM + Transactions implies that unrestricted use of the algorithm within a + computer is permissible. General permission to copy and distribute + the algorithm without fee is granted provided that the copies are not + made or distributed for direct commercial advantage. The ACM + copyright notice and the title of the publication and its date appear, + and notice is given that copying is by permission of the Association + for Computing Machinery. To copy otherwise, or to republish, requires + a fee and/or specific permission. + + Krogh, F. Algorithms Policy. ACM Tran. Math. Softw. 13(1987), + 183-186. + +We place the DCDFLIB code that we have written in the public domain. + + NO WARRANTY + + WE PROVIDE ABSOLUTELY NO WARRANTY OF ANY KIND EITHER EXPRESSED OR + IMPLIED, INCLUDING BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF + MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK + AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD + THIS PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY + SERVICING, REPAIR OR CORRECTION. + + IN NO EVENT SHALL THE UNIVERSITY OF TEXAS OR ANY OF ITS COMPONENT + INSTITUTIONS INCLUDING M. D. ANDERSON HOSPITAL BE LIABLE TO YOU FOR + DAMAGES, INCLUDING ANY LOST PROFITS, LOST MONIES, OR OTHER SPECIAL, + INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR + INABILITY TO USE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA OR + ITS ANALYSIS BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY THIRD + PARTIES) THE PROGRAM. + + (Above NO WARRANTY modified from the GNU NO WARRANTY statement.) + + HOW TO USE THE ROUTINES + +The calling sequence for each routine is of the form: + + SUBROUTINE CDF<name>( WHICH, P, Q, X, <parameters>, STATUS, BOUND ). + +WHICH and STATUS are INTEGER, all other arguments are DOUBLE PRECISION. + +<name> is a one to three character name identifying the distribution. +WHICH is an input integer value that identifies what parameter value +is to be calculated from the values of the other parameters. + +P is always the cdf evaluated at X, Q is always the compliment of the +cdf evaluated at X, i.e. 1-P, and X is always the value at which the +cdf is evaluated. The auxiliary parameters, <parameters>, of the +distribution differ by distribution. + +If WHICH is 1, P and Q are to be calculated, i.e., the cdf; if WHICH +is 2, X is to be calculated, i.e., the inverse cdf. The value of one +auxiliary parameter in <parameters> can also be the value calculated. + +STATUS returns 0 if the calculation completes correctly. + + --------------------WARNING-------------------- + +If STATUS is not 0, no meaningful answer is returned. + + -------------------- END WARNING -------------------- + +STATUS returns -I if the I'th input parameter was not in the legal +range (see below). Parameters are counted with WHICH being the first +in these return values. + +A STATUS value of 1 indicates that the desired answer was apparently +lower than the lower bound on the search interval. A return code of 2 +indicates that the answer was apparently higher than the upper bound +on the search interval. A return code of 3 indicates that P and Q did +not sum to 1. Other positive codes are routine specific. + +BOUND is not set if STATUS is returned as 0. If STATUS is -I then +BOUND is the bound illegally exceeded by input parameter I, where +WHICH is counted as 1, P as 2, Q as 3, X as 4, etc. If STATUS is +returned as 1 or 2 then BOUND is returned as the lower or upper bound +on the search interval respectively. + + BOUNDS + +Below are the rules that we used in determining bounds on quantities +to be calculated. Those who don't care can find a summary of the +bounds in dcdflib.chs. Input bounds are checked for legality of +input. The search range is the range of values searched for an +answer. + + Input Bounds + +Bounds on input parameters are checked by the CDF* routines. These +bounds were set according to the following rules. + +P: If the domain of the cdf (X) extends to -infinity then P must be +greater than 0 otherwise P must be greater than or equal to 0. P must +always be less than or equal to 1. + +Q: If the domain of the cdf (X) extends to +infinity then Q must be +greater than 0 otherwise Q must be greater than or equal to 0. Q must +always be less than or equal to 1. + +Further, P and Q must sum to 1. The smaller of the two P and Q will be +used in calculations to increase accuracy + +X: If the domain is infinite in either the positive or negative +direction, no check is performed in that direction. If the left end +of the domain is 0, then X is checked to assure non-negativity. + +DF, SD, etc.: Some auxiliary parameters must be positive. The lowest +input values accepted for these parameters is 1E-300. + + + Search Bounds + +These are the ranges searched for an answer. If the domain of the +parameter in the cdf is closed at some finite value, e.g., 0, then +this value is the same endpoint of the search range. If the domain is +open at some finite endpoint (which only occurs for 0 -- some +parameters must be strictly positive) then the endpoint is 1E-300. If +the domain is infinite in either direction then +/- 1E300 is used as +the endpoint of the search range. + + HOW THE ROUTINES WORK + +The cumulative distribution functions are computed directly. The +normal, gamma, and beta functions use the code from the references +cited. Other cdfs are calculated by relating them to one of these +distributions. For example, the binomial and negative binomial cdfs +can be converted to a beta cdf. This is how fractional observations +are handled. The formula from Abramowitz and Stegun for converting +the cdfs is cited in the fdoc file. (We think the formula for the +negative binomial in A&S is wrong, but there is a correct one which we +used.) + +The inverse normal and gamma are also taken from the references. For +all other parameters, a search is made for the value that provides the +desired P. Initial values are chosen crudely for the search (e.g., +5). If the domain of the cdf for the parameter being calculated is +infinite, a step doubling strategy is used to bound the desired value +then the zero finder is employed to refine the answer. The zero +finder attempts to obtain the answer accurately to about eight decimal +places. + + + + + diff --git a/modules/statistics/src/dcdflib/algdiv.f b/modules/statistics/src/dcdflib/algdiv.f new file mode 100755 index 000000000..6fab9b490 --- /dev/null +++ b/modules/statistics/src/dcdflib/algdiv.f @@ -0,0 +1,71 @@ + DOUBLE PRECISION FUNCTION algdiv(a,b) +C----------------------------------------------------------------------- +C +C COMPUTATION OF LN(GAMMA(B)/GAMMA(A+B)) WHEN B .GE. 8 +C +C -------- +C +C IN THIS ALGORITHM, DEL(X) IS THE FUNCTION DEFINED BY +C LN(GAMMA(X)) = (X - 0.5)*LN(X) - X + 0.5*LN(2*PI) + DEL(X). +C +C----------------------------------------------------------------------- +C .. Scalar Arguments .. + DOUBLE PRECISION a,b +C .. +C .. Local Scalars .. + DOUBLE PRECISION c,c0,c1,c2,c3,c4,c5,d,h,s11,s3,s5,s7,s9,t,u,v,w, + + x,x2 +C .. +C .. External Functions .. + DOUBLE PRECISION alnrel + EXTERNAL alnrel +C .. +C .. Intrinsic Functions .. + INTRINSIC dlog +C .. +C .. Data statements .. + DATA c0/.833333333333333D-01/,c1/-.277777777760991D-02/, + + c2/.793650666825390D-03/,c3/-.595202931351870D-03/, + + c4/.837308034031215D-03/,c5/-.165322962780713D-02/ +C .. +C .. Executable Statements .. +C------------------------ + IF (a.LE.b) GO TO 10 + h = b/a + c = 1.0D0/ (1.0D0+h) + x = h/ (1.0D0+h) + d = a + (b-0.5D0) + GO TO 20 + + 10 h = a/b + c = h/ (1.0D0+h) + x = 1.0D0/ (1.0D0+h) + d = b + (a-0.5D0) +C +C SET SN = (1 - X**N)/(1 - X) +C + 20 x2 = x*x + s3 = 1.0D0 + (x+x2) + s5 = 1.0D0 + (x+x2*s3) + s7 = 1.0D0 + (x+x2*s5) + s9 = 1.0D0 + (x+x2*s7) + s11 = 1.0D0 + (x+x2*s9) +C +C SET W = DEL(B) - DEL(A + B) +C + t = (1.0D0/b)**2 + w = ((((c5*s11*t+c4*s9)*t+c3*s7)*t+c2*s5)*t+c1*s3)*t + c0 + w = w* (c/b) +C +C COMBINE THE RESULTS +C + u = d*alnrel(a/b) + v = a* (dlog(b)-1.0D0) + IF (u.LE.v) GO TO 30 + algdiv = (w-v) - u + RETURN + + 30 algdiv = (w-u) - v + RETURN + + END diff --git a/modules/statistics/src/dcdflib/algdiv.lo b/modules/statistics/src/dcdflib/algdiv.lo new file mode 100755 index 000000000..586a075e0 --- /dev/null +++ b/modules/statistics/src/dcdflib/algdiv.lo @@ -0,0 +1,12 @@ +# src/dcdflib/algdiv.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/algdiv.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/statistics/src/dcdflib/alngam.f b/modules/statistics/src/dcdflib/alngam.f new file mode 100755 index 000000000..25e485c06 --- /dev/null +++ b/modules/statistics/src/dcdflib/alngam.f @@ -0,0 +1,131 @@ + DOUBLE PRECISION FUNCTION alngam(x) +C********************************************************************** +C +C DOUBLE PRECISION FUNCTION ALNGAM(X) +C double precision LN of the GAMma function +C +C +C Function +C +C +C Returns the natural logarithm of GAMMA(X). +C +C +C Arguments +C +C +C X --> value at which scaled log gamma is to be returned +C X is DOUBLE PRECISION +C +C +C Method +C +C +C If X .le. 6.0, then use recursion to get X below 3 +C then apply rational approximation number 5236 of +C Hart et al, Computer Approximations, John Wiley and +C Sons, NY, 1968. +C +C If X .gt. 6.0, then use recursion to get X to at least 12 and +C then use formula 5423 of the same source. +C +C********************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION hln2pi + PARAMETER (hln2pi=0.91893853320467274178D0) +C .. +C .. Scalar Arguments .. + DOUBLE PRECISION x +C .. +C .. Local Scalars .. + DOUBLE PRECISION offset,prod,xx + INTEGER i,n +C .. +C .. Local Arrays .. + DOUBLE PRECISION coef(5),scoefd(4),scoefn(9) +C .. +C .. External Functions .. + DOUBLE PRECISION devlpl + EXTERNAL devlpl +C .. +C .. Intrinsic Functions .. + INTRINSIC log,dble,int +C .. +C .. Data statements .. + DATA scoefn(1)/0.62003838007127258804D2/, + + scoefn(2)/0.36036772530024836321D2/, + + scoefn(3)/0.20782472531792126786D2/, + + scoefn(4)/0.6338067999387272343D1/, + + scoefn(5)/0.215994312846059073D1/, + + scoefn(6)/0.3980671310203570498D0/, + + scoefn(7)/0.1093115956710439502D0/, + + scoefn(8)/0.92381945590275995D-2/, + + scoefn(9)/0.29737866448101651D-2/ + DATA scoefd(1)/0.62003838007126989331D2/, + + scoefd(2)/0.9822521104713994894D1/, + + scoefd(3)/-0.8906016659497461257D1/, + + scoefd(4)/0.1000000000000000000D1/ + DATA coef(1)/0.83333333333333023564D-1/, + + coef(2)/-0.27777777768818808D-2/, + + coef(3)/0.79365006754279D-3/,coef(4)/-0.594997310889D-3/, + + coef(5)/0.8065880899D-3/ +C .. +C .. Executable Statements .. + IF (.NOT. (x.LE.6.0D0)) GO TO 70 + prod = 1.0D0 + xx = x + IF (.NOT. (x.GT.3.0D0)) GO TO 30 + 10 IF (.NOT. (xx.GT.3.0D0)) GO TO 20 + xx = xx - 1.0D0 + prod = prod*xx + GO TO 10 + + 20 CONTINUE + 30 IF (.NOT. (x.LT.2.0D0)) GO TO 60 + 40 IF (.NOT. (xx.LT.2.0D0)) GO TO 50 + prod = prod/xx + xx = xx + 1.0D0 + GO TO 40 + + 50 CONTINUE + 60 alngam = devlpl(scoefn,9,xx-2.0D0)/devlpl(scoefd,4,xx-2.0D0) +C +C +C COMPUTE RATIONAL APPROXIMATION TO GAMMA(X) +C +C + alngam = alngam*prod + alngam = log(alngam) + GO TO 110 + + 70 offset = hln2pi +C +C +C IF NECESSARY MAKE X AT LEAST 12 AND CARRY CORRECTION IN OFFSET +C +C +C ADDED TO PREVENT INTEGER OVERFLOW IN int(12.0D0-x) S. STEER + if (x .gt. 12.0d0) go to 90 +C + n = int(12.0D0-x) + IF (.NOT. (n.GT.0)) GO TO 90 + prod = 1.0D0 + DO 80,i = 1,n + prod = prod* (x+dble(i-1)) + 80 CONTINUE + offset = offset - log(prod) + xx = x + dble(n) + GO TO 100 + + 90 xx = x +C +C +C COMPUTE POWER SERIES +C +C + 100 alngam = devlpl(coef,5,1.0D0/ (xx**2))/xx + alngam = alngam + offset + (xx-0.5D0)*log(xx) - xx + 110 RETURN + + END diff --git a/modules/statistics/src/dcdflib/alngam.lo b/modules/statistics/src/dcdflib/alngam.lo new file mode 100755 index 000000000..d517d6851 --- /dev/null +++ b/modules/statistics/src/dcdflib/alngam.lo @@ -0,0 +1,12 @@ +# src/dcdflib/alngam.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/alngam.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/statistics/src/dcdflib/alnrel.f b/modules/statistics/src/dcdflib/alnrel.f new file mode 100755 index 000000000..bc9af9adf --- /dev/null +++ b/modules/statistics/src/dcdflib/alnrel.f @@ -0,0 +1,33 @@ + DOUBLE PRECISION FUNCTION alnrel(a) +C----------------------------------------------------------------------- +C EVALUATION OF THE FUNCTION LN(1 + A) +C----------------------------------------------------------------------- +C .. Scalar Arguments .. + DOUBLE PRECISION a +C .. +C .. Local Scalars .. + DOUBLE PRECISION p1,p2,p3,q1,q2,q3,t,t2,w,x +C .. +C .. Intrinsic Functions .. + INTRINSIC abs,dble,dlog +C .. +C .. Data statements .. + DATA p1/-.129418923021993D+01/,p2/.405303492862024D+00/, + + p3/-.178874546012214D-01/ + DATA q1/-.162752256355323D+01/,q2/.747811014037616D+00/, + + q3/-.845104217945565D-01/ +C .. +C .. Executable Statements .. +C-------------------------- + IF (abs(a).GT.0.375D0) GO TO 10 + t = a/ (a+2.0D0) + t2 = t*t + w = (((p3*t2+p2)*t2+p1)*t2+1.0D0)/ (((q3*t2+q2)*t2+q1)*t2+1.0D0) + alnrel = 2.0D0*t*w + RETURN +C + 10 x = 1.D0 + dble(a) + alnrel = dlog(x) + RETURN + + END diff --git a/modules/statistics/src/dcdflib/alnrel.lo b/modules/statistics/src/dcdflib/alnrel.lo new file mode 100755 index 000000000..599c6649d --- /dev/null +++ b/modules/statistics/src/dcdflib/alnrel.lo @@ -0,0 +1,12 @@ +# src/dcdflib/alnrel.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/alnrel.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/statistics/src/dcdflib/apser.f b/modules/statistics/src/dcdflib/apser.f new file mode 100755 index 000000000..e1558f521 --- /dev/null +++ b/modules/statistics/src/dcdflib/apser.f @@ -0,0 +1,46 @@ + DOUBLE PRECISION FUNCTION apser(a,b,x,eps) +C----------------------------------------------------------------------- +C APSER YIELDS THE INCOMPLETE BETA RATIO I(SUB(1-X))(B,A) FOR +C A .LE. MIN(EPS,EPS*B), B*X .LE. 1, AND X .LE. 0.5. USED WHEN +C A IS VERY SMALL. USE ONLY IF ABOVE INEQUALITIES ARE SATISFIED. +C----------------------------------------------------------------------- +C .. Scalar Arguments .. + DOUBLE PRECISION a,b,eps,x +C .. +C .. Local Scalars .. + DOUBLE PRECISION aj,bx,c,g,j,s,t,tol +C .. +C .. External Functions .. + DOUBLE PRECISION psi1 + EXTERNAL psi1 +C .. +C .. Intrinsic Functions .. + INTRINSIC abs,dlog +C .. +C .. Data statements .. +C-------------------- + DATA g/.577215664901533D0/ +C .. +C .. Executable Statements .. +C-------------------- + bx = b*x + t = x - bx + IF (b*eps.GT.2.D-2) GO TO 10 + c = dlog(x) + psi1(b) + g + t + GO TO 20 + + 10 c = dlog(bx) + g + t +C + 20 tol = 5.0D0*eps*abs(c) + j = 1.0D0 + s = 0.0D0 + 30 j = j + 1.0D0 + t = t* (x-bx/j) + aj = t/j + s = s + aj + IF (abs(aj).GT.tol) GO TO 30 +C + apser = -a* (c+s) + RETURN + + END diff --git a/modules/statistics/src/dcdflib/apser.lo b/modules/statistics/src/dcdflib/apser.lo new file mode 100755 index 000000000..566cd4fe3 --- /dev/null +++ b/modules/statistics/src/dcdflib/apser.lo @@ -0,0 +1,12 @@ +# src/dcdflib/apser.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/apser.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/statistics/src/dcdflib/basym.f b/modules/statistics/src/dcdflib/basym.f new file mode 100755 index 000000000..356da173b --- /dev/null +++ b/modules/statistics/src/dcdflib/basym.f @@ -0,0 +1,120 @@ + DOUBLE PRECISION FUNCTION basym(a,b,lambda,eps) +C----------------------------------------------------------------------- +C ASYMPTOTIC EXPANSION FOR IX(A,B) FOR LARGE A AND B. +C LAMBDA = (A + B)*Y - B AND EPS IS THE TOLERANCE USED. +C IT IS ASSUMED THAT LAMBDA IS NONNEGATIVE AND THAT +C A AND B ARE GREATER THAN OR EQUAL TO 15. +C----------------------------------------------------------------------- +C .. Scalar Arguments .. + DOUBLE PRECISION a,b,eps,lambda +C .. +C .. Local Scalars .. + DOUBLE PRECISION bsum,dsum,e0,e1,f,h,h2,hn,j0,j1,r,r0,r1,s,sum,t, + + t0,t1,u,w,w0,z,z0,z2,zn,znm1 + INTEGER i,im1,imj,j,m,mm1,mmj,n,np1,num +C .. +C .. Local Arrays .. + DOUBLE PRECISION a0(21),b0(21),c(21),d(21) +C .. +C .. External Functions .. + DOUBLE PRECISION bcorr,erfc1,rlog1 + EXTERNAL bcorr,erfc1,rlog1 +C .. +C .. Intrinsic Functions .. + INTRINSIC abs,exp,sqrt +C .. +C .. Data statements .. +C------------------------ +C ****** NUM IS THE MAXIMUM VALUE THAT N CAN TAKE IN THE DO LOOP +C ENDING AT STATEMENT 50. IT IS REQUIRED THAT NUM BE EVEN. +C THE ARRAYS A0, B0, C, D HAVE DIMENSION NUM + 1. +C +C------------------------ +C E0 = 2/SQRT(PI) +C E1 = 2**(-3/2) +C------------------------ + DATA num/20/ + DATA e0/1.12837916709551D0/,e1/.353553390593274D0/ +C .. +C .. Executable Statements .. +C------------------------ + basym = 0.0D0 + IF (a.GE.b) GO TO 10 + h = a/b + r0 = 1.0D0/ (1.0D0+h) + r1 = (b-a)/b + w0 = 1.0D0/sqrt(a* (1.0D0+h)) + GO TO 20 + + 10 h = b/a + r0 = 1.0D0/ (1.0D0+h) + r1 = (b-a)/a + w0 = 1.0D0/sqrt(b* (1.0D0+h)) +C + 20 f = a*rlog1(-lambda/a) + b*rlog1(lambda/b) + t = exp(-f) + IF (t.EQ.0.0D0) RETURN + z0 = sqrt(f) + z = 0.5D0* (z0/e1) + z2 = f + f +C + a0(1) = (2.0D0/3.0D0)*r1 + c(1) = -0.5D0*a0(1) + d(1) = -c(1) + j0 = (0.5D0/e0)*erfc1(1,z0) + j1 = e1 + sum = j0 + d(1)*w0*j1 +C + s = 1.0D0 + h2 = h*h + hn = 1.0D0 + w = w0 + znm1 = z + zn = z2 + DO 70 n = 2,num,2 + hn = h2*hn + a0(n) = 2.0D0*r0* (1.0D0+h*hn)/ (n+2.0D0) + np1 = n + 1 + s = s + hn + a0(np1) = 2.0D0*r1*s/ (n+3.0D0) +C + DO 60 i = n,np1 + r = -0.5D0* (i+1.0D0) + b0(1) = r*a0(1) + DO 40 m = 2,i + bsum = 0.0D0 + mm1 = m - 1 + DO 30 j = 1,mm1 + mmj = m - j + bsum = bsum + (j*r-mmj)*a0(j)*b0(mmj) + 30 CONTINUE + b0(m) = r*a0(m) + bsum/m + 40 CONTINUE + c(i) = b0(i)/ (i+1.0D0) +C + dsum = 0.0D0 + im1 = i - 1 + DO 50 j = 1,im1 + imj = i - j + dsum = dsum + d(imj)*c(j) + 50 CONTINUE + d(i) = - (dsum+c(i)) + 60 CONTINUE +C + j0 = e1*znm1 + (n-1.0D0)*j0 + j1 = e1*zn + n*j1 + znm1 = z2*znm1 + zn = z2*zn + w = w0*w + t0 = d(n)*w*j0 + w = w0*w + t1 = d(np1)*w*j1 + sum = sum + (t0+t1) + IF ((abs(t0)+abs(t1)).LE.eps*sum) GO TO 80 + 70 CONTINUE +C + 80 u = exp(-bcorr(a,b)) + basym = e0*t*u*sum + RETURN + + END diff --git a/modules/statistics/src/dcdflib/basym.lo b/modules/statistics/src/dcdflib/basym.lo new file mode 100755 index 000000000..873b35006 --- /dev/null +++ b/modules/statistics/src/dcdflib/basym.lo @@ -0,0 +1,12 @@ +# src/dcdflib/basym.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/basym.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/statistics/src/dcdflib/bcorr.f b/modules/statistics/src/dcdflib/bcorr.f new file mode 100755 index 000000000..381de8b62 --- /dev/null +++ b/modules/statistics/src/dcdflib/bcorr.f @@ -0,0 +1,54 @@ + DOUBLE PRECISION FUNCTION bcorr(a0,b0) +C----------------------------------------------------------------------- +C +C EVALUATION OF DEL(A0) + DEL(B0) - DEL(A0 + B0) WHERE +C LN(GAMMA(A)) = (A - 0.5)*LN(A) - A + 0.5*LN(2*PI) + DEL(A). +C IT IS ASSUMED THAT A0 .GE. 8 AND B0 .GE. 8. +C +C----------------------------------------------------------------------- +C .. Scalar Arguments .. + DOUBLE PRECISION a0,b0 +C .. +C .. Local Scalars .. + DOUBLE PRECISION a,b,c,c0,c1,c2,c3,c4,c5,h,s11,s3,s5,s7,s9,t,w,x, + + x2 +C .. +C .. Intrinsic Functions .. + INTRINSIC dmax1,dmin1 +C .. +C .. Data statements .. + DATA c0/.833333333333333D-01/,c1/-.277777777760991D-02/, + + c2/.793650666825390D-03/,c3/-.595202931351870D-03/, + + c4/.837308034031215D-03/,c5/-.165322962780713D-02/ +C .. +C .. Executable Statements .. +C------------------------ + a = dmin1(a0,b0) + b = dmax1(a0,b0) +C + h = a/b + c = h/ (1.0D0+h) + x = 1.0D0/ (1.0D0+h) + x2 = x*x +C +C SET SN = (1 - X**N)/(1 - X) +C + s3 = 1.0D0 + (x+x2) + s5 = 1.0D0 + (x+x2*s3) + s7 = 1.0D0 + (x+x2*s5) + s9 = 1.0D0 + (x+x2*s7) + s11 = 1.0D0 + (x+x2*s9) +C +C SET W = DEL(B) - DEL(A + B) +C + t = (1.0D0/b)**2 + w = ((((c5*s11*t+c4*s9)*t+c3*s7)*t+c2*s5)*t+c1*s3)*t + c0 + w = w* (c/b) +C +C COMPUTE DEL(A) + W +C + t = (1.0D0/a)**2 + bcorr = (((((c5*t+c4)*t+c3)*t+c2)*t+c1)*t+c0)/a + w + RETURN + + END diff --git a/modules/statistics/src/dcdflib/bcorr.lo b/modules/statistics/src/dcdflib/bcorr.lo new file mode 100755 index 000000000..bca01afce --- /dev/null +++ b/modules/statistics/src/dcdflib/bcorr.lo @@ -0,0 +1,12 @@ +# src/dcdflib/bcorr.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/bcorr.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/statistics/src/dcdflib/betaln.f b/modules/statistics/src/dcdflib/betaln.f new file mode 100755 index 000000000..d9a49b6c4 --- /dev/null +++ b/modules/statistics/src/dcdflib/betaln.f @@ -0,0 +1,103 @@ + DOUBLE PRECISION FUNCTION betaln(a0,b0) +C----------------------------------------------------------------------- +C EVALUATION OF THE LOGARITHM OF THE BETA FUNCTION +C----------------------------------------------------------------------- +C E = 0.5*LN(2*PI) +C-------------------------- +C .. Scalar Arguments .. + DOUBLE PRECISION a0,b0 +C .. +C .. Local Scalars .. + DOUBLE PRECISION a,b,c,e,h,u,v,w,z + INTEGER i,n +C .. +C .. External Functions .. + DOUBLE PRECISION algdiv,alnrel,bcorr,gamln,gsumln + EXTERNAL algdiv,alnrel,bcorr,gamln,gsumln +C .. +C .. Intrinsic Functions .. + INTRINSIC dlog,dmax1,dmin1 +C .. +C .. Data statements .. + DATA e/.918938533204673D0/ +C .. +C .. Executable Statements .. +C-------------------------- + a = dmin1(a0,b0) + b = dmax1(a0,b0) + IF (a.GE.8.0D0) GO TO 100 + IF (a.GE.1.0D0) GO TO 20 +C----------------------------------------------------------------------- +C PROCEDURE WHEN A .LT. 1 +C----------------------------------------------------------------------- + IF (b.GE.8.0D0) GO TO 10 + betaln = gamln(a) + (gamln(b)-gamln(a+b)) + RETURN + + 10 betaln = gamln(a) + algdiv(a,b) + RETURN +C----------------------------------------------------------------------- +C PROCEDURE WHEN 1 .LE. A .LT. 8 +C----------------------------------------------------------------------- + 20 IF (a.GT.2.0D0) GO TO 40 + IF (b.GT.2.0D0) GO TO 30 + betaln = gamln(a) + gamln(b) - gsumln(a,b) + RETURN + + 30 w = 0.0D0 + IF (b.LT.8.0D0) GO TO 60 + betaln = gamln(a) + algdiv(a,b) + RETURN +C +C REDUCTION OF A WHEN B .LE. 1000 +C + 40 IF (b.GT.1000.0D0) GO TO 80 + n = a - 1.0D0 + w = 1.0D0 + DO 50 i = 1,n + a = a - 1.0D0 + h = a/b + w = w* (h/ (1.0D0+h)) + 50 CONTINUE + w = dlog(w) + IF (b.LT.8.0D0) GO TO 60 + betaln = w + gamln(a) + algdiv(a,b) + RETURN +C +C REDUCTION OF B WHEN B .LT. 8 +C + 60 n = b - 1.0D0 + z = 1.0D0 + DO 70 i = 1,n + b = b - 1.0D0 + z = z* (b/ (a+b)) + 70 CONTINUE + betaln = w + dlog(z) + (gamln(a)+ (gamln(b)-gsumln(a,b))) + RETURN +C +C REDUCTION OF A WHEN B .GT. 1000 +C + 80 n = a - 1.0D0 + w = 1.0D0 + DO 90 i = 1,n + a = a - 1.0D0 + w = w* (a/ (1.0D0+a/b)) + 90 CONTINUE + betaln = (dlog(w)-n*dlog(b)) + (gamln(a)+algdiv(a,b)) + RETURN +C----------------------------------------------------------------------- +C PROCEDURE WHEN A .GE. 8 +C----------------------------------------------------------------------- + 100 w = bcorr(a,b) + h = a/b + c = h/ (1.0D0+h) + u = - (a-0.5D0)*dlog(c) + v = b*alnrel(h) + IF (u.LE.v) GO TO 110 + betaln = (((-0.5D0*dlog(b)+e)+w)-v) - u + RETURN + + 110 betaln = (((-0.5D0*dlog(b)+e)+w)-u) - v + RETURN + + END diff --git a/modules/statistics/src/dcdflib/betaln.lo b/modules/statistics/src/dcdflib/betaln.lo new file mode 100755 index 000000000..a7e494f74 --- /dev/null +++ b/modules/statistics/src/dcdflib/betaln.lo @@ -0,0 +1,12 @@ +# src/dcdflib/betaln.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/betaln.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/statistics/src/dcdflib/bfrac.f b/modules/statistics/src/dcdflib/bfrac.f new file mode 100755 index 000000000..1557eca8d --- /dev/null +++ b/modules/statistics/src/dcdflib/bfrac.f @@ -0,0 +1,77 @@ + DOUBLE PRECISION FUNCTION bfrac(a,b,x,y,lambda,eps) +C----------------------------------------------------------------------- +C CONTINUED FRACTION EXPANSION FOR IX(A,B) WHEN A,B .GT. 1. +C IT IS ASSUMED THAT LAMBDA = (A + B)*Y - B. +C----------------------------------------------------------------------- +C .. Scalar Arguments .. + DOUBLE PRECISION a,b,eps,lambda,x,y +C .. +C .. Local Scalars .. + DOUBLE PRECISION alpha,an,anp1,beta,bn,bnp1,c,c0,c1,e,n,p,r,r0,s, + + t,w,yp1 +C .. +C .. External Functions .. + DOUBLE PRECISION brcomp + EXTERNAL brcomp +C .. +C .. Intrinsic Functions .. + INTRINSIC abs +C .. +C .. Executable Statements .. +C-------------------- + bfrac = brcomp(a,b,x,y) + IF (bfrac.EQ.0.0D0) RETURN +C + c = 1.0D0 + lambda + c0 = b/a + c1 = 1.0D0 + 1.0D0/a + yp1 = y + 1.0D0 +C + n = 0.0D0 + p = 1.0D0 + s = a + 1.0D0 + an = 0.0D0 + bn = 1.0D0 + anp1 = 1.0D0 + bnp1 = c/c1 + r = c1/c +C +C CONTINUED FRACTION CALCULATION +C + 10 n = n + 1.0D0 + t = n/a + w = n* (b-n)*x + e = a/s + alpha = (p* (p+c0)*e*e)* (w*x) + e = (1.0D0+t)/ (c1+t+t) + beta = n + w/s + e* (c+n*yp1) + p = 1.0D0 + t + s = s + 2.0D0 +C +C UPDATE AN, BN, ANP1, AND BNP1 +C + t = alpha*an + beta*anp1 + an = anp1 + anp1 = t + t = alpha*bn + beta*bnp1 + bn = bnp1 + bnp1 = t +C + r0 = r + r = anp1/bnp1 + IF (abs(r-r0).LE.eps*r) GO TO 20 +C +C RESCALE AN, BN, ANP1, AND BNP1 +C + an = an/bnp1 + bn = bn/bnp1 + anp1 = r + bnp1 = 1.0D0 + GO TO 10 +C +C TERMINATION +C + 20 bfrac = bfrac*r + RETURN + + END diff --git a/modules/statistics/src/dcdflib/bfrac.lo b/modules/statistics/src/dcdflib/bfrac.lo new file mode 100755 index 000000000..13dd6779d --- /dev/null +++ b/modules/statistics/src/dcdflib/bfrac.lo @@ -0,0 +1,12 @@ +# src/dcdflib/bfrac.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/bfrac.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/statistics/src/dcdflib/bgrat.f b/modules/statistics/src/dcdflib/bgrat.f new file mode 100755 index 000000000..e6a707b65 --- /dev/null +++ b/modules/statistics/src/dcdflib/bgrat.f @@ -0,0 +1,93 @@ + SUBROUTINE bgrat(a,b,x,y,w,eps,ierr) +C----------------------------------------------------------------------- +C ASYMPTOTIC EXPANSION FOR IX(A,B) WHEN A IS LARGER THAN B. +C THE RESULT OF THE EXPANSION IS ADDED TO W. IT IS ASSUMED +C THAT A .GE. 15 AND B .LE. 1. EPS IS THE TOLERANCE USED. +C IERR IS A VARIABLE THAT REPORTS THE STATUS OF THE RESULTS. +C----------------------------------------------------------------------- +C .. Scalar Arguments .. + DOUBLE PRECISION a,b,eps,w,x,y + INTEGER ierr +C .. +C .. Local Scalars .. + DOUBLE PRECISION bm1,bp2n,cn,coef,dj,j,l,lnx,n2,nu,p,q,r,s,sum,t, + + t2,u,v,z + INTEGER i,n,nm1 +C .. +C .. Local Arrays .. + DOUBLE PRECISION c(30),d(30) +C .. +C .. External Functions .. + DOUBLE PRECISION algdiv,alnrel,gam1 + EXTERNAL algdiv,alnrel,gam1 +C .. +C .. External Subroutines .. + EXTERNAL grat1 +C .. +C .. Intrinsic Functions .. + INTRINSIC abs,dlog,exp +C .. +C .. Executable Statements .. +C + bm1 = (b-0.5D0) - 0.5D0 + nu = a + 0.5D0*bm1 + IF (y.GT.0.375D0) GO TO 10 + lnx = alnrel(-y) + GO TO 20 + + 10 lnx = dlog(x) + 20 z = -nu*lnx + IF (b*z.EQ.0.0D0) GO TO 70 +C +C COMPUTATION OF THE EXPANSION +C SET R = EXP(-Z)*Z**B/GAMMA(B) +C + r = b* (1.0D0+gam1(b))*exp(b*dlog(z)) + r = r*exp(a*lnx)*exp(0.5D0*bm1*lnx) + u = algdiv(b,a) + b*dlog(nu) + u = r*exp(-u) + IF (u.EQ.0.0D0) GO TO 70 + CALL grat1(b,z,r,p,q,eps) +C + v = 0.25D0* (1.0D0/nu)**2 + t2 = 0.25D0*lnx*lnx + l = w/u + j = q/r + sum = j + t = 1.0D0 + cn = 1.0D0 + n2 = 0.0D0 + DO 50 n = 1,30 + bp2n = b + n2 + j = (bp2n* (bp2n+1.0D0)*j+ (z+bp2n+1.0D0)*t)*v + n2 = n2 + 2.0D0 + t = t*t2 + cn = cn/ (n2* (n2+1.0D0)) + c(n) = cn + s = 0.0D0 + IF (n.EQ.1) GO TO 40 + nm1 = n - 1 + coef = b - n + DO 30 i = 1,nm1 + s = s + coef*c(i)*d(n-i) + coef = coef + b + 30 CONTINUE + 40 d(n) = bm1*cn + s/n + dj = d(n)*j + sum = sum + dj + IF (sum.LE.0.0D0) GO TO 70 + IF (abs(dj).LE.eps* (sum+l)) GO TO 60 + 50 CONTINUE +C +C ADD THE RESULTS TO W +C + 60 ierr = 0 + w = w + u*sum + RETURN +C +C THE EXPANSION CANNOT BE COMPUTED +C + 70 ierr = 1 + RETURN + + END diff --git a/modules/statistics/src/dcdflib/bgrat.lo b/modules/statistics/src/dcdflib/bgrat.lo new file mode 100755 index 000000000..e16d301e9 --- /dev/null +++ b/modules/statistics/src/dcdflib/bgrat.lo @@ -0,0 +1,12 @@ +# src/dcdflib/bgrat.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/bgrat.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/statistics/src/dcdflib/bpser.f b/modules/statistics/src/dcdflib/bpser.f new file mode 100755 index 000000000..802f0a6db --- /dev/null +++ b/modules/statistics/src/dcdflib/bpser.f @@ -0,0 +1,99 @@ + DOUBLE PRECISION FUNCTION bpser(a,b,x,eps) +C----------------------------------------------------------------------- +C POWER SERIES EXPANSION FOR EVALUATING IX(A,B) WHEN B .LE. 1 +C OR B*X .LE. 0.7. EPS IS THE TOLERANCE USED. +C----------------------------------------------------------------------- +C .. Scalar Arguments .. + DOUBLE PRECISION a,b,eps,x +C .. +C .. Local Scalars .. + DOUBLE PRECISION a0,apb,b0,c,n,sum,t,tol,u,w,z + INTEGER i,m +C .. +C .. External Functions .. + DOUBLE PRECISION algdiv,betaln,gam1,gamln1 + EXTERNAL algdiv,betaln,gam1,gamln1 +C .. +C .. Intrinsic Functions .. + INTRINSIC abs,dble,dlog,dmax1,dmin1,exp +C .. +C .. Executable Statements .. +C + bpser = 0.0D0 + IF (x.EQ.0.0D0) RETURN +C----------------------------------------------------------------------- +C COMPUTE THE FACTOR X**A/(A*BETA(A,B)) +C----------------------------------------------------------------------- + a0 = dmin1(a,b) + IF (a0.LT.1.0D0) GO TO 10 + z = a*dlog(x) - betaln(a,b) + bpser = exp(z)/a + GO TO 100 + + 10 b0 = dmax1(a,b) + IF (b0.GE.8.0D0) GO TO 90 + IF (b0.GT.1.0D0) GO TO 40 +C +C PROCEDURE FOR A0 .LT. 1 AND B0 .LE. 1 +C + bpser = x**a + IF (bpser.EQ.0.0D0) RETURN +C + apb = a + b + IF (apb.GT.1.0D0) GO TO 20 + z = 1.0D0 + gam1(apb) + GO TO 30 + + 20 u = dble(a) + dble(b) - 1.D0 + z = (1.0D0+gam1(u))/apb +C + 30 c = (1.0D0+gam1(a))* (1.0D0+gam1(b))/z + bpser = bpser*c* (b/apb) + GO TO 100 +C +C PROCEDURE FOR A0 .LT. 1 AND 1 .LT. B0 .LT. 8 +C + 40 u = gamln1(a0) + m = b0 - 1.0D0 + IF (m.LT.1) GO TO 60 + c = 1.0D0 + DO 50 i = 1,m + b0 = b0 - 1.0D0 + c = c* (b0/ (a0+b0)) + 50 CONTINUE + u = dlog(c) + u +C + 60 z = a*dlog(x) - u + b0 = b0 - 1.0D0 + apb = a0 + b0 + IF (apb.GT.1.0D0) GO TO 70 + t = 1.0D0 + gam1(apb) + GO TO 80 + + 70 u = dble(a0) + dble(b0) - 1.D0 + t = (1.0D0+gam1(u))/apb + 80 bpser = exp(z)* (a0/a)* (1.0D0+gam1(b0))/t + GO TO 100 +C +C PROCEDURE FOR A0 .LT. 1 AND B0 .GE. 8 +C + 90 u = gamln1(a0) + algdiv(a0,b0) + z = a*dlog(x) - u + bpser = (a0/a)*exp(z) + 100 IF (bpser.EQ.0.0D0 .OR. a.LE.0.1D0*eps) RETURN +C----------------------------------------------------------------------- +C COMPUTE THE SERIES +C----------------------------------------------------------------------- + sum = 0.0D0 + n = 0.0D0 + c = 1.0D0 + tol = eps/a + 110 n = n + 1.0D0 + c = c* (0.5D0+ (0.5D0-b/n))*x + w = c/ (a+n) + sum = sum + w + IF (abs(w).GT.tol) GO TO 110 + bpser = bpser* (1.0D0+a*sum) + RETURN + + END diff --git a/modules/statistics/src/dcdflib/bpser.lo b/modules/statistics/src/dcdflib/bpser.lo new file mode 100755 index 000000000..a41991a2e --- /dev/null +++ b/modules/statistics/src/dcdflib/bpser.lo @@ -0,0 +1,12 @@ +# src/dcdflib/bpser.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/bpser.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/statistics/src/dcdflib/bratio.f b/modules/statistics/src/dcdflib/bratio.f new file mode 100755 index 000000000..7cd451126 --- /dev/null +++ b/modules/statistics/src/dcdflib/bratio.f @@ -0,0 +1,236 @@ + SUBROUTINE bratio(a,b,x,y,w,w1,ierr) +C----------------------------------------------------------------------- +C +C EVALUATION OF THE INCOMPLETE BETA FUNCTION IX(A,B) +C +C -------------------- +C +C IT IS ASSUMED THAT A AND B ARE NONNEGATIVE, AND THAT X .LE. 1 +C AND Y = 1 - X. BRATIO ASSIGNS W AND W1 THE VALUES +C +C W = IX(A,B) +C W1 = 1 - IX(A,B) +C +C IERR IS A VARIABLE THAT REPORTS THE STATUS OF THE RESULTS. +C IF NO INPUT ERRORS ARE DETECTED THEN IERR IS SET TO 0 AND +C W AND W1 ARE COMPUTED. OTHERWISE, IF AN ERROR IS DETECTED, +C THEN W AND W1 ARE ASSIGNED THE VALUE 0 AND IERR IS SET TO +C ONE OF THE FOLLOWING VALUES ... +C +C IERR = 1 IF A OR B IS NEGATIVE +C IERR = 2 IF A = B = 0 +C IERR = 3 IF X .LT. 0 OR X .GT. 1 +C IERR = 4 IF Y .LT. 0 OR Y .GT. 1 +C IERR = 5 IF X + Y .NE. 1 +C IERR = 6 IF X = A = 0 +C IERR = 7 IF Y = B = 0 +C +C-------------------- +C WRITTEN BY ALFRED H. MORRIS, JR. +C NAVAL SURFACE WARFARE CENTER +C DAHLGREN, VIRGINIA +C REVISED ... NOV 1991 +C----------------------------------------------------------------------- +C .. Scalar Arguments .. + DOUBLE PRECISION a,b,w,w1,x,y + INTEGER ierr +C .. +C .. Local Scalars .. + DOUBLE PRECISION a0,b0,eps,lambda,t,x0,y0,z + INTEGER ierr1,ind,n +C .. +C .. External Functions .. + DOUBLE PRECISION apser,basym,bfrac,bpser,bup,fpser,spmpar + EXTERNAL apser,basym,bfrac,bpser,bup,fpser,spmpar +C .. +C .. External Subroutines .. + EXTERNAL bgrat +C .. +C .. Intrinsic Functions .. + INTRINSIC abs,dmax1,dmin1 +C .. +C .. Executable Statements .. +C----------------------------------------------------------------------- +C +C ****** EPS IS A MACHINE DEPENDENT CONSTANT. EPS IS THE SMALLEST +C FLOATING POINT NUMBER FOR WHICH 1.0 + EPS .GT. 1.0 +C + eps = spmpar(1) +C +C----------------------------------------------------------------------- + w = 0.0D0 + w1 = 0.0D0 + IF (a.LT.0.0D0 .OR. b.LT.0.0D0) GO TO 270 + IF (a.EQ.0.0D0 .AND. b.EQ.0.0D0) GO TO 280 + IF (x.LT.0.0D0 .OR. x.GT.1.0D0) GO TO 290 + IF (y.LT.0.0D0 .OR. y.GT.1.0D0) GO TO 300 + z = ((x+y)-0.5D0) - 0.5D0 + IF (abs(z).GT.3.0D0*eps) GO TO 310 +C + ierr = 0 + IF (x.EQ.0.0D0) GO TO 210 + IF (y.EQ.0.0D0) GO TO 230 + IF (a.EQ.0.0D0) GO TO 240 + IF (b.EQ.0.0D0) GO TO 220 +C + eps = dmax1(eps,1.D-15) + IF (dmax1(a,b).LT.1.D-3*eps) GO TO 260 +C + ind = 0 + a0 = a + b0 = b + x0 = x + y0 = y + IF (dmin1(a0,b0).GT.1.0D0) GO TO 40 +C +C PROCEDURE FOR A0 .LE. 1 OR B0 .LE. 1 +C + IF (x.LE.0.5D0) GO TO 10 + ind = 1 + a0 = b + b0 = a + x0 = y + y0 = x +C + 10 IF (b0.LT.dmin1(eps,eps*a0)) GO TO 90 + IF (a0.LT.dmin1(eps,eps*b0) .AND. b0*x0.LE.1.0D0) GO TO 100 + IF (dmax1(a0,b0).GT.1.0D0) GO TO 20 + IF (a0.GE.dmin1(0.2D0,b0)) GO TO 110 + IF (x0**a0.LE.0.9D0) GO TO 110 + IF (x0.GE.0.3D0) GO TO 120 + n = 20 + GO TO 140 +C + 20 IF (b0.LE.1.0D0) GO TO 110 + IF (x0.GE.0.3D0) GO TO 120 + IF (x0.GE.0.1D0) GO TO 30 + IF ((x0*b0)**a0.LE.0.7D0) GO TO 110 + 30 IF (b0.GT.15.0D0) GO TO 150 + n = 20 + GO TO 140 +C +C PROCEDURE FOR A0 .GT. 1 AND B0 .GT. 1 +C + 40 IF (a.GT.b) GO TO 50 + lambda = a - (a+b)*x + GO TO 60 + + 50 lambda = (a+b)*y - b + 60 IF (lambda.GE.0.0D0) GO TO 70 + ind = 1 + a0 = b + b0 = a + x0 = y + y0 = x + lambda = abs(lambda) +C + 70 IF (b0.LT.40.0D0 .AND. b0*x0.LE.0.7D0) GO TO 110 + IF (b0.LT.40.0D0) GO TO 160 + IF (a0.GT.b0) GO TO 80 + IF (a0.LE.100.0D0) GO TO 130 + IF (lambda.GT.0.03D0*a0) GO TO 130 + GO TO 200 + + 80 IF (b0.LE.100.0D0) GO TO 130 + IF (lambda.GT.0.03D0*b0) GO TO 130 + GO TO 200 +C +C EVALUATION OF THE APPROPRIATE ALGORITHM +C + 90 w = fpser(a0,b0,x0,eps) + w1 = 0.5D0 + (0.5D0-w) + GO TO 250 +C + 100 w1 = apser(a0,b0,x0,eps) + w = 0.5D0 + (0.5D0-w1) + GO TO 250 +C + 110 w = bpser(a0,b0,x0,eps) + w1 = 0.5D0 + (0.5D0-w) + GO TO 250 +C + 120 w1 = bpser(b0,a0,y0,eps) + w = 0.5D0 + (0.5D0-w1) + GO TO 250 +C + 130 w = bfrac(a0,b0,x0,y0,lambda,15.0D0*eps) + w1 = 0.5D0 + (0.5D0-w) + GO TO 250 +C + 140 w1 = bup(b0,a0,y0,x0,n,eps) + b0 = b0 + n + 150 CALL bgrat(b0,a0,y0,x0,w1,15.0D0*eps,ierr1) + w = 0.5D0 + (0.5D0-w1) + GO TO 250 +C + 160 n = b0 + b0 = b0 - n + IF (b0.NE.0.0D0) GO TO 170 + n = n - 1 + b0 = 1.0D0 + 170 w = bup(b0,a0,y0,x0,n,eps) + IF (x0.GT.0.7D0) GO TO 180 + w = w + bpser(a0,b0,x0,eps) + w1 = 0.5D0 + (0.5D0-w) + GO TO 250 +C + 180 IF (a0.GT.15.0D0) GO TO 190 + n = 20 + w = w + bup(a0,b0,x0,y0,n,eps) + a0 = a0 + n + 190 CALL bgrat(a0,b0,x0,y0,w,15.0D0*eps,ierr1) + w1 = 0.5D0 + (0.5D0-w) + GO TO 250 +C + 200 w = basym(a0,b0,lambda,100.0D0*eps) + w1 = 0.5D0 + (0.5D0-w) + GO TO 250 +C +C TERMINATION OF THE PROCEDURE +C + 210 IF (a.EQ.0.0D0) GO TO 320 + 220 w = 0.0D0 + w1 = 1.0D0 + RETURN +C + 230 IF (b.EQ.0.0D0) GO TO 330 + 240 w = 1.0D0 + w1 = 0.0D0 + RETURN +C + 250 IF (ind.EQ.0) RETURN + t = w + w = w1 + w1 = t + RETURN +C +C PROCEDURE FOR A AND B .LT. 1.E-3*EPS +C + 260 w = b/ (a+b) + w1 = a/ (a+b) + RETURN +C +C ERROR RETURN +C + 270 ierr = 1 + RETURN + + 280 ierr = 2 + RETURN + + 290 ierr = 3 + RETURN + + 300 ierr = 4 + RETURN + + 310 ierr = 5 + RETURN + + 320 ierr = 6 + RETURN + + 330 ierr = 7 + RETURN + + END diff --git a/modules/statistics/src/dcdflib/bratio.lo b/modules/statistics/src/dcdflib/bratio.lo new file mode 100755 index 000000000..0a8ef1129 --- /dev/null +++ b/modules/statistics/src/dcdflib/bratio.lo @@ -0,0 +1,12 @@ +# src/dcdflib/bratio.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/bratio.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/statistics/src/dcdflib/brcmp1.f b/modules/statistics/src/dcdflib/brcmp1.f new file mode 100755 index 000000000..ae3b412c4 --- /dev/null +++ b/modules/statistics/src/dcdflib/brcmp1.f @@ -0,0 +1,136 @@ + DOUBLE PRECISION FUNCTION brcmp1(mu,a,b,x,y) +C----------------------------------------------------------------------- +C EVALUATION OF EXP(MU) * (X**A*Y**B/BETA(A,B)) +C----------------------------------------------------------------------- +C .. Scalar Arguments .. + DOUBLE PRECISION a,b,x,y + INTEGER mu +C .. +C .. Local Scalars .. + DOUBLE PRECISION a0,apb,b0,c,const,e,h,lambda,lnx,lny,t,u,v,x0,y0, + + z + INTEGER i,n +C .. +C .. External Functions .. + DOUBLE PRECISION algdiv,alnrel,bcorr,betaln,esum,gam1,gamln1,rlog1 + EXTERNAL algdiv,alnrel,bcorr,betaln,esum,gam1,gamln1,rlog1 +C .. +C .. Intrinsic Functions .. + INTRINSIC abs,dble,dlog,dmax1,dmin1,exp,sqrt +C .. +C .. Data statements .. +C----------------- +C CONST = 1/SQRT(2*PI) +C----------------- + DATA const/.398942280401433D0/ +C .. +C .. Executable Statements .. +C + a0 = dmin1(a,b) + IF (a0.GE.8.0D0) GO TO 130 +C + IF (x.GT.0.375D0) GO TO 10 + lnx = dlog(x) + lny = alnrel(-x) + GO TO 30 + + 10 IF (y.GT.0.375D0) GO TO 20 + lnx = alnrel(-y) + lny = dlog(y) + GO TO 30 + + 20 lnx = dlog(x) + lny = dlog(y) +C + 30 z = a*lnx + b*lny + IF (a0.LT.1.0D0) GO TO 40 + z = z - betaln(a,b) + brcmp1 = esum(mu,z) + RETURN +C----------------------------------------------------------------------- +C PROCEDURE FOR A .LT. 1 OR B .LT. 1 +C----------------------------------------------------------------------- + 40 b0 = dmax1(a,b) + IF (b0.GE.8.0D0) GO TO 120 + IF (b0.GT.1.0D0) GO TO 70 +C +C ALGORITHM FOR B0 .LE. 1 +C + brcmp1 = esum(mu,z) + IF (brcmp1.EQ.0.0D0) RETURN +C + apb = a + b + IF (apb.GT.1.0D0) GO TO 50 + z = 1.0D0 + gam1(apb) + GO TO 60 + + 50 u = dble(a) + dble(b) - 1.D0 + z = (1.0D0+gam1(u))/apb +C + 60 c = (1.0D0+gam1(a))* (1.0D0+gam1(b))/z + brcmp1 = brcmp1* (a0*c)/ (1.0D0+a0/b0) + RETURN +C +C ALGORITHM FOR 1 .LT. B0 .LT. 8 +C + 70 u = gamln1(a0) + n = b0 - 1.0D0 + IF (n.LT.1) GO TO 90 + c = 1.0D0 + DO 80 i = 1,n + b0 = b0 - 1.0D0 + c = c* (b0/ (a0+b0)) + 80 CONTINUE + u = dlog(c) + u +C + 90 z = z - u + b0 = b0 - 1.0D0 + apb = a0 + b0 + IF (apb.GT.1.0D0) GO TO 100 + t = 1.0D0 + gam1(apb) + GO TO 110 + + 100 u = dble(a0) + dble(b0) - 1.D0 + t = (1.0D0+gam1(u))/apb + 110 brcmp1 = a0*esum(mu,z)* (1.0D0+gam1(b0))/t + RETURN +C +C ALGORITHM FOR B0 .GE. 8 +C + 120 u = gamln1(a0) + algdiv(a0,b0) + brcmp1 = a0*esum(mu,z-u) + RETURN +C----------------------------------------------------------------------- +C PROCEDURE FOR A .GE. 8 AND B .GE. 8 +C----------------------------------------------------------------------- + 130 IF (a.GT.b) GO TO 140 + h = a/b + x0 = h/ (1.0D0+h) + y0 = 1.0D0/ (1.0D0+h) + lambda = a - (a+b)*x + GO TO 150 + + 140 h = b/a + x0 = 1.0D0/ (1.0D0+h) + y0 = h/ (1.0D0+h) + lambda = (a+b)*y - b +C + 150 e = -lambda/a + IF (abs(e).GT.0.6D0) GO TO 160 + u = rlog1(e) + GO TO 170 + + 160 u = e - dlog(x/x0) +C + 170 e = lambda/b + IF (abs(e).GT.0.6D0) GO TO 180 + v = rlog1(e) + GO TO 190 + + 180 v = e - dlog(y/y0) +C + 190 z = esum(mu,- (a*u+b*v)) + brcmp1 = const*sqrt(b*x0)*z*exp(-bcorr(a,b)) + RETURN + + END diff --git a/modules/statistics/src/dcdflib/brcmp1.lo b/modules/statistics/src/dcdflib/brcmp1.lo new file mode 100755 index 000000000..7577d6829 --- /dev/null +++ b/modules/statistics/src/dcdflib/brcmp1.lo @@ -0,0 +1,12 @@ +# src/dcdflib/brcmp1.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/brcmp1.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/statistics/src/dcdflib/brcomp.f b/modules/statistics/src/dcdflib/brcomp.f new file mode 100755 index 000000000..f54cfd145 --- /dev/null +++ b/modules/statistics/src/dcdflib/brcomp.f @@ -0,0 +1,137 @@ + DOUBLE PRECISION FUNCTION brcomp(a,b,x,y) +C----------------------------------------------------------------------- +C EVALUATION OF X**A*Y**B/BETA(A,B) +C----------------------------------------------------------------------- +C .. Scalar Arguments .. + DOUBLE PRECISION a,b,x,y +C .. +C .. Local Scalars .. + DOUBLE PRECISION a0,apb,b0,c,const,e,h,lambda,lnx,lny,t,u,v,x0,y0, + + z + INTEGER i,n +C .. +C .. External Functions .. + DOUBLE PRECISION algdiv,alnrel,bcorr,betaln,gam1,gamln1,rlog1 + EXTERNAL algdiv,alnrel,bcorr,betaln,gam1,gamln1,rlog1 +C .. +C .. Intrinsic Functions .. + INTRINSIC abs,dble,dlog,dmax1,dmin1,exp,sqrt +C .. +C .. Data statements .. +C----------------- +C CONST = 1/SQRT(2*PI) +C----------------- + DATA const/.398942280401433D0/ +C .. +C .. Executable Statements .. +C + brcomp = 0.0D0 + IF (x.EQ.0.0D0 .OR. y.EQ.0.0D0) RETURN + a0 = dmin1(a,b) + IF (a0.GE.8.0D0) GO TO 130 +C + IF (x.GT.0.375D0) GO TO 10 + lnx = dlog(x) + lny = alnrel(-x) + GO TO 30 + + 10 IF (y.GT.0.375D0) GO TO 20 + lnx = alnrel(-y) + lny = dlog(y) + GO TO 30 + + 20 lnx = dlog(x) + lny = dlog(y) +C + 30 z = a*lnx + b*lny + IF (a0.LT.1.0D0) GO TO 40 + z = z - betaln(a,b) + brcomp = exp(z) + RETURN +C----------------------------------------------------------------------- +C PROCEDURE FOR A .LT. 1 OR B .LT. 1 +C----------------------------------------------------------------------- + 40 b0 = dmax1(a,b) + IF (b0.GE.8.0D0) GO TO 120 + IF (b0.GT.1.0D0) GO TO 70 +C +C ALGORITHM FOR B0 .LE. 1 +C + brcomp = exp(z) + IF (brcomp.EQ.0.0D0) RETURN +C + apb = a + b + IF (apb.GT.1.0D0) GO TO 50 + z = 1.0D0 + gam1(apb) + GO TO 60 + + 50 u = dble(a) + dble(b) - 1.D0 + z = (1.0D0+gam1(u))/apb +C + 60 c = (1.0D0+gam1(a))* (1.0D0+gam1(b))/z + brcomp = brcomp* (a0*c)/ (1.0D0+a0/b0) + RETURN +C +C ALGORITHM FOR 1 .LT. B0 .LT. 8 +C + 70 u = gamln1(a0) + n = b0 - 1.0D0 + IF (n.LT.1) GO TO 90 + c = 1.0D0 + DO 80 i = 1,n + b0 = b0 - 1.0D0 + c = c* (b0/ (a0+b0)) + 80 CONTINUE + u = dlog(c) + u +C + 90 z = z - u + b0 = b0 - 1.0D0 + apb = a0 + b0 + IF (apb.GT.1.0D0) GO TO 100 + t = 1.0D0 + gam1(apb) + GO TO 110 + + 100 u = dble(a0) + dble(b0) - 1.D0 + t = (1.0D0+gam1(u))/apb + 110 brcomp = a0*exp(z)* (1.0D0+gam1(b0))/t + RETURN +C +C ALGORITHM FOR B0 .GE. 8 +C + 120 u = gamln1(a0) + algdiv(a0,b0) + brcomp = a0*exp(z-u) + RETURN +C----------------------------------------------------------------------- +C PROCEDURE FOR A .GE. 8 AND B .GE. 8 +C----------------------------------------------------------------------- + 130 IF (a.GT.b) GO TO 140 + h = a/b + x0 = h/ (1.0D0+h) + y0 = 1.0D0/ (1.0D0+h) + lambda = a - (a+b)*x + GO TO 150 + + 140 h = b/a + x0 = 1.0D0/ (1.0D0+h) + y0 = h/ (1.0D0+h) + lambda = (a+b)*y - b +C + 150 e = -lambda/a + IF (abs(e).GT.0.6D0) GO TO 160 + u = rlog1(e) + GO TO 170 + + 160 u = e - dlog(x/x0) +C + 170 e = lambda/b + IF (abs(e).GT.0.6D0) GO TO 180 + v = rlog1(e) + GO TO 190 + + 180 v = e - dlog(y/y0) +C + 190 z = exp(- (a*u+b*v)) + brcomp = const*sqrt(b*x0)*z*exp(-bcorr(a,b)) + RETURN + + END diff --git a/modules/statistics/src/dcdflib/brcomp.lo b/modules/statistics/src/dcdflib/brcomp.lo new file mode 100755 index 000000000..0bf7abec6 --- /dev/null +++ b/modules/statistics/src/dcdflib/brcomp.lo @@ -0,0 +1,12 @@ +# src/dcdflib/brcomp.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/brcomp.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/statistics/src/dcdflib/bup.f b/modules/statistics/src/dcdflib/bup.f new file mode 100755 index 000000000..2df254e84 --- /dev/null +++ b/modules/statistics/src/dcdflib/bup.f @@ -0,0 +1,81 @@ + DOUBLE PRECISION FUNCTION bup(a,b,x,y,n,eps) +C----------------------------------------------------------------------- +C EVALUATION OF IX(A,B) - IX(A+N,B) WHERE N IS A POSITIVE INTEGER. +C EPS IS THE TOLERANCE USED. +C----------------------------------------------------------------------- +C .. Scalar Arguments .. + DOUBLE PRECISION a,b,eps,x,y + INTEGER n +C .. +C .. Local Scalars .. + DOUBLE PRECISION ap1,apb,d,l,r,t,w + INTEGER i,k,kp1,mu,nm1 +C .. +C .. External Functions .. + DOUBLE PRECISION brcmp1,exparg + EXTERNAL brcmp1,exparg +C .. +C .. Intrinsic Functions .. + INTRINSIC abs,exp +C .. +C .. Executable Statements .. +C +C OBTAIN THE SCALING FACTOR EXP(-MU) AND +C EXP(MU)*(X**A*Y**B/BETA(A,B))/A +C + apb = a + b + ap1 = a + 1.0D0 + mu = 0 + d = 1.0D0 + IF (n.EQ.1 .OR. a.LT.1.0D0) GO TO 10 + IF (apb.LT.1.1D0*ap1) GO TO 10 + mu = abs(exparg(1)) + k = exparg(0) + IF (k.LT.mu) mu = k + t = mu + d = exp(-t) +C + 10 bup = brcmp1(mu,a,b,x,y)/a + IF (n.EQ.1 .OR. bup.EQ.0.0D0) RETURN + nm1 = n - 1 + w = d +C +C LET K BE THE INDEX OF THE MAXIMUM TERM +C + k = 0 + IF (b.LE.1.0D0) GO TO 50 + IF (y.GT.1.D-4) GO TO 20 + k = nm1 + GO TO 30 + + 20 r = (b-1.0D0)*x/y - a + IF (r.LT.1.0D0) GO TO 50 + k = nm1 + t = nm1 + IF (r.LT.t) k = r +C +C ADD THE INCREASING TERMS OF THE SERIES +C + 30 DO 40 i = 1,k + l = i - 1 + d = ((apb+l)/ (ap1+l))*x*d + w = w + d + 40 CONTINUE + IF (k.EQ.nm1) GO TO 70 +C +C ADD THE REMAINING TERMS OF THE SERIES +C + 50 kp1 = k + 1 + DO 60 i = kp1,nm1 + l = i - 1 + d = ((apb+l)/ (ap1+l))*x*d + w = w + d + IF (d.LE.eps*w) GO TO 70 + 60 CONTINUE +C +C TERMINATE THE PROCEDURE +C + 70 bup = bup*w + RETURN + + END diff --git a/modules/statistics/src/dcdflib/bup.lo b/modules/statistics/src/dcdflib/bup.lo new file mode 100755 index 000000000..a283d82e6 --- /dev/null +++ b/modules/statistics/src/dcdflib/bup.lo @@ -0,0 +1,12 @@ +# src/dcdflib/bup.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/bup.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/statistics/src/dcdflib/cdfbet.f b/modules/statistics/src/dcdflib/cdfbet.f new file mode 100755 index 000000000..99a5d5acc --- /dev/null +++ b/modules/statistics/src/dcdflib/cdfbet.f @@ -0,0 +1,410 @@ + SUBROUTINE cdfbet(which,p,q,x,y,a,b,status,bound) +C********************************************************************** +C +C SUBROUTINE CDFBET( WHICH, P, Q, X, Y, A, B, STATUS, BOUND ) +C Cumulative Distribution Function +C BETa Distribution +C +C +C Function +C +C +C Calculates any one parameter of the beta distribution given +C values for the others. +C +C +C Arguments +C +C +C WHICH --> Integer indicating which of the next four argument +C values is to be calculated from the others. +C Legal range: 1..4 +C iwhich = 1 : Calculate P and Q from X,Y,A and B +C iwhich = 2 : Calculate X and Y from P,Q,A and B +C iwhich = 3 : Calculate A from P,Q,X,Y and B +C iwhich = 4 : Calculate B from P,Q,X,Y and A +C +C INTEGER WHICH +C +C P <--> The integral from 0 to X of the chi-square +C distribution. +C Input range: [0, 1]. +C DOUBLE PRECISION P +C +C Q <--> 1-P. +C Input range: [0, 1]. +C P + Q = 1.0. +C DOUBLE PRECISION Q +C +C X <--> Upper limit of integration of beta density. +C Input range: [0,1]. +C Search range: [0,1] +C DOUBLE PRECISION X +C +C Y <--> 1-X. +C Input range: [0,1]. +C Search range: [0,1] +C X + Y = 1.0. +C DOUBLE PRECISION Y +C +C A <--> The first parameter of the beta density. +C Input range: (0, +infinity). +C Search range: [1D-300,1D300] +C DOUBLE PRECISION A +C +C B <--> The second parameter of the beta density. +C Input range: (0, +infinity). +C Search range: [1D-300,1D300] +C DOUBLE PRECISION B +C +C STATUS <-- 0 if calculation completed correctly +C -I if input parameter number I is out of range +C 1 if answer appears to be lower than lowest +C search bound +C 2 if answer appears to be higher than greatest +C search bound +C 3 if P + Q .ne. 1 +C 4 if X + Y .ne. 1 +C INTEGER STATUS +C +C BOUND <-- Undefined if STATUS is 0 +C +C Bound exceeded by parameter number I if STATUS +C is negative. +C +C Lower search bound if STATUS is 1. +C +C Upper search bound if STATUS is 2. +C +C +C Method +C +C +C Cumulative distribution function (P) is calculated directly by +C code associated with the following reference. +C +C DiDinato, A. R. and Morris, A. H. Algorithm 708: Significant +C Digit Computation of the Incomplete Beta Function Ratios. ACM +C Trans. Math. Softw. 18 (1993), 360-373. +C +C Computation of other parameters involve a search for a value that +C produces the desired value of P. The search relies on the +C monotonicity of P with the other parameter. +C +C +C Note +C +C +C The beta density is proportional to +C t^(A-1) * (1-t)^(B-1) +C +C********************************************************************** +C .. Parameters .. + DOUBLE PRECISION tol + PARAMETER (tol=1.0D-13) + DOUBLE PRECISION atol + PARAMETER (atol=1.0D-50) + DOUBLE PRECISION zero,inf + PARAMETER (zero=1.0D-300,inf=1.0D300) + DOUBLE PRECISION one + PARAMETER (one=1.0D0) +C .. +C .. Scalar Arguments .. + DOUBLE PRECISION a,b,bound,p,q,x,y + INTEGER status,which +C .. +C .. Local Scalars .. + DOUBLE PRECISION fx,xhi,xlo,cum,ccum,xy,pq + LOGICAL qhi,qleft,qporq +C .. +C .. External Functions .. + INTEGER vfinite + DOUBLE PRECISION spmpar + EXTERNAL spmpar +C .. +C .. External Subroutines .. + EXTERNAL cumbet,dinvr,dstinv,dstzr,dzror +C .. +C .. Executable Statements .. +C +C Check arguments +C + IF (.NOT. ((which.LT.1).OR. (which.GT.4))) GO TO 30 + IF (.NOT. (which.LT.1)) GO TO 10 + bound = 1.0D0 + GO TO 20 + + 10 bound = 4.0D0 + 20 status = -1 + RETURN + + 30 IF (which.EQ.1) GO TO 70 +C +C P +C + IF (ISANAN(p).EQ.1) THEN + CALL RETURNANANFORTRAN(a) + CALL RETURNANANFORTRAN(b) + CALL RETURNANANFORTRAN(x) + CALL RETURNANANFORTRAN(y) + RETURN + ENDIF + IF (.NOT. ((p.LT.0.0D0).OR. (p.GT.1.0D0))) GO TO 60 + IF (.NOT. (p.LT.0.0D0)) GO TO 40 + bound = 0.0D0 + GO TO 50 + + 40 bound = 1.0D0 + 50 status = -2 + RETURN + + 60 CONTINUE + 70 IF (which.EQ.1) GO TO 110 +C +C Q +C + IF (ISANAN(q).EQ.1) THEN + CALL RETURNANANFORTRAN(a) + CALL RETURNANANFORTRAN(b) + CALL RETURNANANFORTRAN(x) + CALL RETURNANANFORTRAN(y) + RETURN + ENDIF + IF (.NOT. ((q.LT.0.0D0).OR. (q.GT.1.0D0))) GO TO 100 + IF (.NOT. (q.LT.0.0D0)) GO TO 80 + bound = 0.0D0 + GO TO 90 + + 80 bound = 1.0D0 + 90 status = -3 + RETURN + + 100 CONTINUE + 110 IF (which.EQ.2) GO TO 150 +C +C X +C + IF (ISANAN(x).EQ.1) THEN + CALL RETURNANANFORTRAN(p) + CALL RETURNANANFORTRAN(q) + CALL RETURNANANFORTRAN(a) + CALL RETURNANANFORTRAN(b) + RETURN + ENDIF + IF (.NOT. ((x.LT.0.0D0).OR. (x.GT.1.0D0))) GO TO 140 + IF (.NOT. (x.LT.0.0D0)) GO TO 120 + bound = 0.0D0 + GO TO 130 + + 120 bound = 1.0D0 + 130 status = -4 + RETURN + + 140 CONTINUE + 150 IF (which.EQ.2) GO TO 190 +C +C Y +C + IF (ISANAN(y).EQ.1) THEN + CALL RETURNANANFORTRAN(p) + CALL RETURNANANFORTRAN(q) + CALL RETURNANANFORTRAN(a) + CALL RETURNANANFORTRAN(b) + RETURN + ENDIF + IF (.NOT. ((y.LT.0.0D0).OR. (y.GT.1.0D0))) GO TO 180 + IF (.NOT. (y.LT.0.0D0)) GO TO 160 + bound = 0.0D0 + GO TO 170 + + 160 bound = 1.0D0 + 170 status = -5 + RETURN + + 180 CONTINUE + 190 IF (which.EQ.3) GO TO 210 +C +C A +C + IF (ISANAN(a).EQ.1) THEN + CALL RETURNANANFORTRAN(p) + CALL RETURNANANFORTRAN(q) + CALL RETURNANANFORTRAN(x) + CALL RETURNANANFORTRAN(y) + CALL RETURNANANFORTRAN(b) + RETURN + ENDIF + IF (vfinite(1,a).EQ.0) a = SIGN(inf,a) + IF (.NOT. (a.LE.0.0D0)) GO TO 200 + bound = 0.0D0 + status = -6 + RETURN + + 200 CONTINUE + 210 IF (which.EQ.4) GO TO 230 +C +C B +C + IF (ISANAN(b).EQ.1) THEN + CALL RETURNANANFORTRAN(p) + CALL RETURNANANFORTRAN(q) + CALL RETURNANANFORTRAN(x) + CALL RETURNANANFORTRAN(y) + CALL RETURNANANFORTRAN(a) + RETURN + ENDIF + IF (vfinite(1,b).EQ.0) b = SIGN(inf,b) + IF (.NOT. (b.LE.0.0D0)) GO TO 220 + bound = 0.0D0 + status = -7 + RETURN + + 220 CONTINUE + 230 IF (which.EQ.1) GO TO 270 +C +C P + Q +C + pq = p + q + IF (.NOT. (abs(((pq)-0.5D0)-0.5D0).GT. + + (3.0D0*spmpar(1)))) GO TO 260 + IF (.NOT. (pq.LT.0.0D0)) GO TO 240 + bound = 0.0D0 + GO TO 250 + + 240 bound = 1.0D0 + 250 status = 3 + RETURN + + 260 CONTINUE + 270 IF (which.EQ.2) GO TO 310 +C +C X + Y +C + xy = x + y + IF (.NOT. (abs(((xy)-0.5D0)-0.5D0).GT. + + (3.0D0*spmpar(1)))) GO TO 300 + IF (.NOT. (xy.LT.0.0D0)) GO TO 280 + bound = 0.0D0 + GO TO 290 + + 280 bound = 1.0D0 + 290 status = 4 + RETURN + + 300 CONTINUE + 310 IF (.NOT. (which.EQ.1)) qporq = p .LE. q +C +C Select the minimum of P or Q +C +C +C Calculate ANSWERS +C + IF ((1).EQ. (which)) THEN +C +C Calculating P and Q +C + CALL cumbet(x,y,a,b,p,q) + status = 0 + + ELSE IF ((2).EQ. (which)) THEN +C +C Calculating X and Y +C + CALL dstzr(0.0D0,1.0D0,atol,tol) + IF (.NOT. (qporq)) GO TO 340 + status = 0 + CALL dzror(status,x,fx,xlo,xhi,qleft,qhi) + y = one - x + 320 IF (.NOT. (status.EQ.1)) GO TO 330 + CALL cumbet(x,y,a,b,cum,ccum) + fx = cum - p + CALL dzror(status,x,fx,xlo,xhi,qleft,qhi) + y = one - x +c write(6,'(''x'',e10.3,''y='',e10.3,''sta='',i3)') x,y,status + GO TO 320 + + 330 GO TO 370 + + 340 status = 0 + CALL dzror(status,y,fx,xlo,xhi,qleft,qhi) + x = one - y + 350 IF (.NOT. (status.EQ.1)) GO TO 360 + CALL cumbet(x,y,a,b,cum,ccum) + fx = ccum - q + CALL dzror(status,y,fx,xlo,xhi,qleft,qhi) + x = one - y + GO TO 350 + + 360 CONTINUE + 370 IF (.NOT. (status.EQ.-1)) GO TO 400 + IF (.NOT. (qleft)) GO TO 380 + status = 1 + bound = 0.0D0 + GO TO 390 + + 380 status = 2 + bound = 1.0D0 + 390 CONTINUE + 400 CONTINUE + + ELSE IF ((3).EQ. (which)) THEN +C +C Computing A +C + a = 5.0D0 + CALL dstinv(zero,inf,0.5D0,0.5D0,5.0D0,atol,tol) + status = 0 + CALL dinvr(status,a,fx,qleft,qhi) + 410 IF (.NOT. (status.EQ.1)) GO TO 440 + CALL cumbet(x,y,a,b,cum,ccum) + IF (.NOT. (qporq)) GO TO 420 + fx = cum - p + GO TO 430 + + 420 fx = ccum - q + 430 CALL dinvr(status,a,fx,qleft,qhi) + GO TO 410 + + 440 IF (.NOT. (status.EQ.-1)) GO TO 470 + IF (.NOT. (qleft)) GO TO 450 + status = 1 + bound = zero + GO TO 460 + + 450 status = 2 + bound = inf + 460 CONTINUE + 470 CONTINUE + + ELSE IF ((4).EQ. (which)) THEN +C +C Computing B +C + b = 5.0D0 + CALL dstinv(zero,inf,0.5D0,0.5D0,5.0D0,atol,tol) + status = 0 + CALL dinvr(status,b,fx,qleft,qhi) + 480 IF (.NOT. (status.EQ.1)) GO TO 510 + CALL cumbet(x,y,a,b,cum,ccum) + IF (.NOT. (qporq)) GO TO 490 + fx = cum - p + GO TO 500 + + 490 fx = ccum - q + 500 CALL dinvr(status,b,fx,qleft,qhi) + GO TO 480 + + 510 IF (.NOT. (status.EQ.-1)) GO TO 540 + IF (.NOT. (qleft)) GO TO 520 + status = 1 + bound = zero + GO TO 530 + + 520 status = 2 + bound = inf + 530 CONTINUE + 540 END IF + + RETURN +C + END diff --git a/modules/statistics/src/dcdflib/cdfbet.lo b/modules/statistics/src/dcdflib/cdfbet.lo new file mode 100755 index 000000000..e8398f633 --- /dev/null +++ b/modules/statistics/src/dcdflib/cdfbet.lo @@ -0,0 +1,12 @@ +# src/dcdflib/cdfbet.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/cdfbet.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/statistics/src/dcdflib/cdfbin.f b/modules/statistics/src/dcdflib/cdfbin.f new file mode 100755 index 000000000..a2fa5b245 --- /dev/null +++ b/modules/statistics/src/dcdflib/cdfbin.f @@ -0,0 +1,405 @@ + SUBROUTINE cdfbin(which,p,q,s,xn,pr,ompr,status,bound) +C********************************************************************** +C +C SUBROUTINE CDFBIN ( WHICH, P, Q, S, XN, PR, OMPR, STATUS, BOUND ) +C Cumulative Distribution Function +C BINomial distribution +C +C +C Function +C +C +C Calculates any one parameter of the binomial +C distribution given values for the others. +C +C +C Arguments +C +C +C WHICH --> Integer indicating which of the next four argument +C values is to be calculated from the others. +C Legal range: 1..4 +C iwhich = 1 : Calculate P and Q from S,XN,PR and OMPR +C iwhich = 2 : Calculate S from P,Q,XN,PR and OMPR +C iwhich = 3 : Calculate XN from P,Q,S,PR and OMPR +C iwhich = 4 : Calculate PR and OMPR from P,Q,S and XN +C INTEGER WHICH +C +C P <--> The cumulation from 0 to S of the binomial distribution. +C (Probablility of S or fewer successes in XN trials each +C with probability of success PR.) +C Input range: [0,1]. +C DOUBLE PRECISION P +C +C Q <--> 1-P. +C Input range: [0, 1]. +C P + Q = 1.0. +C DOUBLE PRECISION Q +C +C S <--> The number of successes observed. +C Input range: [0, XN] +C Search range: [0, XN] +C DOUBLE PRECISION S +C +C XN <--> The number of binomial trials. +C Input range: (0, +infinity). +C Search range: [1E-300, 1E300] +C DOUBLE PRECISION XN +C +C PR <--> The probability of success in each binomial trial. +C Input range: [0,1]. +C Search range: [0,1] +C DOUBLE PRECISION PR +C +C OMPR <--> 1-PR +C Input range: [0,1]. +C Search range: [0,1] +C PR + OMPR = 1.0 +C DOUBLE PRECISION OMPR +C +C STATUS <-- 0 if calculation completed correctly +C -I if input parameter number I is out of range +C 1 if answer appears to be lower than lowest +C search bound +C 2 if answer appears to be higher than greatest +C search bound +C 3 if P + Q .ne. 1 +C 4 if PR + OMPR .ne. 1 +C INTEGER STATUS +C +C BOUND <-- Undefined if STATUS is 0 +C +C Bound exceeded by parameter number I if STATUS +C is negative. +C +C Lower search bound if STATUS is 1. +C +C Upper search bound if STATUS is 2. +C +C +C Method +C +C +C Formula 26.5.24 of Abramowitz and Stegun, Handbook of +C Mathematical Functions (1966) is used to reduce the binomial +C distribution to the cumulative incomplete beta distribution. +C +C Computation of other parameters involve a search for a value that +C produces the desired value of P. The search relies on the +C monotonicity of P with the other parameter. +C +C +C********************************************************************** + +C .. Parameters .. + DOUBLE PRECISION atol + PARAMETER (atol=1.0D-50) + DOUBLE PRECISION tol + PARAMETER (tol=1.0D-13) + DOUBLE PRECISION zero,inf + PARAMETER (zero=1.0D-300,inf=1.0D300) + DOUBLE PRECISION one + PARAMETER (one=1.0D0) +C .. +C .. Scalar Arguments .. + DOUBLE PRECISION bound,p,q,pr,ompr,s,xn + INTEGER status,which +C .. +C .. Local Scalars .. + DOUBLE PRECISION fx,xhi,xlo,cum,ccum,pq,prompr + LOGICAL qhi,qleft,qporq +C .. +C .. External Functions .. + INTEGER vfinite + DOUBLE PRECISION spmpar + EXTERNAL spmpar +C .. +C .. External Subroutines .. + EXTERNAL dinvr,dstinv,dstzr,dzror,cumbin +C .. +C .. Executable Statements .. +C +C Check arguments + IF ((which.GE.1).AND. (which.LE.4)) GO TO 30 + IF (.NOT. (which.LT.1)) GO TO 10 + bound = 1.0D0 + GO TO 20 + + 10 bound = 4.0D0 + 20 status = -1 + RETURN + + 30 IF (which.EQ.1) GO TO 70 +C +C P +C + IF (ISANAN(p).EQ.1) THEN + CALL RETURNANANFORTRAN(pr) + CALL RETURNANANFORTRAN(ompr) + CALL RETURNANANFORTRAN(s) + CALL RETURNANANFORTRAN(xn) + RETURN + ENDIF + IF (.NOT. ((p.LT.0.0D0).OR. (p.GT.1.0D0))) GO TO 60 + IF (.NOT. (p.LT.0.0D0)) GO TO 40 + bound = 0.0D0 + GO TO 50 + + 40 bound = 1.0D0 + 50 status = -2 + RETURN + + 60 CONTINUE + 70 IF (which.EQ.1) GO TO 110 +C +C Q +C + IF (ISANAN(q).EQ.1) THEN + CALL RETURNANANFORTRAN(pr) + CALL RETURNANANFORTRAN(ompr) + CALL RETURNANANFORTRAN(s) + CALL RETURNANANFORTRAN(xn) + RETURN + ENDIF + IF (.NOT. ((q.LT.0.0D0).OR. (q.GT.1.0D0))) GO TO 100 + IF (.NOT. (q.LT.0.0D0)) GO TO 80 + bound = 0.0D0 + GO TO 90 + + 80 bound = 1.0D0 + 90 status = -3 + RETURN + + 100 CONTINUE + 110 IF (which.EQ.3) GO TO 130 +C +C XN +C + IF (ISANAN(xn).EQ.1) THEN + CALL RETURNANANFORTRAN(p) + CALL RETURNANANFORTRAN(q) + CALL RETURNANANFORTRAN(s) + CALL RETURNANANFORTRAN(pr) + CALL RETURNANANFORTRAN(ompr) + RETURN + ENDIF + IF (vfinite(1,xn).EQ.0) xn = SIGN(inf,xn) + IF (.NOT. (xn.LE.0.0D0)) GO TO 120 + bound = 0.0D0 + status = -5 + RETURN + + 120 CONTINUE + 130 IF (which.EQ.2) GO TO 170 +C +C S +C + IF (ISANAN(s).EQ.1) THEN + CALL RETURNANANFORTRAN(p) + CALL RETURNANANFORTRAN(q) + CALL RETURNANANFORTRAN(xn) + CALL RETURNANANFORTRAN(pr) + CALL RETURNANANFORTRAN(ompr) + RETURN + ENDIF + IF (vfinite(1,s).EQ.0) s = SIGN(inf,s) + IF (.NOT. ((s.LT.0.0D0).OR. ((which.NE.3).AND. + + (s.GT.xn)))) GO TO 160 + IF (.NOT. (s.LT.0.0D0)) GO TO 140 + bound = 0.0D0 + GO TO 150 + + 140 bound = xn + 150 status = -4 + RETURN + + 160 CONTINUE + 170 IF (which.EQ.4) GO TO 210 +C +C PR +C + IF (ISANAN(pr).EQ.1) THEN + CALL RETURNANANFORTRAN(p) + CALL RETURNANANFORTRAN(q) + CALL RETURNANANFORTRAN(s) + CALL RETURNANANFORTRAN(xn) + RETURN + ENDIF + IF (.NOT. ((pr.LT.0.0D0).OR. (pr.GT.1.0D0))) GO TO 200 + IF (.NOT. (pr.LT.0.0D0)) GO TO 180 + bound = 0.0D0 + GO TO 190 + + 180 bound = 1.0D0 + 190 status = -6 + RETURN + + 200 CONTINUE + 210 IF (which.EQ.4) GO TO 250 +C +C OMPR +C + IF (ISANAN(ompr).EQ.1) THEN + CALL RETURNANANFORTRAN(p) + CALL RETURNANANFORTRAN(q) + CALL RETURNANANFORTRAN(s) + CALL RETURNANANFORTRAN(xn) + RETURN + ENDIF + IF (.NOT. ((ompr.LT.0.0D0).OR. (ompr.GT.1.0D0))) GO TO 240 + IF (.NOT. (ompr.LT.0.0D0)) GO TO 220 + bound = 0.0D0 + GO TO 230 + + 220 bound = 1.0D0 + 230 status = -7 + RETURN + + 240 CONTINUE + 250 IF (which.EQ.1) GO TO 290 +C +C P + Q +C + pq = p + q + IF (.NOT. (abs(((pq)-0.5D0)-0.5D0).GT. + + (3.0D0*spmpar(1)))) GO TO 280 + IF (.NOT. (pq.LT.0.0D0)) GO TO 260 + bound = 0.0D0 + GO TO 270 + + 260 bound = 1.0D0 + 270 status = 3 + RETURN + + 280 CONTINUE + 290 IF (which.EQ.4) GO TO 330 +C +C PR + OMPR +C + prompr = pr + ompr + IF (.NOT. (abs(((prompr)-0.5D0)-0.5D0).GT. + + (3.0D0*spmpar(1)))) GO TO 320 + IF (.NOT. (prompr.LT.0.0D0)) GO TO 300 + bound = 0.0D0 + GO TO 310 + + 300 bound = 1.0D0 + 310 status = 4 + RETURN + + 320 CONTINUE + 330 IF (.NOT. (which.EQ.1)) qporq = p .LE. q +C +C Select the minimum of P or Q +C +C +C Calculate ANSWERS +C + IF ((1).EQ. (which)) THEN +C +C Calculating P +C + CALL cumbin(s,xn,pr,ompr,p,q) + status = 0 + + ELSE IF ((2).EQ. (which)) THEN +C +C Calculating S +C + s = 5.0D0 + CALL dstinv(0.0D0,xn,0.5D0,0.5D0,5.0D0,atol,tol) + status = 0 + CALL dinvr(status,s,fx,qleft,qhi) + 340 IF (.NOT. (status.EQ.1)) GO TO 370 + CALL cumbin(s,xn,pr,ompr,cum,ccum) + IF (.NOT. (qporq)) GO TO 350 + fx = cum - p + GO TO 360 + + 350 fx = ccum - q + 360 CALL dinvr(status,s,fx,qleft,qhi) + GO TO 340 + + 370 IF (.NOT. (status.EQ.-1)) GO TO 400 + IF (.NOT. (qleft)) GO TO 380 + status = 1 + bound = 0.0D0 + GO TO 390 + + 380 status = 2 + bound = xn + 390 CONTINUE + 400 CONTINUE + + ELSE IF ((3).EQ. (which)) THEN +C +C Calculating XN +C + xn = 5.0D0 + CALL dstinv(zero,inf,0.5D0,0.5D0,5.0D0,atol,tol) + status = 0 + CALL dinvr(status,xn,fx,qleft,qhi) + 410 IF (.NOT. (status.EQ.1)) GO TO 440 + CALL cumbin(s,xn,pr,ompr,cum,ccum) + IF (.NOT. (qporq)) GO TO 420 + fx = cum - p + GO TO 430 + + 420 fx = ccum - q + 430 CALL dinvr(status,xn,fx,qleft,qhi) + GO TO 410 + + 440 IF (.NOT. (status.EQ.-1)) GO TO 470 + IF (.NOT. (qleft)) GO TO 450 + status = 1 + bound = zero + GO TO 460 + + 450 status = 2 + bound = inf + 460 CONTINUE + 470 CONTINUE + + ELSE IF ((4).EQ. (which)) THEN +C +C Calculating PR and OMPR +C + CALL dstzr(0.0D0,1.0D0,atol,tol) + IF (.NOT. (qporq)) GO TO 500 + status = 0 + CALL dzror(status,pr,fx,xlo,xhi,qleft,qhi) + ompr = one - pr + 480 IF (.NOT. (status.EQ.1)) GO TO 490 + CALL cumbin(s,xn,pr,ompr,cum,ccum) + fx = cum - p + CALL dzror(status,pr,fx,xlo,xhi,qleft,qhi) + ompr = one - pr + GO TO 480 + + 490 GO TO 530 + + 500 status = 0 + CALL dzror(status,ompr,fx,xlo,xhi,qleft,qhi) + pr = one - ompr + 510 IF (.NOT. (status.EQ.1)) GO TO 520 + CALL cumbin(s,xn,pr,ompr,cum,ccum) + fx = ccum - q + CALL dzror(status,ompr,fx,xlo,xhi,qleft,qhi) + pr = one - ompr + GO TO 510 + + 520 CONTINUE + 530 IF (.NOT. (status.EQ.-1)) GO TO 560 + IF (.NOT. (qleft)) GO TO 540 + status = 1 + bound = 0.0D0 + GO TO 550 + + 540 status = 2 + bound = 1.0D0 + 550 CONTINUE + 560 END IF + + RETURN + + END diff --git a/modules/statistics/src/dcdflib/cdfbin.lo b/modules/statistics/src/dcdflib/cdfbin.lo new file mode 100755 index 000000000..fec6612e9 --- /dev/null +++ b/modules/statistics/src/dcdflib/cdfbin.lo @@ -0,0 +1,12 @@ +# src/dcdflib/cdfbin.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/cdfbin.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/statistics/src/dcdflib/cdfchi.f b/modules/statistics/src/dcdflib/cdfchi.f new file mode 100755 index 000000000..322951a5a --- /dev/null +++ b/modules/statistics/src/dcdflib/cdfchi.f @@ -0,0 +1,311 @@ + SUBROUTINE cdfchi(which,p,q,x,df,status,bound) +C********************************************************************** +C +C SUBROUTINE CDFCHI( WHICH, P, Q, X, DF, STATUS, BOUND ) +C Cumulative Distribution Function +C CHI-Square distribution +C +C +C Function +C +C +C Calculates any one parameter of the chi-square +C distribution given values for the others. +C +C +C Arguments +C +C +C WHICH --> Integer indicating which of the next three argument +C values is to be calculated from the others. +C Legal range: 1..3 +C iwhich = 1 : Calculate P and Q from X and DF +C iwhich = 2 : Calculate X from P,Q and DF +C iwhich = 3 : Calculate DF from P,Q and X +C INTEGER WHICH +C +C P <--> The integral from 0 to X of the chi-square +C distribution. +C Input range: [0, 1]. +C DOUBLE PRECISION P +C +C Q <--> 1-P. +C Input range: (0, 1]. +C P + Q = 1.0. +C DOUBLE PRECISION Q +C +C X <--> Upper limit of integration of the non-central +C chi-square distribution. +C Input range: [0, +infinity). +C Search range: [0,1E300] +C DOUBLE PRECISION X +C +C DF <--> Degrees of freedom of the +C chi-square distribution. +C Input range: (0, +infinity). +C Search range: [ 1E-300, 1E300] +C DOUBLE PRECISION DF +C +C STATUS <-- 0 if calculation completed correctly +C -I if input parameter number I is out of range +C 1 if answer appears to be lower than lowest +C search bound +C 2 if answer appears to be higher than greatest +C search bound +C 3 if P + Q .ne. 1 +C 10 indicates error returned from cumgam. See +C references in cdfgam +C INTEGER STATUS +C +C BOUND <-- Undefined if STATUS is 0 +C +C Bound exceeded by parameter number I if STATUS +C is negative. +C +C Lower search bound if STATUS is 1. +C +C Upper search bound if STATUS is 2. +C +C +C Method +C +C +C Formula 26.4.19 of Abramowitz and Stegun, Handbook of +C Mathematical Functions (1966) is used to reduce the chisqure +C distribution to the incomplete distribution. +C +C Computation of other parameters involve a search for a value that +C produces the desired value of P. The search relies on the +C monotonicity of P with the other parameter. +C +C********************************************************************** +C .. Parameters .. + DOUBLE PRECISION tol + PARAMETER (tol=1.0D-13) + DOUBLE PRECISION atol + PARAMETER (atol=1.0D-50) + DOUBLE PRECISION zero,inf + PARAMETER (zero=1.0D-300,inf=1.0D300) +C .. +C .. Scalar Arguments .. + DOUBLE PRECISION bound,df,p,q,x + INTEGER status,which +C .. +C .. Local Scalars .. + DOUBLE PRECISION fx,cum,ccum,pq,porq + LOGICAL qhi,qleft,qporq +C .. +C .. External Functions .. + INTEGER vfinite + DOUBLE PRECISION spmpar + EXTERNAL spmpar +C .. +C .. External Subroutines .. + EXTERNAL dinvr,dstinv,cumchi +C .. +C .. Executable Statements .. +C +C Check arguments +C + IF (.NOT. ((which.LT.1).OR. (which.GT.3))) GO TO 30 + IF (.NOT. (which.LT.1)) GO TO 10 + bound = 1.0D0 + GO TO 20 + + 10 bound = 3.0D0 + 20 status = -1 + RETURN + + 30 IF (which.EQ.1) GO TO 70 +C +C P +C + IF (ISANAN(p).EQ.1) THEN + CALL RETURNANANFORTRAN(df) + CALL RETURNANANFORTRAN(x) + RETURN + ENDIF + IF (.NOT. ((p.LT.0.0D0).OR. (p.GT.1.0D0))) GO TO 60 + IF (.NOT. (p.LT.0.0D0)) GO TO 40 + bound = 0.0D0 + GO TO 50 + + 40 bound = 1.0D0 + 50 status = -2 + RETURN + + 60 CONTINUE + 70 IF (which.EQ.1) GO TO 110 +C +C Q +C + IF (ISANAN(q).EQ.1) THEN + CALL RETURNANANFORTRAN(df) + CALL RETURNANANFORTRAN(x) + RETURN + ENDIF + IF (.NOT. ((q.LE.0.0D0).OR. (q.GT.1.0D0))) GO TO 100 + IF (.NOT. (q.LE.0.0D0)) GO TO 80 + bound = 0.0D0 + GO TO 90 + + 80 bound = 1.0D0 + 90 status = -3 + RETURN + + 100 CONTINUE + 110 IF (which.EQ.2) GO TO 130 +C +C X +C + IF (ISANAN(x).EQ.1) THEN + CALL RETURNANANFORTRAN(p) + CALL RETURNANANFORTRAN(q) + CALL RETURNANANFORTRAN(df) + RETURN + ENDIF + IF (vfinite(1,x).EQ.0) then + IF (which.EQ.1) then + IF (x.GT.0) then + p = 1 + q = 0 + RETURN + ENDIF + ELSE + x = SIGN(1D300,x) + ENDIF + ENDIF + IF (.NOT. (x.LT.0.0D0)) GO TO 120 + bound = 0.0D0 + status = -4 + RETURN + + 120 CONTINUE + 130 IF (which.EQ.3) GO TO 150 +C +C DF +C + IF (ISANAN(df).EQ.1) THEN + CALL RETURNANANFORTRAN(p) + CALL RETURNANANFORTRAN(q) + CALL RETURNANANFORTRAN(x) + RETURN + ENDIF + IF (vfinite(1,df).EQ.0) df = SIGN(inf,df) + IF (.NOT. (df.LE.0.0D0)) GO TO 140 + bound = 0.0D0 + status = -5 + RETURN + + 140 CONTINUE + 150 IF (which.EQ.1) GO TO 190 +C +C P + Q +C + pq = p + q + IF (.NOT. (abs(((pq)-0.5D0)-0.5D0).GT. + + (3.0D0*spmpar(1)))) GO TO 180 + IF (.NOT. (pq.LT.0.0D0)) GO TO 160 + bound = 0.0D0 + GO TO 170 + + 160 bound = 1.0D0 + 170 status = 3 + RETURN + + 180 CONTINUE + 190 IF (which.EQ.1) GO TO 220 +C +C Select the minimum of P or Q +C + qporq = p .LE. q + IF (.NOT. (qporq)) GO TO 200 + porq = p + GO TO 210 + + 200 porq = q + 210 CONTINUE +C +C Calculate ANSWERS +C + 220 IF ((1).EQ. (which)) THEN +C +C Calculating P and Q +C + status = 0 + CALL cumchi(x,df,p,q) +C jpc 2000 : porq must be computed ? +C ---> IF (porq.GT.1.5D0) THEN + IF (p .GT. 1.5d0 .or. q .GT. 1.5d0) then + status = 10 + RETURN + END IF + ELSE IF ((2).EQ. (which)) THEN +C +C Calculating X +C + x = 5.0D0 + CALL dstinv(0.0D0,inf,0.5D0,0.5D0,5.0D0,atol,tol) + status = 0 + CALL dinvr(status,x,fx,qleft,qhi) + 230 IF (.NOT. (status.EQ.1)) GO TO 270 + CALL cumchi(x,df,cum,ccum) + IF (.NOT. (qporq)) GO TO 240 + fx = cum - p + GO TO 250 + + 240 fx = ccum - q + 250 IF (.NOT. ((fx+porq).GT.1.5D0)) GO TO 260 + status = 10 + RETURN + + 260 CALL dinvr(status,x,fx,qleft,qhi) + GO TO 230 + + 270 IF (.NOT. (status.EQ.-1)) GO TO 300 + IF (.NOT. (qleft)) GO TO 280 + status = 1 + bound = 0.0D0 + GO TO 290 + + 280 status = 2 + bound = inf + 290 CONTINUE + 300 CONTINUE + + ELSE IF ((3).EQ. (which)) THEN +C +C Calculating DF +C + df = 5.0D0 + CALL dstinv(zero,inf,0.5D0,0.5D0,5.0D0,atol,tol) + status = 0 + CALL dinvr(status,df,fx,qleft,qhi) + 310 IF (.NOT. (status.EQ.1)) GO TO 350 + CALL cumchi(x,df,cum,ccum) + IF (.NOT. (qporq)) GO TO 320 + fx = cum - p + GO TO 330 + + 320 fx = ccum - q + 330 IF (.NOT. ((fx+porq).GT.1.5D0)) GO TO 340 + status = 10 + RETURN + + 340 CALL dinvr(status,df,fx,qleft,qhi) + GO TO 310 + + 350 IF (.NOT. (status.EQ.-1)) GO TO 380 + IF (.NOT. (qleft)) GO TO 360 + status = 1 + bound = zero + GO TO 370 + + 360 status = 2 + bound = inf + 370 CONTINUE + 380 END IF + + RETURN + + END diff --git a/modules/statistics/src/dcdflib/cdfchi.lo b/modules/statistics/src/dcdflib/cdfchi.lo new file mode 100755 index 000000000..f6981e876 --- /dev/null +++ b/modules/statistics/src/dcdflib/cdfchi.lo @@ -0,0 +1,12 @@ +# src/dcdflib/cdfchi.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/cdfchi.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/statistics/src/dcdflib/cdfchn.f b/modules/statistics/src/dcdflib/cdfchn.f new file mode 100755 index 000000000..fdeca415b --- /dev/null +++ b/modules/statistics/src/dcdflib/cdfchn.f @@ -0,0 +1,302 @@ + SUBROUTINE cdfchn(which,p,q,x,df,pnonc,status,bound) +C********************************************************************** +C +C SUBROUTINE CDFCHN( WHICH, P, Q, X, DF, PNONC, STATUS, BOUND ) +C Cumulative Distribution Function +C Non-central Chi-Square +C +C +C Function +C +C +C Calculates any one parameter of the non-central chi-square +C distribution given values for the others. +C +C +C Arguments +C +C +C WHICH --> Integer indicating which of the next three argument +C values is to be calculated from the others. +C Input range: 1..4 +C iwhich = 1 : Calculate P and Q from X and DF +C iwhich = 2 : Calculate X from P,DF and PNONC +C iwhich = 3 : Calculate DF from P,X and PNONC +C iwhich = 3 : Calculate PNONC from P,X and DF +C INTEGER WHICH +C +C P <--> The integral from 0 to X of the non-central chi-square +C distribution. +C Input range: [0, 1-1E-16). +C DOUBLE PRECISION P +C +C Q <--> 1-P. +C Q is not used by this subroutine and is only included +C for similarity with other cdf* routines. +C DOUBLE PRECISION Q +C +C X <--> Upper limit of integration of the non-central +C chi-square distribution. +C Input range: [0, +infinity). +C Search range: [0,1E300] +C DOUBLE PRECISION X +C +C DF <--> Degrees of freedom of the non-central +C chi-square distribution. +C Input range: (0, +infinity). +C Search range: [ 1E-300, 1E300] +C DOUBLE PRECISION DF +C +C PNONC <--> Non-centrality parameter of the non-central +C chi-square distribution. +C Input range: [0, +infinity). +C Search range: [0,1E4] +C DOUBLE PRECISION PNONC +C +C STATUS <-- 0 if calculation completed correctly +C -I if input parameter number I is out of range +C 1 if answer appears to be lower than lowest +C search bound +C 2 if answer appears to be higher than greatest +C search bound +C INTEGER STATUS +C +C BOUND <-- Undefined if STATUS is 0 +C +C Bound exceeded by parameter number I if STATUS +C is negative. +C +C Lower search bound if STATUS is 1. +C +C Upper search bound if STATUS is 2. +C +C +C Method +C +C +C Formula 26.4.25 of Abramowitz and Stegun, Handbook of +C Mathematical Functions (1966) is used to compute the cumulative +C distribution function. +C +C Computation of other parameters involve a search for a value that +C produces the desired value of P. The search relies on the +C monotonicity of P with the other parameter. +C +C +C WARNING +C +C The computation time required for this routine is proportional +C to the noncentrality parameter (PNONC). Very large values of +C this parameter can consume immense computer resources. This is +C why the search range is bounded by 10,000. +C +C********************************************************************** +C .. Parameters .. + DOUBLE PRECISION tent4 + PARAMETER (tent4=1.0D4) + DOUBLE PRECISION tol + PARAMETER (tol=1.0D-13) + DOUBLE PRECISION atol + PARAMETER (atol=1.0D-50) + DOUBLE PRECISION zero,one,inf + PARAMETER (zero=1.0D-300,one=1.0D0-1.0D-16,inf=1.0D300) +C .. +C .. Scalar Arguments .. + DOUBLE PRECISION bound,df,p,q,pnonc,x + INTEGER status,which +C .. +C .. Local Scalars .. + DOUBLE PRECISION fx,cum,ccum + LOGICAL qhi,qleft +C .. +C .. External Functions .. + INTEGER vfinite +C .. +C .. External Subroutines .. + EXTERNAL dinvr,dstinv,cumchn +C .. +C .. Executable Statements .. +C +C Check arguments +C + IF (.NOT. ((which.LT.1).OR. (which.GT.4))) GO TO 30 + IF (.NOT. (which.LT.1)) GO TO 10 + bound = 1.0D0 + GO TO 20 + + 10 bound = 4.0D0 + 20 status = -1 + RETURN + + 30 IF (which.EQ.1) GO TO 70 +C +C P +C + IF (ISANAN(p).EQ.1) THEN + CALL RETURNANANFORTRAN(df) + CALL RETURNANANFORTRAN(pnonc) + CALL RETURNANANFORTRAN(x) + RETURN + ENDIF + IF (.NOT. ((p.LT.0.0D0).OR. (p.GT.one))) GO TO 60 + IF (.NOT. (p.LT.0.0D0)) GO TO 40 + bound = 0.0D0 + GO TO 50 + + 40 bound = one + 50 status = -2 + RETURN + + 60 CONTINUE + 70 IF (which.EQ.2) GO TO 90 +C +C X +C + IF (ISANAN(x).EQ.1) THEN + CALL RETURNANANFORTRAN(p) + CALL RETURNANANFORTRAN(q) + CALL RETURNANANFORTRAN(df) + CALL RETURNANANFORTRAN(pnonc) + RETURN + ENDIF + IF (vfinite(1,x).EQ.0) then + IF (which.EQ.1) then + IF (x.GT.0) then + p = 1 + q = 0 + RETURN + ENDIF + ELSE + x = SIGN(1D300,x) + ENDIF + ENDIF + IF (.NOT. (x.LT.0.0D0)) GO TO 80 + bound = 0.0D0 + status = -4 + RETURN + + 80 CONTINUE + 90 IF (which.EQ.3) GO TO 110 +C +C DF +C + IF (ISANAN(df).EQ.1) THEN + CALL RETURNANANFORTRAN(p) + CALL RETURNANANFORTRAN(q) + CALL RETURNANANFORTRAN(x) + CALL RETURNANANFORTRAN(pnonc) + RETURN + ENDIF + IF (vfinite(1,df).EQ.0) df = SIGN(inf,df) + IF (.NOT. (df.LE.0.0D0)) GO TO 100 + bound = 0.0D0 + status = -5 + RETURN + + 100 CONTINUE + 110 IF (which.EQ.4) GO TO 130 +C +C PNONC +C + IF (ISANAN(pnonc).EQ.1) THEN + CALL RETURNANANFORTRAN(p) + CALL RETURNANANFORTRAN(q) + CALL RETURNANANFORTRAN(x) + CALL RETURNANANFORTRAN(df) + RETURN + ENDIF + IF (vfinite(1,pnonc).EQ.0) pnonc = SIGN(inf,pnonc) + IF (.NOT. (pnonc.LT.0.0D0)) GO TO 120 + bound = 0.0D0 + status = -6 + RETURN + + 120 CONTINUE +C +C Calculate ANSWERS +C + 130 IF ((1).EQ. (which)) THEN +C +C Calculating P and Q +C + CALL cumchn(x,df,pnonc,p,q) + status = 0 + + ELSE IF ((2).EQ. (which)) THEN +C +C Calculating X +C + x = 5.0D0 + CALL dstinv(0.0D0,inf,0.5D0,0.5D0,5.0D0,atol,tol) + status = 0 + CALL dinvr(status,x,fx,qleft,qhi) + 140 IF (.NOT. (status.EQ.1)) GO TO 150 + CALL cumchn(x,df,pnonc,cum,ccum) + fx = cum - p + CALL dinvr(status,x,fx,qleft,qhi) + GO TO 140 + + 150 IF (.NOT. (status.EQ.-1)) GO TO 180 + IF (.NOT. (qleft)) GO TO 160 + status = 1 + bound = 0.0D0 + GO TO 170 + + 160 status = 2 + bound = inf + 170 CONTINUE + 180 CONTINUE + + ELSE IF ((3).EQ. (which)) THEN +C +C Calculating DF +C + df = 5.0D0 + CALL dstinv(zero,inf,0.5D0,0.5D0,5.0D0,atol,tol) + status = 0 + CALL dinvr(status,df,fx,qleft,qhi) + 190 IF (.NOT. (status.EQ.1)) GO TO 200 + CALL cumchn(x,df,pnonc,cum,ccum) + fx = cum - p + CALL dinvr(status,df,fx,qleft,qhi) + GO TO 190 + + 200 IF (.NOT. (status.EQ.-1)) GO TO 230 + IF (.NOT. (qleft)) GO TO 210 + status = 1 + bound = zero + GO TO 220 + + 210 status = 2 + bound = inf + 220 CONTINUE + 230 CONTINUE + + ELSE IF ((4).EQ. (which)) THEN +C +C Calculating PNONC +C + pnonc = 5.0D0 + CALL dstinv(0.0D0,tent4,0.5D0,0.5D0,5.0D0,atol,tol) + status = 0 + CALL dinvr(status,pnonc,fx,qleft,qhi) + 240 IF (.NOT. (status.EQ.1)) GO TO 250 + CALL cumchn(x,df,pnonc,cum,ccum) + fx = cum - p + CALL dinvr(status,pnonc,fx,qleft,qhi) + GO TO 240 + + 250 IF (.NOT. (status.EQ.-1)) GO TO 280 + IF (.NOT. (qleft)) GO TO 260 + status = 1 + bound = zero + GO TO 270 + + 260 status = 2 + bound = tent4 + 270 CONTINUE + 280 END IF + + RETURN + + END diff --git a/modules/statistics/src/dcdflib/cdfchn.lo b/modules/statistics/src/dcdflib/cdfchn.lo new file mode 100755 index 000000000..42c07230b --- /dev/null +++ b/modules/statistics/src/dcdflib/cdfchn.lo @@ -0,0 +1,12 @@ +# src/dcdflib/cdfchn.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/cdfchn.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/statistics/src/dcdflib/cdff.f b/modules/statistics/src/dcdflib/cdff.f new file mode 100755 index 000000000..ded2f2856 --- /dev/null +++ b/modules/statistics/src/dcdflib/cdff.f @@ -0,0 +1,351 @@ + SUBROUTINE cdff(which,p,q,f,dfn,dfd,status,bound) +C********************************************************************** +C +C SUBROUTINE CDFF( WHICH, P, Q, F, DFN, DFD, STATUS, BOUND ) +C Cumulative Distribution Function +C F distribution +C +C +C Function +C +C +C Calculates any one parameter of the F distribution +C given values for the others. +C +C +C Arguments +C +C +C WHICH --> Integer indicating which of the next four argument +C values is to be calculated from the others. +C Legal range: 1..4 +C iwhich = 1 : Calculate P and Q from F,DFN and DFD +C iwhich = 2 : Calculate F from P,Q,DFN and DFD +C iwhich = 3 : Calculate DFN from P,Q,F and DFD +C iwhich = 4 : Calculate DFD from P,Q,F and DFN +C INTEGER WHICH +C +C P <--> The integral from 0 to F of the f-density. +C Input range: [0,1]. +C DOUBLE PRECISION P +C +C Q <--> 1-P. +C Input range: (0, 1]. +C P + Q = 1.0. +C DOUBLE PRECISION Q +C +C F <--> Upper limit of integration of the f-density. +C Input range: [0, +infinity). +C Search range: [0,1E300] +C DOUBLE PRECISION F +C +C DFN < --> Degrees of freedom of the numerator sum of squares. +C Input range: (0, +infinity). +C Search range: [ 1E-300, 1E300] +C DOUBLE PRECISION DFN +C +C DFD < --> Degrees of freedom of the denominator sum of squares. +C Input range: (0, +infinity). +C Search range: [ 1E-300, 1E300] +C DOUBLE PRECISION DFD +C +C STATUS <-- 0 if calculation completed correctly +C -I if input parameter number I is out of range +C 1 if answer appears to be lower than lowest +C search bound +C 2 if answer appears to be higher than greatest +C search bound +C 3 if P + Q .ne. 1 +C INTEGER STATUS +C +C BOUND <-- Undefined if STATUS is 0 +C +C Bound exceeded by parameter number I if STATUS +C is negative. +C +C Lower search bound if STATUS is 1. +C +C Upper search bound if STATUS is 2. +C +C +C Method +C +C +C Formula 26.6.2 of Abramowitz and Stegun, Handbook of +C Mathematical Functions (1966) is used to reduce the computation +C of the cumulative distribution function for the F variate to +C that of an incomplete beta. +C +C Computation of other parameters involve a search for a value that +C produces the desired value of P. The search relies on the +C monotonicity of P with the other parameter. +C +C WARNING +C +C The value of the cumulative F distribution is not necessarily +C monotone in either degrees of freedom. There thus may be two +C values that provide a given CDF value. This routine assumes +C monotonicity and will find an arbitrary one of the two values. +C +C********************************************************************** +C .. Parameters .. + DOUBLE PRECISION tol + PARAMETER (tol=1.0D-13) + DOUBLE PRECISION atol + PARAMETER (atol=1.0D-50) + DOUBLE PRECISION zero,inf + PARAMETER (zero=1.0D-300,inf=1.0D300) +C .. +C .. Scalar Arguments .. + DOUBLE PRECISION bound,dfd,dfn,f,p,q + INTEGER status,which +C .. +C .. Local Scalars .. + DOUBLE PRECISION pq,fx,cum,ccum + LOGICAL qhi,qleft,qporq +C .. +C .. External Functions .. + INTEGER vfinite + DOUBLE PRECISION spmpar + EXTERNAL spmpar +C .. +C .. External Subroutines .. + EXTERNAL dinvr,dstinv,cumf +C .. +C .. Executable Statements .. +C +C Check arguments +C + IF (.NOT. ((which.LT.1).OR. (which.GT.4))) GO TO 30 + IF (.NOT. (which.LT.1)) GO TO 10 + bound = 1.0D0 + GO TO 20 + + 10 bound = 4.0D0 + 20 status = -1 + RETURN + + 30 IF (which.EQ.1) GO TO 70 +C +C P +C + IF (ISANAN(p).EQ.1) THEN + CALL RETURNANANFORTRAN(f) + CALL RETURNANANFORTRAN(dfn) + CALL RETURNANANFORTRAN(dfd) + RETURN + ENDIF + IF (.NOT. ((p.LT.0.0D0).OR. (p.GT.1.0D0))) GO TO 60 + IF (.NOT. (p.LT.0.0D0)) GO TO 40 + bound = 0.0D0 + GO TO 50 + + 40 bound = 1.0D0 + 50 status = -2 + RETURN + + 60 CONTINUE + 70 IF (which.EQ.1) GO TO 110 +C +C Q +C + IF (ISANAN(q).EQ.1) THEN + CALL RETURNANANFORTRAN(f) + CALL RETURNANANFORTRAN(dfn) + CALL RETURNANANFORTRAN(dfd) + RETURN + ENDIF + IF (.NOT. ((q.LE.0.0D0).OR. (q.GT.1.0D0))) GO TO 100 + IF (.NOT. (q.LE.0.0D0)) GO TO 80 + bound = 0.0D0 + GO TO 90 + + 80 bound = 1.0D0 + 90 status = -3 + RETURN + + 100 CONTINUE + 110 IF (which.EQ.2) GO TO 130 +C +C F +C + IF (ISANAN(f).EQ.1) THEN + CALL RETURNANANFORTRAN(p) + CALL RETURNANANFORTRAN(q) + CALL RETURNANANFORTRAN(dfn) + CALL RETURNANANFORTRAN(dfd) + RETURN + ENDIF + IF (vfinite(1,f).EQ.0) then + IF (which.EQ.1) then + IF (f.GT.0) then + p = 1 + q = 0 + RETURN + ENDIF + ELSE + f = SIGN(1D300,f) + ENDIF + ENDIF + IF (.NOT. (f.LT.0.0D0)) GO TO 120 + bound = 0.0D0 + status = -4 + RETURN + + 120 CONTINUE + 130 IF (which.EQ.3) GO TO 150 +C +C DFN +C + IF (ISANAN(dfn).EQ.1) THEN + CALL RETURNANANFORTRAN(p) + CALL RETURNANANFORTRAN(q) + CALL RETURNANANFORTRAN(f) + CALL RETURNANANFORTRAN(dfd) + RETURN + ENDIF + IF (vfinite(1,dfn).EQ.0) dfn = SIGN(inf,dfn) + IF (.NOT. (dfn.LE.0.0D0)) GO TO 140 + bound = 0.0D0 + status = -5 + RETURN + + 140 CONTINUE + 150 IF (which.EQ.4) GO TO 170 +C +C DFD +C + IF (ISANAN(dfd).EQ.1) THEN + CALL RETURNANANFORTRAN(p) + CALL RETURNANANFORTRAN(q) + CALL RETURNANANFORTRAN(f) + CALL RETURNANANFORTRAN(dfn) + RETURN + ENDIF + IF (vfinite(1,dfd).EQ.0) dfd = SIGN(inf,dfd) + IF (.NOT. (dfd.LE.0.0D0)) GO TO 160 + bound = 0.0D0 + status = -6 + RETURN + + 160 CONTINUE + 170 IF (which.EQ.1) GO TO 210 +C +C P + Q +C + pq = p + q + IF (.NOT. (abs(((pq)-0.5D0)-0.5D0).GT. + + (3.0D0*spmpar(1)))) GO TO 200 + IF (.NOT. (pq.LT.0.0D0)) GO TO 180 + bound = 0.0D0 + GO TO 190 + + 180 bound = 1.0D0 + 190 status = 3 + RETURN + + 200 CONTINUE + 210 IF (.NOT. (which.EQ.1)) qporq = p .LE. q +C +C Select the minimum of P or Q +C +C +C Calculate ANSWERS +C + IF ((1).EQ. (which)) THEN +C +C Calculating P +C + CALL cumf(f,dfn,dfd,p,q) + status = 0 + + ELSE IF ((2).EQ. (which)) THEN +C +C Calculating F +C + f = 5.0D0 + CALL dstinv(0.0D0,inf,0.5D0,0.5D0,5.0D0,atol,tol) + status = 0 + CALL dinvr(status,f,fx,qleft,qhi) + 220 IF (.NOT. (status.EQ.1)) GO TO 250 + CALL cumf(f,dfn,dfd,cum,ccum) + IF (.NOT. (qporq)) GO TO 230 + fx = cum - p + GO TO 240 + + 230 fx = ccum - q + 240 CALL dinvr(status,f,fx,qleft,qhi) + GO TO 220 + + 250 IF (.NOT. (status.EQ.-1)) GO TO 280 + IF (.NOT. (qleft)) GO TO 260 + status = 1 + bound = 0.0D0 + GO TO 270 + + 260 status = 2 + bound = inf + 270 CONTINUE + 280 CONTINUE + + ELSE IF ((3).EQ. (which)) THEN +C +C Calculating DFN +C + dfn = 5.0D0 + CALL dstinv(zero,inf,0.5D0,0.5D0,5.0D0,atol,tol) + status = 0 + CALL dinvr(status,dfn,fx,qleft,qhi) + 290 IF (.NOT. (status.EQ.1)) GO TO 320 + CALL cumf(f,dfn,dfd,cum,ccum) + IF (.NOT. (qporq)) GO TO 300 + fx = cum - p + GO TO 310 + + 300 fx = ccum - q + 310 CALL dinvr(status,dfn,fx,qleft,qhi) + GO TO 290 + + 320 IF (.NOT. (status.EQ.-1)) GO TO 350 + IF (.NOT. (qleft)) GO TO 330 + status = 1 + bound = zero + GO TO 340 + + 330 status = 2 + bound = inf + 340 CONTINUE + 350 CONTINUE + + ELSE IF ((4).EQ. (which)) THEN +C +C Calculating DFD +C + dfd = 5.0D0 + CALL dstinv(zero,inf,0.5D0,0.5D0,5.0D0,atol,tol) + status = 0 + CALL dinvr(status,dfd,fx,qleft,qhi) + 360 IF (.NOT. (status.EQ.1)) GO TO 390 + CALL cumf(f,dfn,dfd,cum,ccum) + IF (.NOT. (qporq)) GO TO 370 + fx = cum - p + GO TO 380 + + 370 fx = ccum - q + 380 CALL dinvr(status,dfd,fx,qleft,qhi) + GO TO 360 + + 390 IF (.NOT. (status.EQ.-1)) GO TO 420 + IF (.NOT. (qleft)) GO TO 400 + status = 1 + bound = zero + GO TO 410 + + 400 status = 2 + bound = inf + 410 CONTINUE + 420 END IF + + RETURN + + END diff --git a/modules/statistics/src/dcdflib/cdff.lo b/modules/statistics/src/dcdflib/cdff.lo new file mode 100755 index 000000000..f1377a72c --- /dev/null +++ b/modules/statistics/src/dcdflib/cdff.lo @@ -0,0 +1,12 @@ +# src/dcdflib/cdff.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/cdff.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/statistics/src/dcdflib/cdffnc.f b/modules/statistics/src/dcdflib/cdffnc.f new file mode 100755 index 000000000..62e50f308 --- /dev/null +++ b/modules/statistics/src/dcdflib/cdffnc.f @@ -0,0 +1,361 @@ + SUBROUTINE cdffnc(which,p,q,f,dfn,dfd,phonc,status,bound) +C********************************************************************** +C +C SUBROUTINE CDFFNC( WHICH, P, Q, F, DFN, DFD, PNONC, STATUS, BOUND +C Cumulative Distribution Function +C Non-central F distribution +C +C +C Function +C +C +C Calculates any one parameter of the Non-central F +C distribution given values for the others. +C +C +C Arguments +C +C +C WHICH --> Integer indicating which of the next five argument +C values is to be calculated from the others. +C Legal range: 1..5 +C iwhich = 1 : Calculate P and Q from F,DFN,DFD and PNONC +C iwhich = 2 : Calculate F from P,Q,DFN,DFD and PNONC +C iwhich = 3 : Calculate DFN from P,Q,F,DFD and PNONC +C iwhich = 4 : Calculate DFD from P,Q,F,DFN and PNONC +C iwhich = 5 : Calculate PNONC from P,Q,F,DFN and DFD +C INTEGER WHICH +C +C P <--> The integral from 0 to F of the non-central f-density. +C Input range: [0,1-1E-16). +C DOUBLE PRECISION P +C +C Q <--> 1-P. +C Q is not used by this subroutine and is only included +C for similarity with other cdf* routines. +C DOUBLE PRECISION Q +C +C F <--> Upper limit of integration of the non-central f-density. +C Input range: [0, +infinity). +C Search range: [0,1E300] +C DOUBLE PRECISION F +C +C DFN < --> Degrees of freedom of the numerator sum of squares. +C Input range: (0, +infinity). +C Search range: [ 1E-300, 1E300] +C DOUBLE PRECISION DFN +C +C DFD < --> Degrees of freedom of the denominator sum of squares. +C Must be in range: (0, +infinity). +C Input range: (0, +infinity). +C Search range: [ 1E-300, 1E300] +C DOUBLE PRECISION DFD +C +C PNONC <-> The non-centrality parameter +C Input range: [0,infinity) +C Search range: [0,1E4] +C DOUBLE PRECISION PHONC +C +C STATUS <-- 0 if calculation completed correctly +C -I if input parameter number I is out of range +C 1 if answer appears to be lower than lowest +C search bound +C 2 if answer appears to be higher than greatest +C search bound +C 3 if P + Q .ne. 1 +C INTEGER STATUS +C +C BOUND <-- Undefined if STATUS is 0 +C +C Bound exceeded by parameter number I if STATUS +C is negative. +C +C Lower search bound if STATUS is 1. +C +C Upper search bound if STATUS is 2. +C +C +C Method +C +C +C Formula 26.6.20 of Abramowitz and Stegun, Handbook of +C Mathematical Functions (1966) is used to compute the cumulative +C distribution function. +C +C Computation of other parameters involve a search for a value that +C produces the desired value of P. The search relies on the +C monotonicity of P with the other parameter. +C +C WARNING +C +C The computation time required for this routine is proportional +C to the noncentrality parameter (PNONC). Very large values of +C this parameter can consume immense computer resources. This is +C why the search range is bounded by 10,000. +C +C WARNING +C +C The value of the cumulative noncentral F distribution is not +C necessarily monotone in either degrees of freedom. There thus +C may be two values that provide a given CDF value. This routine +C assumes monotonicity and will find an arbitrary one of the two +C values. +C +C********************************************************************** +C .. Parameters .. + DOUBLE PRECISION tent4 + PARAMETER (tent4=1.0D4) + DOUBLE PRECISION tol + PARAMETER (tol=1.0D-13) + DOUBLE PRECISION atol + PARAMETER (atol=1.0D-50) + DOUBLE PRECISION zero,one,inf + PARAMETER (zero=1.0D-300,one=1.0D0-1.0D-16,inf=1.0D300) +C .. +C .. Scalar Arguments .. + DOUBLE PRECISION bound,dfd,dfn,f,p,q,phonc + INTEGER status,which +C .. +C .. Local Scalars .. + DOUBLE PRECISION fx,cum,ccum + LOGICAL qhi,qleft +C .. +C .. External Functions .. + INTEGER vfinite +C .. +C .. External Subroutines .. + EXTERNAL dinvr,dstinv,cumfnc +C .. +C .. Executable Statements .. +C +C Check arguments +C + IF (.NOT. ((which.LT.1).OR. (which.GT.5))) GO TO 30 + IF (.NOT. (which.LT.1)) GO TO 10 + bound = 1.0D0 + GO TO 20 + + 10 bound = 5.0D0 + 20 status = -1 + RETURN + + 30 IF (which.EQ.1) GO TO 70 +C +C P +C + IF (ISANAN(p).EQ.1) THEN + CALL RETURNANANFORTRAN(dfn) + CALL RETURNANANFORTRAN(dfd) + CALL RETURNANANFORTRAN(f) + CALL RETURNANANFORTRAN(phonc) + RETURN + ENDIF + IF (.NOT. ((p.LT.0.0D0).OR. (p.GT.one))) GO TO 60 + IF (.NOT. (p.LT.0.0D0)) GO TO 40 + bound = 0.0D0 + GO TO 50 + + 40 bound = one + 50 status = -2 + RETURN + + 60 CONTINUE + 70 IF (which.EQ.2) GO TO 90 +C +C F +C + IF (ISANAN(f).EQ.1) THEN + CALL RETURNANANFORTRAN(p) + CALL RETURNANANFORTRAN(q) + CALL RETURNANANFORTRAN(dfn) + CALL RETURNANANFORTRAN(dfd) + CALL RETURNANANFORTRAN(phonc) + RETURN + ENDIF + IF (vfinite(1,f).EQ.0) then + IF (which.EQ.1) then + IF (f.GT.0) then + p = 1 + q = 0 + RETURN + ENDIF + ELSE + f = SIGN(1D300,f) + ENDIF + ENDIF + IF (.NOT. (f.LT.0.0D0)) GO TO 80 + bound = 0.0D0 + status = -4 + RETURN + + 80 CONTINUE + 90 IF (which.EQ.3) GO TO 110 +C +C DFN +C + IF (ISANAN(dfn).EQ.1) THEN + CALL RETURNANANFORTRAN(p) + CALL RETURNANANFORTRAN(q) + CALL RETURNANANFORTRAN(f) + CALL RETURNANANFORTRAN(dfd) + CALL RETURNANANFORTRAN(phonc) + RETURN + ENDIF + IF (vfinite(1,dfn).EQ.0) dfn = SIGN(inf,dfn) + IF (.NOT. (dfn.LE.0.0D0)) GO TO 100 + bound = 0.0D0 + status = -5 + RETURN + + 100 CONTINUE + 110 IF (which.EQ.4) GO TO 130 +C +C DFD +C + IF (ISANAN(dfd).EQ.1) THEN + CALL RETURNANANFORTRAN(p) + CALL RETURNANANFORTRAN(q) + CALL RETURNANANFORTRAN(dfn) + CALL RETURNANANFORTRAN(f) + CALL RETURNANANFORTRAN(phonc) + RETURN + ENDIF + IF (vfinite(1,dfd).EQ.0) dfd = SIGN(inf,dfd) + IF (.NOT. (dfd.LE.0.0D0)) GO TO 120 + bound = 0.0D0 + status = -6 + RETURN + + 120 CONTINUE + 130 IF (which.EQ.5) GO TO 150 +C +C PHONC +C + IF (ISANAN(phonc).EQ.1) THEN + CALL RETURNANANFORTRAN(p) + CALL RETURNANANFORTRAN(q) + CALL RETURNANANFORTRAN(dfn) + CALL RETURNANANFORTRAN(dfd) + CALL RETURNANANFORTRAN(f) + RETURN + ENDIF + IF (vfinite(1,phonc).EQ.0) phonc = SIGN(inf,phonc) + IF (.NOT. (phonc.LT.0.0D0)) GO TO 140 + bound = 0.0D0 + status = -7 + RETURN + + 140 CONTINUE +C +C Calculate ANSWERS +C + 150 IF ((1).EQ. (which)) THEN +C +C Calculating P +C + CALL cumfnc(f,dfn,dfd,phonc,p,q) + status = 0 + + ELSE IF ((2).EQ. (which)) THEN +C +C Calculating F +C + f = 5.0D0 + CALL dstinv(0.0D0,inf,0.5D0,0.5D0,5.0D0,atol,tol) + status = 0 + CALL dinvr(status,f,fx,qleft,qhi) + 160 IF (.NOT. (status.EQ.1)) GO TO 170 + CALL cumfnc(f,dfn,dfd,phonc,cum,ccum) + fx = cum - p + CALL dinvr(status,f,fx,qleft,qhi) + GO TO 160 + + 170 IF (.NOT. (status.EQ.-1)) GO TO 200 + IF (.NOT. (qleft)) GO TO 180 + status = 1 + bound = 0.0D0 + GO TO 190 + + 180 status = 2 + bound = inf + 190 CONTINUE + 200 CONTINUE + + ELSE IF ((3).EQ. (which)) THEN +C +C Calculating DFN +C + dfn = 5.0D0 + CALL dstinv(zero,inf,0.5D0,0.5D0,5.0D0,atol,tol) + status = 0 + CALL dinvr(status,dfn,fx,qleft,qhi) + 210 IF (.NOT. (status.EQ.1)) GO TO 220 + CALL cumfnc(f,dfn,dfd,phonc,cum,ccum) + fx = cum - p + CALL dinvr(status,dfn,fx,qleft,qhi) + GO TO 210 + + 220 IF (.NOT. (status.EQ.-1)) GO TO 250 + IF (.NOT. (qleft)) GO TO 230 + status = 1 + bound = zero + GO TO 240 + + 230 status = 2 + bound = inf + 240 CONTINUE + 250 CONTINUE + + ELSE IF ((4).EQ. (which)) THEN +C +C Calculating DFD +C + dfd = 5.0D0 + CALL dstinv(zero,inf,0.5D0,0.5D0,5.0D0,atol,tol) + status = 0 + CALL dinvr(status,dfd,fx,qleft,qhi) + 260 IF (.NOT. (status.EQ.1)) GO TO 270 + CALL cumfnc(f,dfn,dfd,phonc,cum,ccum) + fx = cum - p + CALL dinvr(status,dfd,fx,qleft,qhi) + GO TO 260 + + 270 IF (.NOT. (status.EQ.-1)) GO TO 300 + IF (.NOT. (qleft)) GO TO 280 + status = 1 + bound = zero + GO TO 290 + + 280 status = 2 + bound = inf + 290 CONTINUE + 300 CONTINUE + + ELSE IF ((5).EQ. (which)) THEN +C +C Calculating PHONC +C + phonc = 5.0D0 + CALL dstinv(0.0D0,tent4,0.5D0,0.5D0,5.0D0,atol,tol) + status = 0 + CALL dinvr(status,phonc,fx,qleft,qhi) + 310 IF (.NOT. (status.EQ.1)) GO TO 320 + CALL cumfnc(f,dfn,dfd,phonc,cum,ccum) + fx = cum - p + CALL dinvr(status,phonc,fx,qleft,qhi) + GO TO 310 + + 320 IF (.NOT. (status.EQ.-1)) GO TO 350 + IF (.NOT. (qleft)) GO TO 330 + status = 1 + bound = 0.0D0 + GO TO 340 + + 330 status = 2 + bound = tent4 + 340 CONTINUE + 350 END IF + + RETURN + + END diff --git a/modules/statistics/src/dcdflib/cdffnc.lo b/modules/statistics/src/dcdflib/cdffnc.lo new file mode 100755 index 000000000..ffc4c2298 --- /dev/null +++ b/modules/statistics/src/dcdflib/cdffnc.lo @@ -0,0 +1,12 @@ +# src/dcdflib/cdffnc.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/cdffnc.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/statistics/src/dcdflib/cdfgam.f b/modules/statistics/src/dcdflib/cdfgam.f new file mode 100755 index 000000000..e8b8d1ea6 --- /dev/null +++ b/modules/statistics/src/dcdflib/cdfgam.f @@ -0,0 +1,355 @@ + SUBROUTINE cdfgam(which,p,q,x,shape,scale,status,bound) +C********************************************************************** +C +C SUBROUTINE CDFGAM( WHICH, P, Q, X, SHAPE, SCALE, STATUS, BOUND ) +C Cumulative Distribution Function +C GAMma Distribution +C +C +C Function +C +C +C Calculates any one parameter of the gamma +C distribution given values for the others. +C +C +C Arguments +C +C +C WHICH --> Integer indicating which of the next four argument +C values is to be calculated from the others. +C Legal range: 1..4 +C iwhich = 1 : Calculate P and Q from X,SHAPE and SCALE +C iwhich = 2 : Calculate X from P,Q,SHAPE and SCALE +C iwhich = 3 : Calculate SHAPE from P,Q,X and SCALE +C iwhich = 4 : Calculate SCALE from P,Q,X and SHAPE +C INTEGER WHICH +C +C P <--> The integral from 0 to X of the gamma density. +C Input range: [0,1]. +C DOUBLE PRECISION P +C +C Q <--> 1-P. +C Input range: (0, 1]. +C P + Q = 1.0. +C DOUBLE PRECISION Q +C +C +C X <--> The upper limit of integration of the gamma density. +C Input range: [0, +infinity). +C Search range: [0,1E300] +C DOUBLE PRECISION X +C +C SHAPE <--> The shape parameter of the gamma density. +C Input range: (0, +infinity). +C Search range: [1E-300,1E300] +C DOUBLE PRECISION SHAPE +C +C +C SCALE <--> The scale parameter of the gamma density. +C Input range: (0, +infinity). +C Search range: (1E-300,1E300] +C DOUBLE PRECISION SCALE +C +C STATUS <-- 0 if calculation completed correctly +C -I if input parameter number I is out of range +C 1 if answer appears to be lower than lowest +C search bound +C 2 if answer appears to be higher than greatest +C search bound +C 3 if P + Q .ne. 1 +C 10 if the gamma or inverse gamma routine cannot +C compute the answer. Usually happens only for +C X and SHAPE very large (gt 1E10 or more) +C INTEGER STATUS +C +C BOUND <-- Undefined if STATUS is 0 +C +C Bound exceeded by parameter number I if STATUS +C is negative. +C +C Lower search bound if STATUS is 1. +C +C Upper search bound if STATUS is 2. +C +C +C Method +C +C +C Cumulative distribution function (P) is calculated directly by +C the code associated with: +C +C DiDinato, A. R. and Morris, A. H. Computation of the incomplete +C gamma function ratios and their inverse. ACM Trans. Math. +C Softw. 12 (1986), 377-393. +C +C Computation of other parameters involve a search for a value that +C produces the desired value of P. The search relies on the +C monotonicity of P with the other parameter. +C +C +C Note +C +C +C +C The gamma density is proportional to +C T**(SHAPE - 1) * EXP(- SCALE * T) +C +C History +C +C Routine modified by Scilab group 1998, because of an undefined +C variable. See below comments "CSS". + +C********************************************************************** +C .. Parameters .. + DOUBLE PRECISION tol + PARAMETER (tol=1.0D-13) + DOUBLE PRECISION atol + PARAMETER (atol=1.0D-50) + DOUBLE PRECISION zero,inf + PARAMETER (zero=1.0D-300,inf=1.0D300) +C .. +C .. Scalar Arguments .. + DOUBLE PRECISION bound,p,q,scale,shape,x + INTEGER status,which +C .. +C .. Local Scalars .. + DOUBLE PRECISION xx + DOUBLE PRECISION fx,xscale,cum,ccum,pq,porq + INTEGER ierr + LOGICAL qhi,qleft,qporq +C .. +C .. External Functions .. + INTEGER vfinite + DOUBLE PRECISION spmpar + EXTERNAL spmpar +C .. +C .. External Subroutines .. + EXTERNAL gaminv,dinvr,dstinv,cumgam +C .. +C .. Executable Statements .. +C +C Check arguments +C + IF (.NOT. ((which.LT.1).OR. (which.GT.4))) GO TO 30 + IF (.NOT. (which.LT.1)) GO TO 10 + bound = 1.0D0 + GO TO 20 + + 10 bound = 4.0D0 + 20 status = -1 + RETURN + + 30 IF (which.EQ.1) GO TO 70 +C +C P +C + IF (ISANAN(p).EQ.1) THEN + CALL RETURNANANFORTRAN(shape) + CALL RETURNANANFORTRAN(x) + CALL RETURNANANFORTRAN(scale) + RETURN + ENDIF + IF (.NOT. ((p.LT.0.0D0).OR. (p.GT.1.0D0))) GO TO 60 + IF (.NOT. (p.LT.0.0D0)) GO TO 40 + bound = 0.0D0 + GO TO 50 + + 40 bound = 1.0d0 + 50 status = -2 + RETURN + + 60 CONTINUE + 70 IF (which.EQ.1) GO TO 110 +C +C Q +C + IF (ISANAN(q).EQ.1) THEN + CALL RETURNANANFORTRAN(shape) + CALL RETURNANANFORTRAN(x) + CALL RETURNANANFORTRAN(scale) + RETURN + ENDIF + IF (.NOT. ((q.LE.0.0D0).OR. (q.GT.1.0D0))) GO TO 100 + IF (.NOT. (q.LE.0.0D0)) GO TO 80 + bound = 0.0D0 + GO TO 90 + + 80 bound = 1.0D0 + 90 status = -3 + RETURN + + 100 CONTINUE + 110 IF (which.EQ.2) GO TO 130 +C +C X +C + IF (ISANAN(x).EQ.1) THEN + CALL RETURNANANFORTRAN(p) + CALL RETURNANANFORTRAN(q) + CALL RETURNANANFORTRAN(shape) + CALL RETURNANANFORTRAN(scale) + RETURN + ENDIF + IF (vfinite(1,x).EQ.0) then + IF (which.EQ.1) then + IF (x.GT.0) then + p = 1 + q = 0 + RETURN + ENDIF + ELSE + x = SIGN(1D300,x) + ENDIF + ENDIF + IF (.NOT. (x.LT.0.0D0)) GO TO 120 + bound = 0.0D0 + status = -4 + RETURN + + 120 CONTINUE + 130 IF (which.EQ.3) GO TO 150 +C +C SHAPE +C + IF (ISANAN(shape).EQ.1) THEN + CALL RETURNANANFORTRAN(p) + CALL RETURNANANFORTRAN(q) + CALL RETURNANANFORTRAN(x) + CALL RETURNANANFORTRAN(scale) + RETURN + ENDIF + IF (vfinite(1,shape).EQ.0) shape = SIGN(inf,shape) + IF (.NOT. (shape.LE.0.0D0)) GO TO 140 + bound = 0.0D0 + status = -5 + RETURN + + 140 CONTINUE + 150 IF (which.EQ.4) GO TO 170 +C +C SCALE +C + IF (ISANAN(scale).EQ.1) THEN + CALL RETURNANANFORTRAN(p) + CALL RETURNANANFORTRAN(q) + CALL RETURNANANFORTRAN(shape) + CALL RETURNANANFORTRAN(x) + RETURN + ENDIF + IF (vfinite(1,scale).EQ.0) scale = SIGN(inf,scale) + IF (.NOT. (scale.LE.0.0D0)) GO TO 160 + bound = 0.0D0 + status = -6 + RETURN + + 160 CONTINUE + 170 IF (which.EQ.1) GO TO 210 +C +C P + Q +C + pq = p + q + IF (.NOT. (abs(((pq)-0.5D0)-0.5D0).GT. + + (3.0D0*spmpar(1)))) GO TO 200 + IF (.NOT. (pq.LT.0.0D0)) GO TO 180 + bound = 0.0D0 + GO TO 190 + + 180 bound = 1.0D0 + 190 status = 3 + RETURN + + 200 CONTINUE + 210 IF (which.EQ.1) GO TO 240 +C +C Select the minimum of P or Q +C + qporq = p .LE. q + IF (.NOT. (qporq)) GO TO 220 + porq = p + GO TO 230 + + 220 porq = q + 230 CONTINUE +C +C Calculate ANSWERS +C + 240 IF ((1).EQ. (which)) THEN +C +C Calculating P +C + status = 0 + xscale = x*scale + CALL cumgam(xscale,shape,p,q) +CSS Next line changed by Scilab group. porq undefined here +CSS IF (porq.GT.1.5D0) status = 10 + IF (p.GT.1.5D0) status = 10 + + ELSE IF ((2).EQ. (which)) THEN +C +C Computing X +C + CALL gaminv(shape,xx,-1.0D0,p,q,ierr) + IF (ierr.LT.0.0D0) THEN + status = 10 + RETURN + + ELSE + x = xx/scale + status = 0 + END IF + + ELSE IF ((3).EQ. (which)) THEN +C +C Computing SHAPE +C + shape = 5.0D0 + xscale = x*scale + CALL dstinv(zero,inf,0.5D0,0.5D0,5.0D0,atol,tol) + status = 0 + CALL dinvr(status,shape,fx,qleft,qhi) + 250 IF (.NOT. (status.EQ.1)) GO TO 290 + CALL cumgam(xscale,shape,cum,ccum) + IF (.NOT. (qporq)) GO TO 260 + fx = cum - p + GO TO 270 + + 260 fx = ccum - q + 270 IF (.NOT. ((qporq.AND. (cum.GT.1.5D0)).OR. + + ((.NOT.qporq).AND. (ccum.GT.1.5D0)))) GO TO 280 + status = 10 + RETURN + + 280 CALL dinvr(status,shape,fx,qleft,qhi) + GO TO 250 + + 290 IF (.NOT. (status.EQ.-1)) GO TO 320 + IF (.NOT. (qleft)) GO TO 300 + status = 1 + bound = zero + GO TO 310 + + 300 status = 2 + bound = inf + 310 CONTINUE + 320 CONTINUE + + ELSE IF ((4).EQ. (which)) THEN +C +C Computing SCALE +C + CALL gaminv(shape,xx,-1.0D0,p,q,ierr) + IF (ierr.LT.0.0D0) THEN + status = 10 + RETURN + + ELSE + scale = xx/x + status = 0 + END IF + + END IF + + RETURN + + END diff --git a/modules/statistics/src/dcdflib/cdfgam.lo b/modules/statistics/src/dcdflib/cdfgam.lo new file mode 100755 index 000000000..4395fff6c --- /dev/null +++ b/modules/statistics/src/dcdflib/cdfgam.lo @@ -0,0 +1,12 @@ +# src/dcdflib/cdfgam.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/cdfgam.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/statistics/src/dcdflib/cdfnbn.f b/modules/statistics/src/dcdflib/cdfnbn.f new file mode 100755 index 000000000..924ab647e --- /dev/null +++ b/modules/statistics/src/dcdflib/cdfnbn.f @@ -0,0 +1,420 @@ + SUBROUTINE cdfnbn(which,p,q,s,xn,pr,ompr,status,bound) +C********************************************************************** +C +C SUBROUTINE CDFNBN ( WHICH, P,Q, S, XN, PR, STATUS, BOUND ) +C Cumulative Distribution Function +C Negative BiNomial distribution +C +C +C Function +C +C +C Calculates any one parameter of the negative binomial +C distribution given values for the others. +C +C The cumulative negative binomial distribution returns the +C probability that there will be F or fewer failures before the +C XNth success in binomial trials each of which has probability of +C success PR. +C +C The individual term of the negative binomial is the probability of +C S failures before XN successes and is +C Choose( S, XN+S-1 ) * PR^(XN) * (1-PR)^S +C +C +C Arguments +C +C +C WHICH --> Integer indicating which of the next four argument +C values is to be calculated from the others. +C Legal range: 1..4 +C iwhich = 1 : Calculate P and Q from S,XN,PR and OMPR +C iwhich = 2 : Calculate S from P,Q,XN,PR and OMPR +C iwhich = 3 : Calculate XN from P,Q,S,PR and OMPR +C iwhich = 4 : Calculate PR and OMPR from P,Q,S and XN +C INTEGER WHICH +C +C P <--> The cumulation from 0 to S of the negative +C binomial distribution. +C Input range: [0,1]. +C DOUBLE PRECISION P +C +C Q <--> 1-P. +C Input range: (0, 1]. +C P + Q = 1.0. +C DOUBLE PRECISION Q +C +C S <--> The upper limit of cumulation of the binomial distribution. +C There are F or fewer failures before the XNth success. +C Input range: [0, +infinity). +C Search range: [0, 1E300] +C DOUBLE PRECISION S +C +C XN <--> The number of successes. +C Input range: [0, +infinity). +C Search range: [0, 1E300] +C DOUBLE PRECISION XN +C +C PR <--> The probability of success in each binomial trial. +C Input range: [0,1]. +C Search range: [0,1]. +C DOUBLE PRECISION PR +C +C OMPR <--> 1-PR +C Input range: [0,1]. +C Search range: [0,1] +C PR + OMPR = 1.0 +C DOUBLE PRECISION OMPR +C +C STATUS <-- 0 if calculation completed correctly +C -I if input parameter number I is out of range +C 1 if answer appears to be lower than lowest +C search bound +C 2 if answer appears to be higher than greatest +C search bound +C 3 if P + Q .ne. 1 +C 4 if PR + OMPR .ne. 1 +C INTEGER STATUS +C +C BOUND <-- Undefined if STATUS is 0 +C +C Bound exceeded by parameter number I if STATUS +C is negative. +C +C Lower search bound if STATUS is 1. +C +C Upper search bound if STATUS is 2. +C +C +C Method +C +C +C Formula 26.5.26 of Abramowitz and Stegun, Handbook of +C Mathematical Functions (1966) is used to reduce calculation of +C the cumulative distribution function to that of an incomplete +C beta. +C +C Computation of other parameters involve a search for a value that +C produces the desired value of P. The search relies on the +C monotonicity of P with the other parameter. +C +C +C********************************************************************** +C .. Parameters .. + DOUBLE PRECISION tol + PARAMETER (tol=1.0D-13) + DOUBLE PRECISION atol + PARAMETER (atol=1.0D-50) + DOUBLE PRECISION inf + PARAMETER (inf=1.0D300) + DOUBLE PRECISION one + PARAMETER (one=1.0D0) +C .. +C .. Scalar Arguments .. + DOUBLE PRECISION bound,p,q,pr,ompr,s,xn + INTEGER status,which +C .. +C .. Local Scalars .. + DOUBLE PRECISION fx,xhi,xlo,pq,prompr,cum,ccum + LOGICAL qhi,qleft,qporq +C .. +C .. External Functions .. + INTEGER vfinite + DOUBLE PRECISION spmpar + EXTERNAL spmpar +C .. +C .. External Subroutines .. + EXTERNAL dinvr,dstinv,dstzr,dzror,cumnbn +C .. +C .. Executable Statements .. +C +C Check arguments +C + IF (.NOT. ((which.LT.1).OR. (which.GT.4))) GO TO 30 + IF (.NOT. (which.LT.1)) GO TO 10 + bound = 1.0D0 + GO TO 20 + + 10 bound = 4.0D0 + 20 status = -1 + RETURN + + 30 IF (which.EQ.1) GO TO 70 +C +C P +C + IF (ISANAN(p).EQ.1) THEN + CALL RETURNANANFORTRAN(s) + CALL RETURNANANFORTRAN(xn) + CALL RETURNANANFORTRAN(pr) + CALL RETURNANANFORTRAN(ompr) + RETURN + ENDIF + IF (.NOT. ((p.LT.0.0D0).OR. (p.GT.1.0D0))) GO TO 60 + IF (.NOT. (p.LT.0.0D0)) GO TO 40 + bound = 0.0D0 + GO TO 50 + + 40 bound = 1.0D0 + 50 status = -2 + RETURN + + 60 CONTINUE + 70 IF (which.EQ.1) GO TO 110 +C +C Q +C + IF (ISANAN(q).EQ.1) THEN + CALL RETURNANANFORTRAN(s) + CALL RETURNANANFORTRAN(xn) + CALL RETURNANANFORTRAN(pr) + CALL RETURNANANFORTRAN(ompr) + RETURN + ENDIF + IF (.NOT. ((q.LE.0.0D0).OR. (q.GT.1.0D0))) GO TO 100 + IF (.NOT. (q.LE.0.0D0)) GO TO 80 + bound = 0.0D0 + GO TO 90 + + 80 bound = 1.0D0 + 90 status = -3 + RETURN + + 100 CONTINUE + 110 IF (which.EQ.2) GO TO 130 +C +C S +C + IF (ISANAN(s).EQ.1) THEN + CALL RETURNANANFORTRAN(p) + CALL RETURNANANFORTRAN(q) + CALL RETURNANANFORTRAN(xn) + CALL RETURNANANFORTRAN(pr) + CALL RETURNANANFORTRAN(ompr) + RETURN + ENDIF + IF (vfinite(1,s).EQ.0) then + IF (which.EQ.1) then + IF (s.GT.0) then + p = 1 + q = 0 + RETURN + ENDIF + ELSE + s = SIGN(1D300,s) + ENDIF + ENDIF + IF (.NOT. (s.LT.0.0D0)) GO TO 120 + bound = 0.0D0 + status = -4 + RETURN + + 120 CONTINUE + 130 IF (which.EQ.3) GO TO 150 +C +C XN +C + IF (ISANAN(xn).EQ.1) THEN + CALL RETURNANANFORTRAN(p) + CALL RETURNANANFORTRAN(q) + CALL RETURNANANFORTRAN(s) + CALL RETURNANANFORTRAN(pr) + CALL RETURNANANFORTRAN(ompr) + RETURN + ENDIF + IF (vfinite(1,xn).EQ.0) xn = SIGN(inf,xn) + IF (.NOT. (xn.LT.0.0D0)) GO TO 140 + bound = 0.0D0 + status = -5 + RETURN + + 140 CONTINUE + 150 IF (which.EQ.4) GO TO 190 +C +C PR +C + IF (ISANAN(pr).EQ.1) THEN + CALL RETURNANANFORTRAN(p) + CALL RETURNANANFORTRAN(q) + CALL RETURNANANFORTRAN(s) + CALL RETURNANANFORTRAN(xn) + RETURN + ENDIF + IF (.NOT. ((pr.LT.0.0D0).OR. (pr.GT.1.0D0))) GO TO 180 + IF (.NOT. (pr.LT.0.0D0)) GO TO 160 + bound = 0.0D0 + GO TO 170 + + 160 bound = 1.0D0 + 170 status = -6 + RETURN + + 180 CONTINUE + 190 IF (which.EQ.4) GO TO 230 +C +C OMPR +C + IF (ISANAN(ompr).EQ.1) THEN + CALL RETURNANANFORTRAN(p) + CALL RETURNANANFORTRAN(q) + CALL RETURNANANFORTRAN(s) + CALL RETURNANANFORTRAN(xn) + RETURN + ENDIF + IF (.NOT. ((ompr.LT.0.0D0).OR. (ompr.GT.1.0D0))) GO TO 220 + IF (.NOT. (ompr.LT.0.0D0)) GO TO 200 + bound = 0.0D0 + GO TO 210 + + 200 bound = 1.0D0 + 210 status = -7 + RETURN + + 220 CONTINUE + 230 IF (which.EQ.1) GO TO 270 +C +C P + Q +C + pq = p + q + IF (.NOT. (abs(((pq)-0.5D0)-0.5D0).GT. + + (3.0D0*spmpar(1)))) GO TO 260 + IF (.NOT. (pq.LT.0.0D0)) GO TO 240 + bound = 0.0D0 + GO TO 250 + + 240 bound = 1.0D0 + 250 status = 3 + RETURN + + 260 CONTINUE + 270 IF (which.EQ.4) GO TO 310 +C +C PR + OMPR +C + prompr = pr + ompr + IF (.NOT. (abs(((prompr)-0.5D0)-0.5D0).GT. + + (3.0D0*spmpar(1)))) GO TO 300 + IF (.NOT. (prompr.LT.0.0D0)) GO TO 280 + bound = 0.0D0 + GO TO 290 + + 280 bound = 1.0D0 + 290 status = 4 + RETURN + + 300 CONTINUE + 310 IF (.NOT. (which.EQ.1)) qporq = p .LE. q +C +C Select the minimum of P or Q +C +C +C Calculate ANSWERS +C + IF ((1).EQ. (which)) THEN +C +C Calculating P +C + CALL cumnbn(s,xn,pr,ompr,p,q) + status = 0 + + ELSE IF ((2).EQ. (which)) THEN +C +C Calculating S +C + s = 5.0D0 + CALL dstinv(0.0D0,inf,0.5D0,0.5D0,5.0D0,atol,tol) + status = 0 + CALL dinvr(status,s,fx,qleft,qhi) + 320 IF (.NOT. (status.EQ.1)) GO TO 350 + CALL cumnbn(s,xn,pr,ompr,cum,ccum) + IF (.NOT. (qporq)) GO TO 330 + fx = cum - p + GO TO 340 + + 330 fx = ccum - q + 340 CALL dinvr(status,s,fx,qleft,qhi) + GO TO 320 + + 350 IF (.NOT. (status.EQ.-1)) GO TO 380 + IF (.NOT. (qleft)) GO TO 360 + status = 1 + bound = 0.0D0 + GO TO 370 + + 360 status = 2 + bound = inf + 370 CONTINUE + 380 CONTINUE + + ELSE IF ((3).EQ. (which)) THEN +C +C Calculating XN +C + xn = 5.0D0 + CALL dstinv(0.0D0,inf,0.5D0,0.5D0,5.0D0,atol,tol) + status = 0 + CALL dinvr(status,xn,fx,qleft,qhi) + 390 IF (.NOT. (status.EQ.1)) GO TO 420 + CALL cumnbn(s,xn,pr,ompr,cum,ccum) + IF (.NOT. (qporq)) GO TO 400 + fx = cum - p + GO TO 410 + + 400 fx = ccum - q + 410 CALL dinvr(status,xn,fx,qleft,qhi) + GO TO 390 + + 420 IF (.NOT. (status.EQ.-1)) GO TO 450 + IF (.NOT. (qleft)) GO TO 430 + status = 1 + bound = 0.0D0 + GO TO 440 + + 430 status = 2 + bound = inf + 440 CONTINUE + 450 CONTINUE + + ELSE IF ((4).EQ. (which)) THEN +C +C Calculating PR and OMPR +C + CALL dstzr(0.0D0,1.0D0,atol,tol) + IF (.NOT. (qporq)) GO TO 480 + status = 0 + CALL dzror(status,pr,fx,xlo,xhi,qleft,qhi) + ompr = one - pr + 460 IF (.NOT. (status.EQ.1)) GO TO 470 + CALL cumnbn(s,xn,pr,ompr,cum,ccum) + fx = cum - p + CALL dzror(status,pr,fx,xlo,xhi,qleft,qhi) + ompr = one - pr + GO TO 460 + + 470 GO TO 510 + + 480 status = 0 + CALL dzror(status,ompr,fx,xlo,xhi,qleft,qhi) + pr = one - ompr + 490 IF (.NOT. (status.EQ.1)) GO TO 500 + CALL cumnbn(s,xn,pr,ompr,cum,ccum) + fx = ccum - q + CALL dzror(status,ompr,fx,xlo,xhi,qleft,qhi) + pr = one - ompr + GO TO 490 + + 500 CONTINUE + 510 IF (.NOT. (status.EQ.-1)) GO TO 540 + IF (.NOT. (qleft)) GO TO 520 + status = 1 + bound = 0.0D0 + GO TO 530 + + 520 status = 2 + bound = 1.0D0 + 530 CONTINUE + 540 END IF + + RETURN + + END diff --git a/modules/statistics/src/dcdflib/cdfnbn.lo b/modules/statistics/src/dcdflib/cdfnbn.lo new file mode 100755 index 000000000..aa1081399 --- /dev/null +++ b/modules/statistics/src/dcdflib/cdfnbn.lo @@ -0,0 +1,12 @@ +# src/dcdflib/cdfnbn.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/cdfnbn.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/statistics/src/dcdflib/cdfnor.f b/modules/statistics/src/dcdflib/cdfnor.f new file mode 100755 index 000000000..67f5b0c23 --- /dev/null +++ b/modules/statistics/src/dcdflib/cdfnor.f @@ -0,0 +1,281 @@ + SUBROUTINE cdfnor(which,p,q,x,mean,sd,status,bound) +C********************************************************************** +C +C SUBROUTINE CDFNOR( WHICH, P, Q, X, MEAN, SD, STATUS, BOUND ) +C Cumulative Distribution Function +C NORmal distribution +C +C +C Function +C +C +C Calculates any one parameter of the normal +C distribution given values for the others. +C +C +C Arguments +C +C +C WHICH --> Integer indicating which of the next parameter +C values is to be calculated using values of the others. +C Legal range: 1..4 +C iwhich = 1 : Calculate P and Q from X,MEAN and SD +C iwhich = 2 : Calculate X from P,Q,MEAN and SD +C iwhich = 3 : Calculate MEAN from P,Q,X and SD +C iwhich = 4 : Calculate SD from P,Q,X and MEAN +C INTEGER WHICH +C +C P <--> The integral from -infinity to X of the normal density. +C Input range: (0,1]. +C DOUBLE PRECISION P +C +C Q <--> 1-P. +C Input range: (0, 1]. +C P + Q = 1.0. +C DOUBLE PRECISION Q +C +C X < --> Upper limit of integration of the normal-density. +C Input range: ( -infinity, +infinity) +C DOUBLE PRECISION X +C +C MEAN <--> The mean of the normal density. +C Input range: (-infinity, +infinity) +C DOUBLE PRECISION MEAN +C +C SD <--> Standard Deviation of the normal density. +C Input range: (0, +infinity). +C DOUBLE PRECISION SD +C +C STATUS <-- 0 if calculation completed correctly +C -I if input parameter number I is out of range +C 1 if answer appears to be lower than lowest +C search bound +C 2 if answer appears to be higher than greatest +C search bound +C 3 if P + Q .ne. 1 +C INTEGER STATUS +C +C BOUND <-- Undefined if STATUS is 0 +C +C Bound exceeded by parameter number I if STATUS +C is negative. +C +C Lower search bound if STATUS is 1. +C +C Upper search bound if STATUS is 2. +C +C +C Method +C +C +C +C +C A slightly modified version of ANORM from +C +C Cody, W.D. (1993). "ALGORITHM 715: SPECFUN - A Portabel FORTRAN +C Package of Special Function Routines and Test Drivers" +C acm Transactions on Mathematical Software. 19, 22-32. +C +C is used to calulate the cumulative standard normal distribution. +C +C The rational functions from pages 90-95 of Kennedy and Gentle, +C Statistical Computing, Marcel Dekker, NY, 1980 are used as +C starting values to Newton's Iterations which compute the inverse +C standard normal. Therefore no searches are necessary for any +C parameter. +C +C For X < -15, the asymptotic expansion for the normal is used as +C the starting value in finding the inverse standard normal. +C This is formula 26.2.12 of Abramowitz and Stegun. +C +C +C Note +C +C +C The normal density is proportional to +C exp( - 0.5 * (( X - MEAN)/SD)**2) +C +C +C********************************************************************** +C .. Parameters .. + DOUBLE PRECISION inf + PARAMETER (inf=1.0D300) +C .. +C .. Scalar Arguments .. + DOUBLE PRECISION bound,mean,p,q,sd,x + INTEGER status,which +C .. +C .. Local Scalars .. + DOUBLE PRECISION z,pq +C .. +C .. External Functions .. + INTEGER vfinite + DOUBLE PRECISION dinvnr,spmpar + EXTERNAL dinvnr,spmpar +C .. +C .. External Subroutines .. + EXTERNAL cumnor +C .. +C .. Executable Statements .. +C +C Check arguments +C + status = 0 + IF (.NOT. ((which.LT.1).OR. (which.GT.4))) GO TO 30 + IF (.NOT. (which.LT.1)) GO TO 10 + bound = 1.0D0 + GO TO 20 + + 10 bound = 4.0D0 + 20 status = -1 + RETURN + + 30 IF (which.EQ.1) GO TO 70 +C +C P +C + IF (ISANAN(p).EQ.1) THEN + CALL RETURNANANFORTRAN(x) + CALL RETURNANANFORTRAN(sd) + CALL RETURNANANFORTRAN(mean) + RETURN + ENDIF + IF (.NOT. ((p.LE.0.0D0).OR. (p.GT.1.0D0))) GO TO 60 + IF (.NOT. (p.LE.0.0D0)) GO TO 40 + bound = 0.0D0 + GO TO 50 + + 40 bound = 1.0D0 + 50 status = -2 + RETURN + + 60 CONTINUE + 70 IF (which.EQ.1) GO TO 110 +C +C Q +C + IF (ISANAN(q).EQ.1) THEN + CALL RETURNANANFORTRAN(x) + CALL RETURNANANFORTRAN(sd) + CALL RETURNANANFORTRAN(mean) + RETURN + ENDIF + IF (.NOT. ((q.LE.0.0D0).OR. (q.GT.1.0D0))) GO TO 100 + IF (.NOT. (q.LE.0.0D0)) GO TO 80 + bound = 0.0D0 + GO TO 90 + + 80 bound = 1.0D0 + 90 status = -3 + RETURN + + 100 CONTINUE + 110 IF (which.EQ.1) GO TO 150 +C +C P + Q +C + pq = p + q + IF (.NOT. (abs(((pq)-0.5D0)-0.5D0).GT. + + (3.0D0*spmpar(1)))) GO TO 140 + IF (.NOT. (pq.LT.0.0D0)) GO TO 120 + bound = 0.0D0 + GO TO 130 + + 120 bound = 1.0D0 + 130 status = 3 + RETURN + + 140 CONTINUE + 150 IF (which.EQ.2) GO TO 160 +C +C X +C + IF (ISANAN(x).EQ.1) THEN + CALL RETURNANANFORTRAN(p) + CALL RETURNANANFORTRAN(q) + CALL RETURNANANFORTRAN(mean) + CALL RETURNANANFORTRAN(sd) + RETURN + ENDIF + IF (vfinite(1,x).EQ.0) then + IF (which.EQ.1) then + IF (x.GT.0) then + p = 1 + q = 0 + RETURN + ELSE + p = 0 + q = 1 + RETURN + ENDIF + ELSE + x = SIGN(inf,x) + ENDIF + ENDIF + + 160 IF (which.EQ.3) GO TO 170 +C +C MEAN +C + IF (ISANAN(mean).EQ.1) THEN + CALL RETURNANANFORTRAN(p) + CALL RETURNANANFORTRAN(q) + CALL RETURNANANFORTRAN(x) + CALL RETURNANANFORTRAN(sd) + RETURN + ENDIF + IF (vfinite(1,mean).EQ.0) mean = SIGN(inf,mean) + + 170 IF (which.EQ.4) GO TO 190 +C +C SD +C + IF (ISANAN(sd).EQ.1) THEN + CALL RETURNANANFORTRAN(p) + CALL RETURNANANFORTRAN(q) + CALL RETURNANANFORTRAN(x) + CALL RETURNANANFORTRAN(mean) + RETURN + ENDIF + IF (vfinite(1,sd).EQ.0) sd = SIGN(inf,sd) + IF (.NOT. (sd.LE.0.0D0)) GO TO 180 + bound = 0.0D0 + status = -6 + RETURN + + 180 CONTINUE +C +C Calculate ANSWERS +C + 190 IF ((1).EQ. (which)) THEN +C +C Computing P +C + z = (x-mean)/sd + CALL cumnor(z,p,q) + + ELSE IF ((2).EQ. (which)) THEN +C +C Computing X +C + z = dinvnr(p,q) + x = sd*z + mean + + ELSE IF ((3).EQ. (which)) THEN +C +C Computing the MEAN +C + z = dinvnr(p,q) + mean = x - sd*z + + ELSE IF ((4).EQ. (which)) THEN +C +C Computing SD +C + z = dinvnr(p,q) + sd = (x-mean)/z + END IF + + RETURN + + END diff --git a/modules/statistics/src/dcdflib/cdfnor.lo b/modules/statistics/src/dcdflib/cdfnor.lo new file mode 100755 index 000000000..7be6f5588 --- /dev/null +++ b/modules/statistics/src/dcdflib/cdfnor.lo @@ -0,0 +1,12 @@ +# src/dcdflib/cdfnor.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/cdfnor.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/statistics/src/dcdflib/cdfpoi.f b/modules/statistics/src/dcdflib/cdfpoi.f new file mode 100755 index 000000000..cb08bd470 --- /dev/null +++ b/modules/statistics/src/dcdflib/cdfpoi.f @@ -0,0 +1,289 @@ + SUBROUTINE cdfpoi(which,p,q,s,xlam,status,bound) +C********************************************************************** +C +C SUBROUTINE CDFPOI( WHICH, P, Q, S, XLAM, STATUS, BOUND ) +C Cumulative Distribution Function +C POIsson distribution +C +C +C Function +C +C +C Calculates any one parameter of the Poisson +C distribution given values for the others. +C +C +C Arguments +C +C +C WHICH --> Integer indicating which argument +C value is to be calculated from the others. +C Legal range: 1..3 +C iwhich = 1 : Calculate P and Q from S and XLAM +C iwhich = 2 : Calculate A from P,Q and XLAM +C iwhich = 3 : Calculate XLAM from P,Q and S +C INTEGER WHICH +C +C P <--> The cumulation from 0 to S of the poisson density. +C Input range: [0,1]. +C DOUBLE PRECISION P +C +C Q <--> 1-P. +C Input range: (0, 1]. +C P + Q = 1.0. +C DOUBLE PRECISION Q +C +C S <--> Upper limit of cumulation of the Poisson. +C Input range: [0, +infinity). +C Search range: [0,1E300] +C DOUBLE PRECISION S +C +C XLAM <--> Mean of the Poisson distribution. +C Input range: [0, +infinity). +C Search range: [0,1E300] +C DOUBLE PRECISION XLAM +C +C STATUS <-- 0 if calculation completed correctly +C -I if input parameter number I is out of range +C 1 if answer appears to be lower than lowest +C search bound +C 2 if answer appears to be higher than greatest +C search bound +C 3 if P + Q .ne. 1 +C INTEGER STATUS +C +C BOUND <-- Undefined if STATUS is 0 +C +C Bound exceeded by parameter number I if STATUS +C is negative. +C +C Lower search bound if STATUS is 1. +C +C Upper search bound if STATUS is 2. +C +C +C Method +C +C +C Formula 26.4.21 of Abramowitz and Stegun, Handbook of +C Mathematical Functions (1966) is used to reduce the computation +C of the cumulative distribution function to that of computing a +C chi-square, hence an incomplete gamma function. +C +C Cumulative distribution function (P) is calculated directly. +C Computation of other parameters involve a search for a value that +C produces the desired value of P. The search relies on the +C monotonicity of P with the other parameter. +C +C +C********************************************************************** +C .. Parameters .. + DOUBLE PRECISION tol + PARAMETER (tol=1.0D-13) + DOUBLE PRECISION atol + PARAMETER (atol=1.0D-50) + DOUBLE PRECISION inf + PARAMETER (inf=1.0D300) +C .. +C .. Scalar Arguments .. + DOUBLE PRECISION bound,p,q,s,xlam + INTEGER status,which +C .. +C .. Local Scalars .. + DOUBLE PRECISION fx,cum,ccum,pq + LOGICAL qhi,qleft,qporq +C .. +C .. External Functions .. + INTEGER vfinite + DOUBLE PRECISION spmpar + EXTERNAL spmpar +C .. +C .. External Subroutines .. + EXTERNAL dinvr,dstinv,cumpoi +C .. +C .. Executable Statements .. +C +C Check arguments +C + IF (.NOT. ((which.LT.1).OR. (which.GT.3))) GO TO 30 + IF (.NOT. (which.LT.1)) GO TO 10 + bound = 1.0D0 + GO TO 20 + + 10 bound = 3.0D0 + 20 status = -1 + RETURN + + 30 IF (which.EQ.1) GO TO 70 +C +C P +C + IF (ISANAN(p).EQ.1) THEN + CALL RETURNANANFORTRAN(s) + CALL RETURNANANFORTRAN(xlam) + RETURN + ENDIF + IF (.NOT. ((p.LT.0.0D0).OR. (p.GT.1.0D0))) GO TO 60 + IF (.NOT. (p.LT.0.0D0)) GO TO 40 + bound = 0.0D0 + GO TO 50 + + 40 bound = 1.0D0 + 50 status = -2 + RETURN + + 60 CONTINUE + 70 IF (which.EQ.1) GO TO 110 +C +C Q +C + IF (ISANAN(q).EQ.1) THEN + CALL RETURNANANFORTRAN(s) + CALL RETURNANANFORTRAN(xlam) + RETURN + ENDIF + IF (.NOT. ((q.LE.0.0D0).OR. (q.GT.1.0D0))) GO TO 100 + IF (.NOT. (q.LE.0.0D0)) GO TO 80 + bound = 0.0D0 + GO TO 90 + + 80 bound = 1.0D0 + 90 status = -3 + RETURN + + 100 CONTINUE + 110 IF (which.EQ.2) GO TO 130 +C +C S +C + IF (ISANAN(s).EQ.1) THEN + CALL RETURNANANFORTRAN(p) + CALL RETURNANANFORTRAN(q) + CALL RETURNANANFORTRAN(xlam) + RETURN + ENDIF + IF (vfinite(1,s).EQ.0) then + IF (which.EQ.1) then + IF (s.GT.0) then + p = 1 + q = 0 + RETURN + ENDIF + ELSE + s = SIGN(1D300,s) + ENDIF + ENDIF + IF (.NOT. (s.LT.0.0D0)) GO TO 120 + bound = 0.0D0 + status = -4 + RETURN + + 120 CONTINUE + 130 IF (which.EQ.3) GO TO 150 +C +C XLAM +C + IF (ISANAN(xlam).EQ.1) THEN + CALL RETURNANANFORTRAN(p) + CALL RETURNANANFORTRAN(q) + CALL RETURNANANFORTRAN(s) + RETURN + ENDIF + IF (vfinite(1,xlam).EQ.0) xlam = SIGN(inf,xlam) + IF (.NOT. (xlam.LT.0.0D0)) GO TO 140 + bound = 0.0D0 + status = -5 + RETURN + + 140 CONTINUE + 150 IF (which.EQ.1) GO TO 190 +C +C P + Q +C + pq = p + q + IF (.NOT. (abs(((pq)-0.5D0)-0.5D0).GT. + + (3.0D0*spmpar(1)))) GO TO 180 + IF (.NOT. (pq.LT.0.0D0)) GO TO 160 + bound = 0.0D0 + GO TO 170 + + 160 bound = 1.0D0 + 170 status = 3 + RETURN + + 180 CONTINUE + 190 IF (.NOT. (which.EQ.1)) qporq = p .LE. q +C +C Select the minimum of P or Q +C +C +C Calculate ANSWERS +C + IF ((1).EQ. (which)) THEN +C +C Calculating P +C + CALL cumpoi(s,xlam,p,q) + status = 0 + + ELSE IF ((2).EQ. (which)) THEN +C +C Calculating S +C + s = 5.0D0 + CALL dstinv(0.0D0,inf,0.5D0,0.5D0,5.0D0,atol,tol) + status = 0 + CALL dinvr(status,s,fx,qleft,qhi) + 200 IF (.NOT. (status.EQ.1)) GO TO 230 + CALL cumpoi(s,xlam,cum,ccum) + IF (.NOT. (qporq)) GO TO 210 + fx = cum - p + GO TO 220 + + 210 fx = ccum - q + 220 CALL dinvr(status,s,fx,qleft,qhi) + GO TO 200 + + 230 IF (.NOT. (status.EQ.-1)) GO TO 260 + IF (.NOT. (qleft)) GO TO 240 + status = 1 + bound = 0.0D0 + GO TO 250 + + 240 status = 2 + bound = inf + 250 CONTINUE + 260 CONTINUE + + ELSE IF ((3).EQ. (which)) THEN +C +C Calculating XLAM +C + xlam = 5.0D0 + CALL dstinv(0.0D0,inf,0.5D0,0.5D0,5.0D0,atol,tol) + status = 0 + CALL dinvr(status,xlam,fx,qleft,qhi) + 270 IF (.NOT. (status.EQ.1)) GO TO 300 + CALL cumpoi(s,xlam,cum,ccum) + IF (.NOT. (qporq)) GO TO 280 + fx = cum - p + GO TO 290 + + 280 fx = ccum - q + 290 CALL dinvr(status,xlam,fx,qleft,qhi) + GO TO 270 + + 300 IF (.NOT. (status.EQ.-1)) GO TO 330 + IF (.NOT. (qleft)) GO TO 310 + status = 1 + bound = 0.0D0 + GO TO 320 + + 310 status = 2 + bound = inf + 320 CONTINUE + 330 END IF + + RETURN + + END diff --git a/modules/statistics/src/dcdflib/cdfpoi.lo b/modules/statistics/src/dcdflib/cdfpoi.lo new file mode 100755 index 000000000..8dbe5655e --- /dev/null +++ b/modules/statistics/src/dcdflib/cdfpoi.lo @@ -0,0 +1,12 @@ +# src/dcdflib/cdfpoi.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/cdfpoi.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/statistics/src/dcdflib/cdft.f b/modules/statistics/src/dcdflib/cdft.f new file mode 100755 index 000000000..917091f3f --- /dev/null +++ b/modules/statistics/src/dcdflib/cdft.f @@ -0,0 +1,290 @@ + SUBROUTINE cdft(which,p,q,t,df,status,bound) +C********************************************************************** +C +C SUBROUTINE CDFT( WHICH, P, Q, T, DF, STATUS, BOUND ) +C Cumulative Distribution Function +C T distribution +C +C +C Function +C +C +C Calculates any one parameter of the t distribution given +C values for the others. +C +C +C Arguments +C +C +C WHICH --> Integer indicating which argument +C values is to be calculated from the others. +C Legal range: 1..3 +C iwhich = 1 : Calculate P and Q from T and DF +C iwhich = 2 : Calculate T from P,Q and DF +C iwhich = 3 : Calculate DF from P,Q and T +C INTEGER WHICH +C +C P <--> The integral from -infinity to t of the t-density. +C Input range: (0,1]. +C DOUBLE PRECISION P +C +C Q <--> 1-P. +C Input range: (0, 1]. +C P + Q = 1.0. +C DOUBLE PRECISION Q +C +C T <--> Upper limit of integration of the t-density. +C Input range: ( -infinity, +infinity). +C Search range: [ -1E150, 1E150 ] +C DOUBLE PRECISION T +C +C DF <--> Degrees of freedom of the t-distribution. +C Input range: (0 , +infinity). +C Search range: [1e-300, 1E10] +C DOUBLE PRECISION DF +C +C STATUS <-- 0 if calculation completed correctly +C -I if input parameter number I is out of range +C 1 if answer appears to be lower than lowest +C search bound +C 2 if answer appears to be higher than greatest +C search bound +C 3 if P + Q .ne. 1 +C INTEGER STATUS +C +C BOUND <-- Undefined if STATUS is 0 +C +C Bound exceeded by parameter number I if STATUS +C is negative. +C +C Lower search bound if STATUS is 1. +C +C Upper search bound if STATUS is 2. +C +C +C Method +C +C +C Formula 26.5.27 of Abramowitz and Stegun, Handbook of +C Mathematical Functions (1966) is used to reduce the computation +C of the cumulative distribution function to that of an incomplete +C beta. +C +C Computation of other parameters involve a search for a value that +C produces the desired value of P. The search relies on the +C monotonicity of P with the other parameter. +C +C********************************************************************** +C .. Parameters .. + DOUBLE PRECISION tol + PARAMETER (tol=1.0D-13) + DOUBLE PRECISION atol + PARAMETER (atol=1.0D-50) + DOUBLE PRECISION zero,inf + PARAMETER (zero=1.0D-300,inf=1.0D300) + DOUBLE PRECISION rtinf + PARAMETER (rtinf=1.0D150) + DOUBLE PRECISION maxdf + PARAMETER (maxdf=1.0d10) +C .. +C .. Scalar Arguments .. + DOUBLE PRECISION bound,df,p,q,t + INTEGER status,which +C .. +C .. Local Scalars .. + DOUBLE PRECISION fx,cum,ccum,pq + LOGICAL qhi,qleft,qporq +C .. +C .. External Functions .. + INTEGER vfinite + DOUBLE PRECISION spmpar,dt1 + EXTERNAL spmpar,dt1 +C .. +C .. External Subroutines .. + EXTERNAL dinvr,dstinv,cumt +C .. +C .. Executable Statements .. +C +C Check arguments +C + IF (.NOT. ((which.LT.1).OR. (which.GT.3))) GO TO 30 + IF (.NOT. (which.LT.1)) GO TO 10 + bound = 1.0D0 + GO TO 20 + + 10 bound = 3.0D0 + 20 status = -1 + RETURN + + 30 IF (which.EQ.1) GO TO 70 +C +C P +C + IF (ISANAN(p).EQ.1) THEN + CALL RETURNANANFORTRAN(t) + CALL RETURNANANFORTRAN(df) + RETURN + ENDIF + IF (.NOT. ((p.LE.0.0D0).OR. (p.GT.1.0D0))) GO TO 60 + IF (.NOT. (p.LE.0.0D0)) GO TO 40 + bound = 0.0D0 + GO TO 50 + + 40 bound = 1.0D0 + 50 status = -2 + RETURN + + 60 CONTINUE + 70 IF (which.EQ.1) GO TO 110 +C +C Q +C + IF (ISANAN(q).EQ.1) THEN + CALL RETURNANANFORTRAN(t) + CALL RETURNANANFORTRAN(df) + RETURN + ENDIF + IF (.NOT. ((q.LE.0.0D0).OR. (q.GT.1.0D0))) GO TO 100 + IF (.NOT. (q.LE.0.0D0)) GO TO 80 + bound = 0.0D0 + GO TO 90 + + 80 bound = 1.0D0 + 90 status = -3 + RETURN + + 100 CONTINUE + 110 IF (which.EQ.3) GO TO 130 +C +C T +C + IF (ISANAN(t).EQ.1) THEN + CALL RETURNANANFORTRAN(p) + CALL RETURNANANFORTRAN(q) + CALL RETURNANANFORTRAN(df) + RETURN + ENDIF + IF (vfinite(1,t).EQ.0) then + IF (which.EQ.1) then + IF (t.GT.0) then + p = 1 + q = 0 + RETURN + ELSE + p = 0 + q = 1 + RETURN + ENDIF + ELSE + t = SIGN(1D300,t) + ENDIF + ENDIF +C +C DF +C + IF (ISANAN(df).EQ.1) THEN + CALL RETURNANANFORTRAN(p) + CALL RETURNANANFORTRAN(q) + CALL RETURNANANFORTRAN(t) + RETURN + ENDIF + IF (vfinite(1,df).EQ.0) df = SIGN(inf,df) + IF (.NOT. (df.LE.0.0D0)) GO TO 120 + bound = 0.0D0 + status = -5 + RETURN + + 120 CONTINUE + 130 IF (which.EQ.1) GO TO 170 +C +C P + Q +C + pq = p + q + IF (.NOT. (abs(((pq)-0.5D0)-0.5D0).GT. + + (3.0D0*spmpar(1)))) GO TO 160 + IF (.NOT. (pq.LT.0.0D0)) GO TO 140 + bound = 0.0D0 + GO TO 150 + + 140 bound = 1.0D0 + 150 status = 3 + RETURN + + 160 CONTINUE + 170 IF (.NOT. (which.EQ.1)) qporq = p .LE. q +C +C Select the minimum of P or Q +C +C +C Calculate ANSWERS +C + IF ((1).EQ. (which)) THEN +C +C Computing P and Q +C + CALL cumt(t,df,p,q) + status = 0 + + ELSE IF ((2).EQ. (which)) THEN +C +C Computing T +C +C .. Get initial approximation for T +C + t = dt1(p,q,df) + CALL dstinv(-rtinf,rtinf,0.5D0,0.5D0,5.0D0,atol,tol) + status = 0 + CALL dinvr(status,t,fx,qleft,qhi) + 180 IF (.NOT. (status.EQ.1)) GO TO 210 + CALL cumt(t,df,cum,ccum) + IF (.NOT. (qporq)) GO TO 190 + fx = cum - p + GO TO 200 + + 190 fx = ccum - q + 200 CALL dinvr(status,t,fx,qleft,qhi) + GO TO 180 + + 210 IF (.NOT. (status.EQ.-1)) GO TO 240 + IF (.NOT. (qleft)) GO TO 220 + status = 1 + bound = -rtinf + GO TO 230 + + 220 status = 2 + bound = rtinf + 230 CONTINUE + 240 CONTINUE + + ELSE IF ((3).EQ. (which)) THEN +C +C Computing DF +C + df = 5.0D0 + CALL dstinv(zero,maxdf,0.5D0,0.5D0,5.0D0,atol,tol) + status = 0 + CALL dinvr(status,df,fx,qleft,qhi) + 250 IF (.NOT. (status.EQ.1)) GO TO 280 + CALL cumt(t,df,cum,ccum) + IF (.NOT. (qporq)) GO TO 260 + fx = cum - p + GO TO 270 + + 260 fx = ccum - q + 270 CALL dinvr(status,df,fx,qleft,qhi) + GO TO 250 + + 280 IF (.NOT. (status.EQ.-1)) GO TO 310 + IF (.NOT. (qleft)) GO TO 290 + status = 1 + bound = zero + GO TO 300 + + 290 status = 2 + bound = maxdf + 300 CONTINUE + 310 END IF + + RETURN + + END diff --git a/modules/statistics/src/dcdflib/cdft.lo b/modules/statistics/src/dcdflib/cdft.lo new file mode 100755 index 000000000..1cb0acedf --- /dev/null +++ b/modules/statistics/src/dcdflib/cdft.lo @@ -0,0 +1,12 @@ +# src/dcdflib/cdft.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/cdft.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/statistics/src/dcdflib/cumbet.f b/modules/statistics/src/dcdflib/cumbet.f new file mode 100755 index 000000000..b7a1242ca --- /dev/null +++ b/modules/statistics/src/dcdflib/cumbet.f @@ -0,0 +1,78 @@ + SUBROUTINE cumbet(x,y,a,b,cum,ccum) +C********************************************************************** +C +C SUBROUTINE CUMBET(X,Y,A,B,CUM,CCUM) +C Double precision cUMulative incomplete BETa distribution +C +C +C Function +C +C +C Calculates the cdf to X of the incomplete beta distribution +C with parameters a and b. This is the integral from 0 to x +C of (1/B(a,b))*f(t)) where f(t) = t**(a-1) * (1-t)**(b-1) +C +C +C Arguments +C +C +C X --> Upper limit of integration. +C X is DOUBLE PRECISION +C +C Y --> 1 - X. +C Y is DOUBLE PRECISION +C +C A --> First parameter of the beta distribution. +C A is DOUBLE PRECISION +C +C B --> Second parameter of the beta distribution. +C B is DOUBLE PRECISION +C +C CUM <-- Cumulative incomplete beta distribution. +C CUM is DOUBLE PRECISION +C +C CCUM <-- Compliment of Cumulative incomplete beta distribution. +C CCUM is DOUBLE PRECISION +C +C +C Method +C +C +C Calls the routine BRATIO. +C +C References +C +C Didonato, Armido R. and Morris, Alfred H. Jr. (1992) Algorithim +C 708 Significant Digit Computation of the Incomplete Beta Function +C Ratios. ACM ToMS, Vol.18, No. 3, Sept. 1992, 360-373. +C +C********************************************************************** + +C .. Scalar Arguments .. + DOUBLE PRECISION x,y,a,b,cum,ccum +C .. +C .. Local Scalars .. + INTEGER ierr +C .. +C .. External Routines .. + EXTERNAL bratio +C .. +C .. Executable Statements .. + IF (.NOT. (x.LE.0.0D0)) GO TO 10 + cum = 0.0D0 + ccum = 1.0D0 + RETURN + + 10 IF (.NOT. (y.LE.0.0D0)) GO TO 20 + cum = 1.0D0 + ccum = 0.0D0 + RETURN + + 20 CALL bratio(a,b,x,y,cum,ccum,ierr) + +C Call bratio routine + + + RETURN + + END diff --git a/modules/statistics/src/dcdflib/cumbet.lo b/modules/statistics/src/dcdflib/cumbet.lo new file mode 100755 index 000000000..c04ad6df7 --- /dev/null +++ b/modules/statistics/src/dcdflib/cumbet.lo @@ -0,0 +1,12 @@ +# src/dcdflib/cumbet.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/cumbet.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/statistics/src/dcdflib/cumbin.f b/modules/statistics/src/dcdflib/cumbin.f new file mode 100755 index 000000000..7fc721e57 --- /dev/null +++ b/modules/statistics/src/dcdflib/cumbin.f @@ -0,0 +1,61 @@ + SUBROUTINE cumbin(s,xn,pr,ompr,cum,ccum) +C********************************************************************** +C +C SUBROUTINE CUMBIN(S,XN,PBIN,OMPR,CUM,CCUM) +C CUmulative BINomial distribution +C +C +C Function +C +C +C Returns the probability of 0 to S successes in XN binomial +C trials, each of which has a probability of success, PBIN. +C +C +C Arguments +C +C +C S --> The upper limit of cumulation of the binomial distribution. +C S is DOUBLE PRECISION +C +C XN --> The number of binomial trials. +C XN is DOUBLE PRECISIO +C +C PBIN --> The probability of success in each binomial trial. +C PBIN is DOUBLE PRECIS +C +C OMPR --> 1 - PBIN +C OMPR is DOUBLE PRECIS +C +C CUM <-- Cumulative binomial distribution. +C CUM is DOUBLE PRECISI +C +C CCUM <-- Compliment of Cumulative binomial distribution. +C CCUM is DOUBLE PRECIS + +C +C +C Method +C +C +C Formula 26.5.24 of Abramowitz and Stegun, Handbook of +C Mathematical Functions (1966) is used to reduce the binomial +C distribution to the cumulative beta distribution. +C +C********************************************************************** +C .. Scalar Arguments .. + DOUBLE PRECISION pr,ompr,s,xn,cum,ccum +C .. +C .. External Subroutines .. + EXTERNAL cumbet +C .. +C .. Executable Statements .. + IF (.NOT. (s.LT.xn)) GO TO 10 + CALL cumbet(pr,ompr,s+1.0D0,xn-s,ccum,cum) + GO TO 20 + + 10 cum = 1.0D0 + ccum = 0.0D0 + 20 RETURN + + END diff --git a/modules/statistics/src/dcdflib/cumbin.lo b/modules/statistics/src/dcdflib/cumbin.lo new file mode 100755 index 000000000..df9437dcc --- /dev/null +++ b/modules/statistics/src/dcdflib/cumbin.lo @@ -0,0 +1,12 @@ +# src/dcdflib/cumbin.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/cumbin.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/statistics/src/dcdflib/cumchi.f b/modules/statistics/src/dcdflib/cumchi.f new file mode 100755 index 000000000..5471b8120 --- /dev/null +++ b/modules/statistics/src/dcdflib/cumchi.f @@ -0,0 +1,53 @@ + SUBROUTINE cumchi(x,df,cum,ccum) +C********************************************************************** +C +C SUBROUTINE FUNCTION CUMCHI(X,DF,CUM,CCUM) +C CUMulative of the CHi-square distribution +C +C +C Function +C +C +C Calculates the cumulative chi-square distribution. +C +C +C Arguments +C +C +C X --> Upper limit of integration of the +C chi-square distribution. +C X is DOUBLE PRECISION +C +C DF --> Degrees of freedom of the +C chi-square distribution. +C DF is DOUBLE PRECISION +C +C CUM <-- Cumulative chi-square distribution. +C CUM is DOUBLE PRECISIO +C +C CCUM <-- Compliment of Cumulative chi-square distribution. +C CCUM is DOUBLE PRECISI +C +C +C Method +C +C +C Calls incomplete gamma function (CUMGAM) +C +C********************************************************************** +C .. Scalar Arguments .. + DOUBLE PRECISION df,x,cum,ccum +C .. +C .. Local Scalars .. + DOUBLE PRECISION a,xx +C .. +C .. External Subroutines .. + EXTERNAL cumgam +C .. +C .. Executable Statements .. + a = df*0.5D0 + xx = x*0.5D0 + CALL cumgam(xx,a,cum,ccum) + RETURN + + END diff --git a/modules/statistics/src/dcdflib/cumchi.lo b/modules/statistics/src/dcdflib/cumchi.lo new file mode 100755 index 000000000..7c43aef69 --- /dev/null +++ b/modules/statistics/src/dcdflib/cumchi.lo @@ -0,0 +1,12 @@ +# src/dcdflib/cumchi.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/cumchi.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/statistics/src/dcdflib/cumchn.f b/modules/statistics/src/dcdflib/cumchn.f new file mode 100755 index 000000000..1e6ba50df --- /dev/null +++ b/modules/statistics/src/dcdflib/cumchn.f @@ -0,0 +1,244 @@ + SUBROUTINE cumchn(x,df,pnonc,cum,ccum) +C********************************************************************** +C +C SUBROUTINE CUMCHN(X,DF,PNONC,CUM,CCUM) +C CUMulative of the Non-central CHi-square distribution +C +C +C Function +C +C +C Calculates the cumulative non-central chi-square +C distribution, i.e., the probability that a random variable +C which follows the non-central chi-square distribution, with +C non-centrality parameter PNONC and continuous degrees of +C freedom DF, is less than or equal to X. +C +C +C Arguments +C +C +C X --> Upper limit of integration of the non-central +C chi-square distribution. +C X is DOUBLE PRECISION +C +C DF --> Degrees of freedom of the non-central +C chi-square distribution. +C DF is DOUBLE PRECISION +C +C PNONC --> Non-centrality parameter of the non-central +C chi-square distribution. +C PNONC is DOUBLE PRECIS +C +C CUM <-- Cumulative non-central chi-square distribution. +C CUM is DOUBLE PRECISIO +C +C CCUM <-- Compliment of Cumulative non-central chi-square distribut +C CCUM is DOUBLE PRECISI + +C +C +C Method +C +C +C Uses formula 26.4.25 of Abramowitz and Stegun, Handbook of +C Mathematical Functions, US NBS (1966) to calculate the +C non-central chi-square. +C +C +C Variables +C +C +C EPS --- Convergence criterion. The sum stops when a +C term is less than EPS*SUM. +C EPS is DOUBLE PRECISIO +C +C NTIRED --- Maximum number of terms to be evaluated +C in each sum. +C NTIRED is INTEGER +C +C QCONV --- .TRUE. if convergence achieved - +C i.e., program did not stop on NTIRED criterion. +C QCONV is LOGICAL +C +C CCUM <-- Compliment of Cumulative non-central +C chi-square distribution. +C CCUM is DOUBLE PRECISI +C +C********************************************************************** +C +C +C .. Scalar Arguments .. + DOUBLE PRECISION df,pnonc,x,cum,ccum +C .. +C .. Local Scalars .. + DOUBLE PRECISION adj,centaj,centwt,chid2,dfd2,eps,lcntaj,lcntwt, + + lfact,pcent,pterm,sum,sumadj,term,wt,xnonc,xx + INTEGER i,icent,iterb,iterf,ntired +C .. +C .. External Functions .. + DOUBLE PRECISION alngam + EXTERNAL alngam +C .. +C .. External Subroutines .. + EXTERNAL cumchi +C .. +C .. Intrinsic Functions .. + INTRINSIC log,exp,dble,int +C .. +C .. Statement Functions .. + DOUBLE PRECISION dg + LOGICAL qsmall,qtired +C .. +C .. Data statements .. + DATA ntired,eps/1000,1.0D-5/ +C .. +C .. Statement Function definitions .. + qtired(i) = i .GT. ntired + qsmall(xx) = sum .LT. 1.0D-20 .OR. xx .LT. eps*sum + dg(i) = df + 2.0D0*dble(i) +C .. +C .. Executable Statements .. +C + IF (.NOT. (x.LE.0.0D0)) GO TO 10 + cum = 0.0D0 + ccum = 1.0D0 + RETURN + + 10 IF (.NOT. (pnonc.LE.1.0D-10)) GO TO 20 +C +C +C When non-centrality parameter is (essentially) zero, +C use cumulative chi-square distribution +C +C + CALL cumchi(x,df,cum,ccum) + RETURN + + 20 xnonc = pnonc/2.0D0 +C********************************************************************** +C +C The following code calcualtes the weight, chi-square, and +C adjustment term for the central term in the infinite series. +C The central term is the one in which the poisson weight is +C greatest. The adjustment term is the amount that must +C be subtracted from the chi-square to move up two degrees +C of freedom. +C +C********************************************************************** + icent = int(xnonc) + IF (icent.EQ.0) icent = 1 + chid2 = x/2.0D0 +C +C +C Calculate central weight term +C +C + lfact = alngam(dble(icent+1)) + lcntwt = -xnonc + icent*log(xnonc) - lfact + centwt = exp(lcntwt) +C +C +C Calculate central chi-square +C +C + CALL cumchi(x,dg(icent),pcent,ccum) +C +C +C Calculate central adjustment term +C +C + dfd2 = dg(icent)/2.0D0 + lfact = alngam(1.0D0+dfd2) + lcntaj = dfd2*log(chid2) - chid2 - lfact + centaj = exp(lcntaj) + sum = centwt*pcent +C********************************************************************** +C +C Sum backwards from the central term towards zero. +C Quit whenever either +C (1) the zero term is reached, or +C (2) the term gets small relative to the sum, or +C (3) More than NTIRED terms are totaled. +C +C********************************************************************** + iterb = 0 + sumadj = 0.0D0 + adj = centaj + wt = centwt + i = icent +C + GO TO 40 + + 30 IF (qtired(iterb) .OR. qsmall(term) .OR. i.EQ.0) GO TO 50 + 40 dfd2 = dg(i)/2.0D0 +C +C +C Adjust chi-square for two fewer degrees of freedom. +C The adjusted value ends up in PTERM. +C +C + adj = adj*dfd2/chid2 + sumadj = sumadj + adj + pterm = pcent + sumadj +C +C +C Adjust poisson weight for J decreased by one +C +C + wt = wt* (i/xnonc) + term = wt*pterm + sum = sum + term + i = i - 1 + iterb = iterb + 1 + GO TO 30 + + 50 iterf = 0 +C********************************************************************** +C +C Now sum forward from the central term towards infinity. +C Quit when either +C (1) the term gets small relative to the sum, or +C (2) More than NTIRED terms are totaled. +C +C********************************************************************** + sumadj = centaj + adj = centaj + wt = centwt + i = icent +C + GO TO 70 + + 60 IF (qtired(iterf) .OR. qsmall(term)) GO TO 80 +C +C +C Update weights for next higher J +C +C + 70 wt = wt* (xnonc/ (i+1)) +C +C +C Calculate PTERM and add term to sum +C +C + pterm = pcent - sumadj + term = wt*pterm + sum = sum + term +C +C +C Update adjustment term for DF for next iteration +C +C + i = i + 1 + dfd2 = dg(i)/2.0D0 + adj = adj*chid2/dfd2 + sumadj = sumadj + adj + iterf = iterf + 1 + GO TO 60 + + 80 cum = sum + ccum = 0.5D0 + (0.5D0-cum) +C + RETURN + + END diff --git a/modules/statistics/src/dcdflib/cumchn.lo b/modules/statistics/src/dcdflib/cumchn.lo new file mode 100755 index 000000000..70c5981d3 --- /dev/null +++ b/modules/statistics/src/dcdflib/cumchn.lo @@ -0,0 +1,12 @@ +# src/dcdflib/cumchn.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/cumchn.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/statistics/src/dcdflib/cumf.f b/modules/statistics/src/dcdflib/cumf.f new file mode 100755 index 000000000..84c758bab --- /dev/null +++ b/modules/statistics/src/dcdflib/cumf.f @@ -0,0 +1,93 @@ + SUBROUTINE cumf(f,dfn,dfd,cum,ccum) +C********************************************************************** +C +C SUBROUTINE CUMF(F,DFN,DFD,CUM,CCUM) +C CUMulative F distribution +C +C +C Function +C +C +C Computes the integral from 0 to F of the f-density with DFN +C and DFD degrees of freedom. +C +C +C Arguments +C +C +C F --> Upper limit of integration of the f-density. +C F is DOUBLE PRECISION +C +C DFN --> Degrees of freedom of the numerator sum of squares. +C DFN is DOUBLE PRECISI +C +C DFD --> Degrees of freedom of the denominator sum of squares. +C DFD is DOUBLE PRECISI +C +C CUM <-- Cumulative f distribution. +C CUM is DOUBLE PRECISI +C +C CCUM <-- Compliment of Cumulative f distribution. +C CCUM is DOUBLE PRECIS +C +C +C Method +C +C +C Formula 26.5.28 of Abramowitz and Stegun is used to reduce +C the cumulative F to a cumulative beta distribution. +C +C +C Note +C +C +C If F is less than or equal to 0, 0 is returned. +C +C********************************************************************** +C .. Scalar Arguments .. + DOUBLE PRECISION dfd,dfn,f,cum,ccum +C .. +C .. Local Scalars .. + + DOUBLE PRECISION dsum,prod,xx,yy + INTEGER ierr +C .. +C .. Parameters .. + DOUBLE PRECISION half + PARAMETER (half=0.5D0) + DOUBLE PRECISION done + PARAMETER (done=1.0D0) +C .. +C .. External Subroutines .. + EXTERNAL bratio +C .. +C .. Executable Statements .. + + IF (.NOT. (f.LE.0.0D0)) GO TO 10 + cum = 0.0D0 + ccum = 1.0D0 + RETURN + + 10 prod = dfn*f +C +C XX is such that the incomplete beta with parameters +C DFD/2 and DFN/2 evaluated at XX is 1 - CUM or CCUM +C +C YY is 1 - XX +C +C Calculate the smaller of XX and YY accurately +C + dsum = dfd + prod + xx = dfd/dsum + IF (xx.GT.half) THEN + yy = prod/dsum + xx = done - yy + + ELSE + yy = done - xx + END IF + + CALL bratio(dfd*half,dfn*half,xx,yy,ccum,cum,ierr) + RETURN + + END diff --git a/modules/statistics/src/dcdflib/cumf.lo b/modules/statistics/src/dcdflib/cumf.lo new file mode 100755 index 000000000..b4be11707 --- /dev/null +++ b/modules/statistics/src/dcdflib/cumf.lo @@ -0,0 +1,12 @@ +# src/dcdflib/cumf.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/cumf.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/statistics/src/dcdflib/cumfnc.f b/modules/statistics/src/dcdflib/cumfnc.f new file mode 100755 index 000000000..6d8675445 --- /dev/null +++ b/modules/statistics/src/dcdflib/cumfnc.f @@ -0,0 +1,189 @@ + SUBROUTINE cumfnc(f,dfn,dfd,pnonc,cum,ccum) +C********************************************************************** +C +C F -NON- -C-ENTRAL F DISTRIBUTION +C +C +C +C Function +C +C +C COMPUTES NONCENTRAL F DISTRIBUTION WITH DFN AND DFD +C DEGREES OF FREEDOM AND NONCENTRALITY PARAMETER PNONC +C +C +C Arguments +C +C +C X --> UPPER LIMIT OF INTEGRATION OF NONCENTRAL F IN EQUATION +C +C DFN --> DEGREES OF FREEDOM OF NUMERATOR +C +C DFD --> DEGREES OF FREEDOM OF DENOMINATOR +C +C PNONC --> NONCENTRALITY PARAMETER. +C +C CUM <-- CUMULATIVE NONCENTRAL F DISTRIBUTION +C +C CCUM <-- COMPLIMENT OF CUMMULATIVE +C +C +C Method +C +C +C USES FORMULA 26.6.20 OF REFERENCE FOR INFINITE SERIES. +C SERIES IS CALCULATED BACKWARD AND FORWARD FROM J = LAMBDA/2 +C (THIS IS THE TERM WITH THE LARGEST POISSON WEIGHT) UNTIL +C THE CONVERGENCE CRITERION IS MET. +C +C FOR SPEED, THE INCOMPLETE BETA FUNCTIONS ARE EVALUATED +C BY FORMULA 26.5.16. +C +C +C REFERENCE +C +C +C HANDBOOD OF MATHEMATICAL FUNCTIONS +C EDITED BY MILTON ABRAMOWITZ AND IRENE A. STEGUN +C NATIONAL BUREAU OF STANDARDS APPLIED MATEMATICS SERIES - 55 +C MARCH 1965 +C P 947, EQUATIONS 26.6.17, 26.6.18 +C +C +C Note +C +C +C THE SUM CONTINUES UNTIL A SUCCEEDING TERM IS LESS THAN EPS +C TIMES THE SUM (OR THE SUM IS LESS THAN 1.0E-20). EPS IS +C SET TO 1.0E-4 IN A DATA STATEMENT WHICH CAN BE CHANGED. +C +C********************************************************************** + +C .. Scalar Arguments .. + DOUBLE PRECISION dfd,dfn,pnonc,f,cum,ccum +C .. +C .. Local Scalars .. + DOUBLE PRECISION dsum,dummy,prod,xx,yy + DOUBLE PRECISION adn,aup,b,betdn,betup,centwt,dnterm,eps,sum, + + upterm,xmult,xnonc,x + INTEGER i,icent,ierr +C .. +C .. External Functions .. + DOUBLE PRECISION alngam + EXTERNAL alngam +C .. +C .. Intrinsic Functions .. + INTRINSIC log,dble,exp +C .. +C .. Statement Functions .. + LOGICAL qsmall +C .. +C .. External Subroutines .. + EXTERNAL bratio,cumf +C .. +C .. Parameters .. + DOUBLE PRECISION half + PARAMETER (half=0.5D0) + DOUBLE PRECISION done + PARAMETER (done=1.0D0) +C .. +C .. Data statements .. + DATA eps/1.0D-4/ +C .. +C .. Statement Function definitions .. + qsmall(x) = sum .LT. 1.0D-20 .OR. x .LT. eps*sum +C .. +C .. Executable Statements .. +C + IF (.NOT. (f.LE.0.0D0)) GO TO 10 + cum = 0.0D0 + ccum = 1.0D0 + RETURN + + 10 IF (.NOT. (pnonc.LT.1.0D-10)) GO TO 20 +C +C Handle case in which the non-centrality parameter is +C (essentially) zero. + + CALL cumf(f,dfn,dfd,cum,ccum) + RETURN + + 20 xnonc = pnonc/2.0D0 + +C Calculate the central term of the poisson weighting factor. + + icent = xnonc + IF (icent.EQ.0) icent = 1 + +C Compute central weight term + + centwt = exp(-xnonc+icent*log(xnonc)-alngam(dble(icent+1))) + +C Compute central incomplete beta term +C Assure that minimum of arg to beta and 1 - arg is computed +C accurately. + + prod = dfn*f + dsum = dfd + prod + yy = dfd/dsum + IF (yy.GT.half) THEN + xx = prod/dsum + yy = done - xx + + ELSE + xx = done - yy + END IF + + CALL bratio(dfn*half+dble(icent),dfd*half,xx,yy,betdn,dummy,ierr) + adn = dfn/2.0D0 + dble(icent) + aup = adn + b = dfd/2.0D0 + betup = betdn + sum = centwt*betdn + +C Now sum terms backward from icent until convergence or all done + + xmult = centwt + i = icent + dnterm = exp(alngam(adn+b)-alngam(adn+1.0D0)-alngam(b)+ + + adn*log(xx)+b*log(yy)) + 30 IF (qsmall(xmult*betdn) .OR. i.LE.0) GO TO 40 + xmult = xmult* (i/xnonc) + i = i - 1 + adn = adn - 1 + dnterm = (adn+1)/ ((adn+b)*xx)*dnterm + betdn = betdn + dnterm + sum = sum + xmult*betdn + GO TO 30 + + 40 i = icent + 1 + +C Now sum forwards until convergence + + xmult = centwt + IF ((aup-1+b).EQ.0) THEN + upterm = exp(-alngam(aup)-alngam(b)+ (aup-1)*log(xx)+ + + b*log(yy)) + + ELSE + upterm = exp(alngam(aup-1+b)-alngam(aup)-alngam(b)+ + + (aup-1)*log(xx)+b*log(yy)) + END IF + + GO TO 60 + + 50 IF (qsmall(xmult*betup)) GO TO 70 + 60 xmult = xmult* (xnonc/i) + i = i + 1 + aup = aup + 1 + upterm = (aup+b-2.0D0)*xx/ (aup-1)*upterm + betup = betup - upterm + sum = sum + xmult*betup + GO TO 50 + + 70 cum = sum + + ccum = 0.5D0 + (0.5D0-cum) + RETURN + + END diff --git a/modules/statistics/src/dcdflib/cumfnc.lo b/modules/statistics/src/dcdflib/cumfnc.lo new file mode 100755 index 000000000..e034d10b4 --- /dev/null +++ b/modules/statistics/src/dcdflib/cumfnc.lo @@ -0,0 +1,12 @@ +# src/dcdflib/cumfnc.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/cumfnc.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/statistics/src/dcdflib/cumgam.f b/modules/statistics/src/dcdflib/cumgam.f new file mode 100755 index 000000000..25484c56c --- /dev/null +++ b/modules/statistics/src/dcdflib/cumgam.f @@ -0,0 +1,61 @@ + SUBROUTINE cumgam(x,a,cum,ccum) +C********************************************************************** +C +C SUBROUTINE CUMGAM(X,A,CUM,CCUM) +C Double precision cUMulative incomplete GAMma distribution +C +C +C Function +C +C +C Computes the cumulative of the incomplete gamma +C distribution, i.e., the integral from 0 to X of +C (1/GAM(A))*EXP(-T)*T**(A-1) DT +C where GAM(A) is the complete gamma function of A, i.e., +C GAM(A) = integral from 0 to infinity of +C EXP(-T)*T**(A-1) DT +C +C +C Arguments +C +C +C X --> The upper limit of integration of the incomplete gamma. +C X is DOUBLE PRECISION +C +C A --> The shape parameter of the incomplete gamma. +C A is DOUBLE PRECISION +C +C CUM <-- Cumulative incomplete gamma distribution. +C CUM is DOUBLE PRECISION +C +C CCUM <-- Compliment of Cumulative incomplete gamma distribution. +C CCUM is DOUBLE PRECISIO +C +C +C Method +C +C +C Calls the routine GRATIO. +C +C********************************************************************** +C +C .. +C .. Scalar Arguments .. + DOUBLE PRECISION a,x,cum,ccum +C .. +C .. External Routines .. + EXTERNAL gratio +C .. +C .. Executable Statements .. + IF (.NOT. (x.LE.0.0D0)) GO TO 10 + cum = 0.0D0 + ccum = 1.0D0 + RETURN + + 10 CALL gratio(a,x,cum,ccum,0) + +C Call gratio routine + + RETURN + + END diff --git a/modules/statistics/src/dcdflib/cumgam.lo b/modules/statistics/src/dcdflib/cumgam.lo new file mode 100755 index 000000000..bb241a209 --- /dev/null +++ b/modules/statistics/src/dcdflib/cumgam.lo @@ -0,0 +1,12 @@ +# src/dcdflib/cumgam.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/cumgam.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/statistics/src/dcdflib/cumnbn.f b/modules/statistics/src/dcdflib/cumnbn.f new file mode 100755 index 000000000..969b14a3f --- /dev/null +++ b/modules/statistics/src/dcdflib/cumnbn.f @@ -0,0 +1,61 @@ + SUBROUTINE cumnbn(s,xn,pr,ompr,cum,ccum) +C********************************************************************** +C +C SUBROUTINE CUMNNBN(S,XN,PR,OMPR,CUM,CCUM) +C CUmulative Negative BINomial distribution +C +C +C Function +C +C +C Returns the probability that it there will be S or fewer failures +C before there are XN successes, with each binomial trial having +C a probability of success PR. +C +C Prob(# failures = S | XN successes, PR) = +C ( XN + S - 1 ) +C ( ) * PR^XN * (1-PR)^S +C ( S ) +C +C +C Arguments +C +C +C S --> The number of failures +C S is DOUBLE PRECISION +C +C XN --> The number of successes +C XN is DOUBLE PRECISIO +C +C PR --> The probability of success in each binomial trial. +C PR is DOUBLE PRECISIO +C +C OMPR --> 1 - PR +C OMPR is DOUBLE PRECIS +C +C CUM <-- Cumulative negative binomial distribution. +C CUM is DOUBLE PRECISI +C +C CCUM <-- Compliment of Cumulative negative binomial distribution. +C CCUM is DOUBLE PRECIS +C +C +C Method +C +C +C Formula 26.5.26 of Abramowitz and Stegun, Handbook of +C Mathematical Functions (1966) is used to reduce the negative +C binomial distribution to the cumulative beta distribution. +C +C********************************************************************** +C .. Scalar Arguments .. + DOUBLE PRECISION pr,ompr,s,xn,cum,ccum +C .. +C .. External Subroutines .. + EXTERNAL cumbet +C .. +C .. Executable Statements .. + CALL cumbet(pr,ompr,xn,s+1.D0,cum,ccum) + RETURN + + END diff --git a/modules/statistics/src/dcdflib/cumnbn.lo b/modules/statistics/src/dcdflib/cumnbn.lo new file mode 100755 index 000000000..e9a0c5d2f --- /dev/null +++ b/modules/statistics/src/dcdflib/cumnbn.lo @@ -0,0 +1,12 @@ +# src/dcdflib/cumnbn.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/cumnbn.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/statistics/src/dcdflib/cumnor.f b/modules/statistics/src/dcdflib/cumnor.f new file mode 100755 index 000000000..32ada82fb --- /dev/null +++ b/modules/statistics/src/dcdflib/cumnor.f @@ -0,0 +1,213 @@ + SUBROUTINE cumnor(arg,result,ccum) +C********************************************************************** +C +C SUBROUINE CUMNOR(X,RESULT,CCUM) +C +C +C Function +C +C +C Computes the cumulative of the normal distribution, i.e., +C the integral from -infinity to x of +C (1/sqrt(2*pi)) exp(-u*u/2) du +C +C X --> Upper limit of integration. +C X is DOUBLE PRECISION +C +C RESULT <-- Cumulative normal distribution. +C RESULT is DOUBLE PRECISION +C +C CCUM <-- Compliment of Cumulative normal distribution. +C CCUM is DOUBLE PRECISION +C +C +C Renaming of function ANORM from: +C +C Cody, W.D. (1993). "ALGORITHM 715: SPECFUN - A Portabel FORTRAN +C Package of Special Function Routines and Test Drivers" +C acm Transactions on Mathematical Software. 19, 22-32. +C +C with slight modifications to return ccum and to deal with +C machine constants. +C +C********************************************************************** +C +C +C Original Comments: +C------------------------------------------------------------------ +C +C This function evaluates the normal distribution function: +C +C / x +C 1 | -t*t/2 +C P(x) = ----------- | e dt +C sqrt(2 pi) | +C /-oo +C +C The main computation evaluates near-minimax approximations +C derived from those in "Rational Chebyshev approximations for +C the error function" by W. J. Cody, Math. Comp., 1969, 631-637. +C This transportable program uses rational functions that +C theoretically approximate the normal distribution function to +C at least 18 significant decimal digits. The accuracy achieved +C depends on the arithmetic system, the compiler, the intrinsic +C functions, and proper selection of the machine-dependent +C constants. +C +C******************************************************************* +C******************************************************************* +C +C Explanation of machine-dependent constants. +C +C MIN = smallest machine representable number. +C +C EPS = argument below which anorm(x) may be represented by +C 0.5 and above which x*x will not underflow. +C A conservative value is the largest machine number X +C such that 1.0 + X = 1.0 to machine precision. +C******************************************************************* +C******************************************************************* +C +C Error returns +C +C The program returns ANORM = 0 for ARG .LE. XLOW. +C +C +C Intrinsic functions required are: +C +C ABS, AINT, EXP +C +C +C Author: W. J. Cody +C Mathematics and Computer Science Division +C Argonne National Laboratory +C Argonne, IL 60439 +C +C Latest modification: March 15, 1992 +C +C------------------------------------------------------------------ + INTEGER i + DOUBLE PRECISION a,arg,b,c,d,del,eps,half,p,one,q,result,sixten, + + temp,sqrpi,thrsh,root32,x,xden,xnum,y,xsq,zero, + + min,ccum + DIMENSION a(5),b(4),c(9),d(8),p(6),q(5) +C------------------------------------------------------------------ +C External Function +C------------------------------------------------------------------ + DOUBLE PRECISION spmpar + EXTERNAL spmpar +C------------------------------------------------------------------ +C Mathematical constants +C +C SQRPI = 1 / sqrt(2*pi), ROOT32 = sqrt(32), and +C THRSH is the argument for which anorm = 0.75. +C------------------------------------------------------------------ + DATA one,half,zero,sixten/1.0D0,0.5D0,0.0D0,1.60D0/, + + sqrpi/3.9894228040143267794D-1/,thrsh/0.66291D0/, + + root32/5.656854248D0/ +C------------------------------------------------------------------ +C Coefficients for approximation in first interval +C------------------------------------------------------------------ + DATA a/2.2352520354606839287D00,1.6102823106855587881D02, + + 1.0676894854603709582D03,1.8154981253343561249D04, + + 6.5682337918207449113D-2/ + DATA b/4.7202581904688241870D01,9.7609855173777669322D02, + + 1.0260932208618978205D04,4.5507789335026729956D04/ +C------------------------------------------------------------------ +C Coefficients for approximation in second interval +C------------------------------------------------------------------ + DATA c/3.9894151208813466764D-1,8.8831497943883759412D00, + + 9.3506656132177855979D01,5.9727027639480026226D02, + + 2.4945375852903726711D03,6.8481904505362823326D03, + + 1.1602651437647350124D04,9.8427148383839780218D03, + + 1.0765576773720192317D-8/ + DATA d/2.2266688044328115691D01,2.3538790178262499861D02, + + 1.5193775994075548050D03,6.4855582982667607550D03, + + 1.8615571640885098091D04,3.4900952721145977266D04, + + 3.8912003286093271411D04,1.9685429676859990727D04/ +C------------------------------------------------------------------ +C Coefficients for approximation in third interval +C------------------------------------------------------------------ + DATA p/2.1589853405795699D-1,1.274011611602473639D-1, + + 2.2235277870649807D-2,1.421619193227893466D-3, + + 2.9112874951168792D-5,2.307344176494017303D-2/ + DATA q/1.28426009614491121D00,4.68238212480865118D-1, + + 6.59881378689285515D-2,3.78239633202758244D-3, + + 7.29751555083966205D-5/ +C------------------------------------------------------------------ +C Machine dependent constants +C------------------------------------------------------------------ + eps = spmpar(1)*0.5D0 + min = spmpar(2) +C------------------------------------------------------------------ + x = arg + y = abs(x) + IF (y.LE.thrsh) THEN +C------------------------------------------------------------------ +C Evaluate anorm for |X| <= 0.66291 +C------------------------------------------------------------------ + xsq = zero + IF (y.GT.eps) xsq = x*x + xnum = a(5)*xsq + xden = xsq + DO 10 i = 1,3 + xnum = (xnum+a(i))*xsq + xden = (xden+b(i))*xsq + 10 CONTINUE + result = x* (xnum+a(4))/ (xden+b(4)) + temp = result + result = half + temp + ccum = half - temp +C------------------------------------------------------------------ +C Evaluate anorm for 0.66291 <= |X| <= sqrt(32) +C------------------------------------------------------------------ + ELSE IF (y.LE.root32) THEN + xnum = c(9)*y + xden = y + DO 20 i = 1,7 + xnum = (xnum+c(i))*y + xden = (xden+d(i))*y + 20 CONTINUE + result = (xnum+c(8))/ (xden+d(8)) + xsq = aint(y*sixten)/sixten + del = (y-xsq)* (y+xsq) + result = exp(-xsq*xsq*half)*exp(-del*half)*result + ccum = one - result + IF (x.GT.zero) THEN + temp = result + result = ccum + ccum = temp + END IF +C------------------------------------------------------------------ +C Evaluate anorm for |X| > sqrt(32) +C------------------------------------------------------------------ + ELSE + result = zero + xsq = one/ (x*x) + xnum = p(6)*xsq + xden = xsq + DO 30 i = 1,4 + xnum = (xnum+p(i))*xsq + xden = (xden+q(i))*xsq + 30 CONTINUE + result = xsq* (xnum+p(5))/ (xden+q(5)) + result = (sqrpi-result)/y + xsq = aint(x*sixten)/sixten + del = (x-xsq)* (x+xsq) + result = exp(-xsq*xsq*half)*exp(-del*half)*result + ccum = one - result + IF (x.GT.zero) THEN + temp = result + result = ccum + ccum = temp + END IF + + END IF + + IF (result.LT.min) result = 0.0D0 + IF (ccum.LT.min) ccum = 0.0D0 +C------------------------------------------------------------------ +C Fix up for negative argument, erf, etc. +C------------------------------------------------------------------ +C----------Last card of ANORM ---------- + END diff --git a/modules/statistics/src/dcdflib/cumnor.lo b/modules/statistics/src/dcdflib/cumnor.lo new file mode 100755 index 000000000..9f057b10b --- /dev/null +++ b/modules/statistics/src/dcdflib/cumnor.lo @@ -0,0 +1,12 @@ +# src/dcdflib/cumnor.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/cumnor.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/statistics/src/dcdflib/cumpoi.f b/modules/statistics/src/dcdflib/cumpoi.f new file mode 100755 index 000000000..b6736816d --- /dev/null +++ b/modules/statistics/src/dcdflib/cumpoi.f @@ -0,0 +1,54 @@ + SUBROUTINE cumpoi(s,xlam,cum,ccum) +C********************************************************************** +C +C SUBROUTINE CUMPOI(S,XLAM,CUM,CCUM) +C CUMulative POIsson distribution +C +C +C Function +C +C +C Returns the probability of S or fewer events in a Poisson +C distribution with mean XLAM. +C +C +C Arguments +C +C +C S --> Upper limit of cumulation of the Poisson. +C S is DOUBLE PRECISION +C +C XLAM --> Mean of the Poisson distribution. +C XLAM is DOUBLE PRECIS +C +C CUM <-- Cumulative poisson distribution. +C CUM is DOUBLE PRECISION +C +C CCUM <-- Compliment of Cumulative poisson distribution. +C CCUM is DOUBLE PRECIS +C +C +C Method +C +C +C Uses formula 26.4.21 of Abramowitz and Stegun, Handbook of +C Mathematical Functions to reduce the cumulative Poisson to +C the cumulative chi-square distribution. +C +C********************************************************************** +C .. Scalar Arguments .. + DOUBLE PRECISION s,xlam,cum,ccum +C .. +C .. Local Scalars .. + DOUBLE PRECISION chi,df +C .. +C .. External Subroutines .. + EXTERNAL cumchi +C .. +C .. Executable Statements .. + df = 2.0D0* (s+1.0D0) + chi = 2.0D0*xlam + CALL cumchi(chi,df,ccum,cum) + RETURN + + END diff --git a/modules/statistics/src/dcdflib/cumpoi.lo b/modules/statistics/src/dcdflib/cumpoi.lo new file mode 100755 index 000000000..9168f7f8e --- /dev/null +++ b/modules/statistics/src/dcdflib/cumpoi.lo @@ -0,0 +1,12 @@ +# src/dcdflib/cumpoi.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/cumpoi.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/statistics/src/dcdflib/cumt.f b/modules/statistics/src/dcdflib/cumt.f new file mode 100755 index 000000000..c69d71847 --- /dev/null +++ b/modules/statistics/src/dcdflib/cumt.f @@ -0,0 +1,63 @@ + SUBROUTINE cumt(t,df,cum,ccum) +C********************************************************************** +C +C SUBROUTINE CUMT(T,DF,CUM,CCUM) +C CUMulative T-distribution +C +C +C Function +C +C +C Computes the integral from -infinity to T of the t-density. +C +C +C Arguments +C +C +C T --> Upper limit of integration of the t-density. +C T is DOUBLE PRECISION +C +C DF --> Degrees of freedom of the t-distribution. +C DF is DOUBLE PRECISIO +C +C CUM <-- Cumulative t-distribution. +C CCUM is DOUBLE PRECIS +C +C CCUM <-- Compliment of Cumulative t-distribution. +C CCUM is DOUBLE PRECIS +C +C +C Method +C +C +C Formula 26.5.27 of Abramowitz and Stegun, Handbook of +C Mathematical Functions is used to reduce the t-distribution +C to an incomplete beta. +C +C********************************************************************** + +C .. Scalar Arguments .. + DOUBLE PRECISION df,t,cum,ccum +C .. +C .. Local Scalars .. + DOUBLE PRECISION xx,a,oma,tt,yy,dfptt +C .. +C .. External Subroutines .. + EXTERNAL cumbet +C .. +C .. Executable Statements .. + tt = t*t + dfptt = df + tt + xx = df/dfptt + yy = tt/dfptt + CALL cumbet(xx,yy,0.5D0*df,0.5D0,a,oma) + IF (.NOT. (t.LE.0.0D0)) GO TO 10 + cum = 0.5D0*a + ccum = oma + cum + GO TO 20 + + 10 ccum = 0.5D0*a + cum = oma + ccum + 20 RETURN + + END diff --git a/modules/statistics/src/dcdflib/cumt.lo b/modules/statistics/src/dcdflib/cumt.lo new file mode 100755 index 000000000..56c2fe72f --- /dev/null +++ b/modules/statistics/src/dcdflib/cumt.lo @@ -0,0 +1,12 @@ +# src/dcdflib/cumt.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/cumt.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/statistics/src/dcdflib/dcd_f/Core_Import.def b/modules/statistics/src/dcdflib/dcd_f/Core_Import.def new file mode 100755 index 000000000..757ec2c41 --- /dev/null +++ b/modules/statistics/src/dcdflib/dcd_f/Core_Import.def @@ -0,0 +1,7 @@ +LIBRARY core.dll + + +EXPORTS +; +isanan_ +returnananfortran_
\ No newline at end of file diff --git a/modules/statistics/src/dcdflib/dcd_f/Output_stream_Import.def b/modules/statistics/src/dcdflib/dcd_f/Output_stream_Import.def new file mode 100755 index 000000000..9181ba70b --- /dev/null +++ b/modules/statistics/src/dcdflib/dcd_f/Output_stream_Import.def @@ -0,0 +1,6 @@ +LIBRARY output_stream.dll + + +EXPORTS +; +basout_
\ No newline at end of file diff --git a/modules/statistics/src/dcdflib/dcd_f/dcd_f.rc b/modules/statistics/src/dcdflib/dcd_f/dcd_f.rc new file mode 100755 index 000000000..dad8f0988 --- /dev/null +++ b/modules/statistics/src/dcdflib/dcd_f/dcd_f.rc @@ -0,0 +1,96 @@ +// Microsoft Visual C++ generated resource script. +// + + +#define APSTUDIO_READONLY_SYMBOLS +///////////////////////////////////////////////////////////////////////////// +// +// Generated from the TEXTINCLUDE 2 resource. +// +//#include "afxres.h" +#define APSTUDIO_HIDDEN_SYMBOLS +#include "windows.h" +///////////////////////////////////////////////////////////////////////////// +#undef APSTUDIO_READONLY_SYMBOLS + +///////////////////////////////////////////////////////////////////////////// +// French (France) resources + +#if !defined(AFX_RESOURCE_DLL) || defined(AFX_TARG_FRA) +#ifdef _WIN32 +LANGUAGE LANG_FRENCH, SUBLANG_FRENCH +#pragma code_page(1252) +#endif //_WIN32 + +#ifdef APSTUDIO_INVOKED +///////////////////////////////////////////////////////////////////////////// +// +// TEXTINCLUDE +// + +1 TEXTINCLUDE +BEGIN + "resource.h\0" +END + +3 TEXTINCLUDE +BEGIN + "\r\n" + "\0" +END + +#endif // APSTUDIO_INVOKED + + +///////////////////////////////////////////////////////////////////////////// +// +// Version +// + +VS_VERSION_INFO VERSIONINFO + FILEVERSION 5,5,2,0 + PRODUCTVERSION 5,5,2,0 + FILEFLAGSMASK 0x17L +#ifdef _DEBUG + FILEFLAGS 0x1L +#else + FILEFLAGS 0x0L +#endif + FILEOS 0x4L + FILETYPE 0x2L + FILESUBTYPE 0x0L +BEGIN + BLOCK "StringFileInfo" + BEGIN + BLOCK "040c04b0" + BEGIN + VALUE "FileDescription", "dcd library" + VALUE "FileVersion", "5, 5, 2, 0" + VALUE "InternalName", "dcd library for scilab 5.x" + VALUE "LegalCopyright", "Copyright (C) 2017" + VALUE "OriginalFilename", "dcd_f.dll" + VALUE "ProductName", "dcd library for scilab 5.x" + VALUE "ProductVersion", "5, 5, 2, 0" + END + END + BLOCK "VarFileInfo" + BEGIN + VALUE "Translation", 0x40c, 1200 + END +END + +#endif // French (France) resources +///////////////////////////////////////////////////////////////////////////// + + + +#ifndef APSTUDIO_INVOKED +///////////////////////////////////////////////////////////////////////////// +// +// Generated from the TEXTINCLUDE 3 resource. +// + + +///////////////////////////////////////////////////////////////////////////// +#endif // not APSTUDIO_INVOKED + diff --git a/modules/statistics/src/dcdflib/dcd_f/dcd_f.vfproj b/modules/statistics/src/dcdflib/dcd_f/dcd_f.vfproj new file mode 100755 index 000000000..15ffbe325 --- /dev/null +++ b/modules/statistics/src/dcdflib/dcd_f/dcd_f.vfproj @@ -0,0 +1,162 @@ +<?xml version="1.0" encoding="UTF-8"?> +<VisualStudioProject ProjectType="typeDynamicLibrary" ProjectCreator="Intel Fortran" Keyword="Dll" Version="11.0" ProjectIdGuid="{18F043DA-1DB5-464F-B67D-CF1C23BE7EA0}"> + <Platforms> + <Platform Name="Win32"/> + <Platform Name="x64"/></Platforms> + <Configurations> + <Configuration Name="Debug|Win32" OutputDirectory="$(SolutionDir)bin\" IntermediateDirectory="$(ProjectDir)$(ConfigurationName)" DeleteExtensionsOnClean="*.obj;*.mod;*.pdb;*.asm;*.map;*.dyn;*.dpi;*.tmp;*.log;*.ilk;*.dll;$(TargetPath)" ConfigurationType="typeDynamicLibrary"> + <Tool Name="VFFortranCompilerTool" SuppressStartupBanner="true" DebugInformationFormat="debugEnabled" Optimization="optimizeDisabled" AdditionalIncludeDirectories="../../../../core/includes" F77RuntimeCompatibility="true" CallingConvention="callConventionCRef" ExternalNameUnderscore="true" ModulePath="$(INTDIR)/" ObjectFile="$(INTDIR)/" Traceback="true" BoundsCheck="true" RuntimeLibrary="rtMultiThreadedDebugDLL"/> + <Tool Name="VFLinkerTool" OutputFile="$(SolutionDir)bin\$(ProjectName).dll" LinkIncremental="linkIncrementalNo" SuppressStartupBanner="true" ModuleDefinitionFile="dcd_f.def" GenerateDebugInformation="true" SubSystem="subSystemWindows" ImportLibrary="$(SolutionDir)bin\$(ProjectName).lib" LinkDLL="true" AdditionalDependencies="../../../../../bin/blasplus.lib ../../../../../bin/lapack.lib output_stream.lib statistics.lib core.lib elementary_functions.lib"/> + <Tool Name="VFResourceCompilerTool"/> + <Tool Name="VFMidlTool" SuppressStartupBanner="true" HeaderFileName="$(InputName).h" TypeLibraryName="$(IntDir)/$(InputName).tlb"/> + <Tool Name="VFCustomBuildTool"/> + <Tool Name="VFPreLinkEventTool" CommandLine="setlocal EnableDelayedExpansion +cd $(ConfigurationName) +set LIST_OBJ= +for %%f in (*.obj) do set LIST_OBJ=!LIST_OBJ! %%f +"$(SolutionDir)bin\dumpexts" -o $(ProjectName).def $(ProjectName).dll %LIST_OBJ% +copy $(ProjectName).def ..\$(ProjectName).def >nul +del *.def >nul +cd .." Description="Build $(ProjectName).def"/> + <Tool Name="VFPreBuildEventTool" CommandLine="lib /DEF:"$(InputDir)Output_stream_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X86 /OUT:"$(InputDir)output_stream.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)Statistics_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X86 /OUT:"$(InputDir)statistics.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)Core_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X86 /OUT:"$(InputDir)core.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)elementary_functions_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X86 /OUT:"$(InputDir)elementary_functions.lib" 1>NUL 2>NUL" Description="Make dependencies"/> + <Tool Name="VFPostBuildEventTool"/> + <Tool Name="VFManifestTool" SuppressStartupBanner="true"/></Configuration> + <Configuration Name="Release|Win32" OutputDirectory="$(SolutionDir)bin\" IntermediateDirectory="$(ProjectDir)$(ConfigurationName)" DeleteExtensionsOnClean="*.obj;*.mod;*.pdb;*.asm;*.map;*.dyn;*.dpi;*.tmp;*.log;*.ilk;*.dll;$(TargetPath)" ConfigurationType="typeDynamicLibrary"> + <Tool Name="VFFortranCompilerTool" SuppressStartupBanner="true" AdditionalIncludeDirectories="../../../../core/includes" AlternateParameterSyntax="false" F77RuntimeCompatibility="true" BackslashAsNormalCharacter="false" FPS4Libs="false" CallingConvention="callConventionCRef" ExternalNameUnderscore="true" ModulePath="$(INTDIR)/" ObjectFile="$(INTDIR)/" RuntimeLibrary="rtMultiThreadedDLL"/> + <Tool Name="VFLinkerTool" OutputFile="$(SolutionDir)bin\$(ProjectName).dll" LinkIncremental="linkIncrementalNo" SuppressStartupBanner="true" ModuleDefinitionFile="dcd_f.def" SubSystem="subSystemWindows" SupportUnloadOfDelayLoadedDLL="true" ImportLibrary="$(SolutionDir)bin\$(ProjectName).lib" LinkDLL="true" AdditionalDependencies="../../../../../bin/blasplus.lib ../../../../../bin/lapack.lib output_stream.lib statistics.lib core.lib elementary_functions.lib"/> + <Tool Name="VFResourceCompilerTool"/> + <Tool Name="VFMidlTool" SuppressStartupBanner="true" HeaderFileName="$(InputName).h" TypeLibraryName="$(IntDir)/$(InputName).tlb"/> + <Tool Name="VFCustomBuildTool"/> + <Tool Name="VFPreLinkEventTool" CommandLine="setlocal EnableDelayedExpansion +cd $(ConfigurationName) +set LIST_OBJ= +for %%f in (*.obj) do set LIST_OBJ=!LIST_OBJ! %%f +"$(SolutionDir)bin\dumpexts" -o $(ProjectName).def $(ProjectName).dll %LIST_OBJ% +copy $(ProjectName).def ..\$(ProjectName).def >nul +del *.def >nul +cd .." Description="Build $(ProjectName).def"/> + <Tool Name="VFPreBuildEventTool" CommandLine="lib /DEF:"$(InputDir)Output_stream_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X86 /OUT:"$(InputDir)output_stream.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)Statistics_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X86 /OUT:"$(InputDir)statistics.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)Core_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X86 /OUT:"$(InputDir)core.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)elementary_functions_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X86 /OUT:"$(InputDir)elementary_functions.lib" 1>NUL 2>NUL" Description="Make dependencies"/> + <Tool Name="VFPostBuildEventTool"/> + <Tool Name="VFManifestTool" SuppressStartupBanner="true"/></Configuration> + <Configuration Name="Debug|x64" OutputDirectory="$(SolutionDir)bin\" IntermediateDirectory="$(ProjectDir)$(ConfigurationName)" DeleteExtensionsOnClean="*.obj;*.mod;*.pdb;*.asm;*.map;*.dyn;*.dpi;*.tmp;*.log;*.ilk;*.dll;$(TargetPath)" ConfigurationType="typeDynamicLibrary"> + <Tool Name="VFFortranCompilerTool" SuppressStartupBanner="true" DebugInformationFormat="debugEnabled" Optimization="optimizeDisabled" AdditionalIncludeDirectories="../../../../core/includes" F77RuntimeCompatibility="true" CallingConvention="callConventionCRef" ExternalNameUnderscore="true" ModulePath="$(INTDIR)/" ObjectFile="$(INTDIR)/" Traceback="true" BoundsCheck="true" RuntimeLibrary="rtMultiThreadedDebugDLL"/> + <Tool Name="VFLinkerTool" OutputFile="$(SolutionDir)bin\$(ProjectName).dll" LinkIncremental="linkIncrementalNo" SuppressStartupBanner="true" ModuleDefinitionFile="dcd_f.def" GenerateDebugInformation="true" SubSystem="subSystemWindows" ImportLibrary="$(SolutionDir)bin\$(ProjectName).lib" LinkDLL="true" AdditionalDependencies="../../../../../bin/blasplus.lib ../../../../../bin/lapack.lib output_stream.lib statistics.lib core.lib elementary_functions.lib"/> + <Tool Name="VFResourceCompilerTool"/> + <Tool Name="VFMidlTool" SuppressStartupBanner="true" HeaderFileName="$(InputName).h" TypeLibraryName="$(IntDir)/$(InputName).tlb"/> + <Tool Name="VFCustomBuildTool"/> + <Tool Name="VFPreLinkEventTool" CommandLine="setlocal EnableDelayedExpansion +cd $(ConfigurationName) +set LIST_OBJ= +for %%f in (*.obj) do set LIST_OBJ=!LIST_OBJ! %%f +"$(SolutionDir)bin\dumpexts" -o $(ProjectName).def $(ProjectName).dll %LIST_OBJ% +copy $(ProjectName).def ..\$(ProjectName).def >nul +del *.def >nul +cd .." Description="Build $(ProjectName).def"/> + <Tool Name="VFPreBuildEventTool" CommandLine="lib /DEF:"$(InputDir)Output_stream_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X64 /OUT:"$(InputDir)output_stream.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)Statistics_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X64 /OUT:"$(InputDir)statistics.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)Core_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X64 /OUT:"$(InputDir)core.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)elementary_functions_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X64 /OUT:"$(InputDir)elementary_functions.lib" 1>NUL 2>NUL" Description="Make dependencies"/> + <Tool Name="VFPostBuildEventTool"/> + <Tool Name="VFManifestTool" SuppressStartupBanner="true"/></Configuration> + <Configuration Name="Release|x64" OutputDirectory="$(SolutionDir)bin\" IntermediateDirectory="$(ProjectDir)$(ConfigurationName)" DeleteExtensionsOnClean="*.obj;*.mod;*.pdb;*.asm;*.map;*.dyn;*.dpi;*.tmp;*.log;*.ilk;*.dll;$(TargetPath)" ConfigurationType="typeDynamicLibrary"> + <Tool Name="VFFortranCompilerTool" SuppressStartupBanner="true" AdditionalIncludeDirectories="../../../../core/includes" AlternateParameterSyntax="false" F77RuntimeCompatibility="true" BackslashAsNormalCharacter="false" FPS4Libs="false" CallingConvention="callConventionCRef" ExternalNameUnderscore="true" ModulePath="$(INTDIR)/" ObjectFile="$(INTDIR)/" RuntimeLibrary="rtMultiThreadedDLL"/> + <Tool Name="VFLinkerTool" OutputFile="$(SolutionDir)bin\$(ProjectName).dll" LinkIncremental="linkIncrementalNo" SuppressStartupBanner="true" ModuleDefinitionFile="dcd_f.def" SubSystem="subSystemWindows" SupportUnloadOfDelayLoadedDLL="true" ImportLibrary="$(SolutionDir)bin\$(ProjectName).lib" LinkDLL="true" AdditionalDependencies="../../../../../bin/blasplus.lib ../../../../../bin/lapack.lib output_stream.lib statistics.lib core.lib elementary_functions.lib"/> + <Tool Name="VFResourceCompilerTool"/> + <Tool Name="VFMidlTool" SuppressStartupBanner="true" HeaderFileName="$(InputName).h" TypeLibraryName="$(IntDir)/$(InputName).tlb"/> + <Tool Name="VFCustomBuildTool"/> + <Tool Name="VFPreLinkEventTool" CommandLine="setlocal EnableDelayedExpansion +cd $(ConfigurationName) +set LIST_OBJ= +for %%f in (*.obj) do set LIST_OBJ=!LIST_OBJ! %%f +"$(SolutionDir)bin\dumpexts" -o $(ProjectName).def $(ProjectName).dll %LIST_OBJ% +copy $(ProjectName).def ..\$(ProjectName).def >nul +del *.def >nul +cd .." Description="Build $(ProjectName).def"/> + <Tool Name="VFPreBuildEventTool" CommandLine="lib /DEF:"$(InputDir)Output_stream_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X64 /OUT:"$(InputDir)output_stream.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)Statistics_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X64 /OUT:"$(InputDir)statistics.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)Core_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X64 /OUT:"$(InputDir)core.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)elementary_functions_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X64 /OUT:"$(InputDir)elementary_functions.lib" 1>NUL 2>NUL" Description="Make dependencies"/> + <Tool Name="VFPostBuildEventTool"/> + <Tool Name="VFManifestTool" SuppressStartupBanner="true"/></Configuration></Configurations> + <Files> + <Filter Name="Header Files" Filter="fi;fd"/> + <Filter Name="Library Dependencies"> + <File RelativePath=".\Core_Import.def"/> + <File RelativePath=".\elementary_functions_Import.def"/> + <File RelativePath=".\Output_stream_Import.def"/> + <File RelativePath=".\statistics_Import.def"/></Filter> + <Filter Name="Resource Files" Filter="rc;ico;cur;bmp;dlg;rc2;rct;bin;rgs;gif;jpg;jpeg;jpe"> + <File RelativePath=".\dcd_f.rc"/></Filter> + <Filter Name="Source Files" Filter="f90;for;f;fpp;ftn;def;odl;idl"> + <File RelativePath="..\algdiv.f"/> + <File RelativePath="..\alngam.f"/> + <File RelativePath="..\alnrel.f"/> + <File RelativePath="..\apser.f"/> + <File RelativePath="..\basym.f"/> + <File RelativePath="..\bcorr.f"/> + <File RelativePath="..\betaln.f"/> + <File RelativePath="..\bfrac.f"/> + <File RelativePath="..\bgrat.f"/> + <File RelativePath="..\bpser.f"/> + <File RelativePath="..\bratio.f"/> + <File RelativePath="..\brcmp1.f"/> + <File RelativePath="..\brcomp.f"/> + <File RelativePath="..\bup.f"/> + <File RelativePath="..\cdfbet.f"/> + <File RelativePath="..\cdfbin.f"/> + <File RelativePath="..\cdfchi.f"/> + <File RelativePath="..\cdfchn.f"/> + <File RelativePath="..\cdff.f"/> + <File RelativePath="..\cdffnc.f"/> + <File RelativePath="..\cdfgam.f"/> + <File RelativePath="..\cdfnbn.f"/> + <File RelativePath="..\cdfnor.f"/> + <File RelativePath="..\cdfpoi.f"/> + <File RelativePath="..\cdft.f"/> + <File RelativePath="..\cumbet.f"/> + <File RelativePath="..\cumbin.f"/> + <File RelativePath="..\cumchi.f"/> + <File RelativePath="..\cumchn.f"/> + <File RelativePath="..\cumf.f"/> + <File RelativePath="..\cumfnc.f"/> + <File RelativePath="..\cumgam.f"/> + <File RelativePath="..\cumnbn.f"/> + <File RelativePath="..\cumnor.f"/> + <File RelativePath="..\cumpoi.f"/> + <File RelativePath="..\cumt.f"/> + <File RelativePath="..\devlpl.f"/> + <File RelativePath="..\dexpm1.f"/> + <File RelativePath="..\dinvnr.f"/> + <File RelativePath="..\dinvr.f"/> + <File RelativePath="..\dt1.f"/> + <File RelativePath="..\dzror.f"/> + <File RelativePath="..\erf.f"/> + <File RelativePath="..\erfc1.f"/> + <File RelativePath="..\esum.f"/> + <File RelativePath="..\exparg.f"/> + <File RelativePath="..\fpser.f"/> + <File RelativePath="..\gam1.f"/> + <File RelativePath="..\gaminv.f"/> + <File RelativePath="..\gamln.f"/> + <File RelativePath="..\gamln1.f"/> + <File RelativePath="..\gamma.f"/> + <File RelativePath="..\grat1.f"/> + <File RelativePath="..\gratio.f"/> + <File RelativePath="..\gsumln.f"/> + <File RelativePath="..\ipmpar.f"/> + <File RelativePath="..\psi.f"/> + <File RelativePath="..\rcomp.f"/> + <File RelativePath="..\rexp.f"/> + <File RelativePath="..\rlog.f"/> + <File RelativePath="..\rlog1.f"/> + <File RelativePath="..\spmpar.f"/> + <File RelativePath="..\stvaln.f"/></Filter> + <File RelativePath="..\..\..\..\..\bin\blasplus.lib"/> + <File RelativePath="..\..\..\..\..\bin\lapack.lib"/></Files> + <Globals/></VisualStudioProject> diff --git a/modules/statistics/src/dcdflib/dcd_f/dcd_f2c.vcxproj b/modules/statistics/src/dcdflib/dcd_f/dcd_f2c.vcxproj new file mode 100755 index 000000000..d43dcb320 --- /dev/null +++ b/modules/statistics/src/dcdflib/dcd_f/dcd_f2c.vcxproj @@ -0,0 +1,386 @@ +<?xml version="1.0" encoding="utf-8"?> +<Project DefaultTargets="Build" ToolsVersion="4.0" xmlns="http://schemas.microsoft.com/developer/msbuild/2003"> + <ItemGroup Label="ProjectConfigurations"> + <ProjectConfiguration Include="Debug|Win32"> + <Configuration>Debug</Configuration> + <Platform>Win32</Platform> + </ProjectConfiguration> + <ProjectConfiguration Include="Debug|x64"> + <Configuration>Debug</Configuration> + <Platform>x64</Platform> + </ProjectConfiguration> + <ProjectConfiguration Include="Release|Win32"> + <Configuration>Release</Configuration> + <Platform>Win32</Platform> + </ProjectConfiguration> + <ProjectConfiguration Include="Release|x64"> + <Configuration>Release</Configuration> + <Platform>x64</Platform> + </ProjectConfiguration> + </ItemGroup> + <PropertyGroup Label="Globals"> + <ProjectName>dcd_f</ProjectName> + <ProjectGuid>{18F043DA-1DB5-464F-B67D-CF1C23BE7EA0}</ProjectGuid> + <RootNamespace>dcd_f2c_DLL</RootNamespace> + <Keyword>Win32Proj</Keyword> + </PropertyGroup> + <Import Project="$(VCTargetsPath)\Microsoft.Cpp.Default.props" /> + <PropertyGroup Condition="'$(Configuration)|$(Platform)'=='Release|Win32'" Label="Configuration"> + <ConfigurationType>DynamicLibrary</ConfigurationType> + <CharacterSet>MultiByte</CharacterSet> + <PlatformToolset>v110</PlatformToolset> + </PropertyGroup> + <PropertyGroup Condition="'$(Configuration)|$(Platform)'=='Debug|Win32'" Label="Configuration"> + <ConfigurationType>DynamicLibrary</ConfigurationType> + <CharacterSet>MultiByte</CharacterSet> + <PlatformToolset>v110</PlatformToolset> + </PropertyGroup> + <PropertyGroup Condition="'$(Configuration)|$(Platform)'=='Release|x64'" Label="Configuration"> + <ConfigurationType>DynamicLibrary</ConfigurationType> + <CharacterSet>MultiByte</CharacterSet> + <PlatformToolset>v110</PlatformToolset> + </PropertyGroup> + <PropertyGroup Condition="'$(Configuration)|$(Platform)'=='Debug|x64'" Label="Configuration"> + <ConfigurationType>DynamicLibrary</ConfigurationType> + <CharacterSet>MultiByte</CharacterSet> + <PlatformToolset>v110</PlatformToolset> + </PropertyGroup> + <Import Project="$(VCTargetsPath)\Microsoft.Cpp.props" /> + <ImportGroup Label="ExtensionSettings"> + <Import Project="..\..\..\..\..\Visual-Studio-settings\f2c.props" /> + </ImportGroup> + <ImportGroup Condition="'$(Configuration)|$(Platform)'=='Release|Win32'" Label="PropertySheets"> + <Import Project="$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props" Condition="exists('$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props')" Label="LocalAppDataPlatform" /> + </ImportGroup> + <ImportGroup Condition="'$(Configuration)|$(Platform)'=='Debug|Win32'" Label="PropertySheets"> + <Import Project="$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props" Condition="exists('$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props')" Label="LocalAppDataPlatform" /> + </ImportGroup> + <ImportGroup Condition="'$(Configuration)|$(Platform)'=='Release|x64'" Label="PropertySheets"> + <Import Project="$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props" Condition="exists('$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props')" Label="LocalAppDataPlatform" /> + </ImportGroup> + <ImportGroup Condition="'$(Configuration)|$(Platform)'=='Debug|x64'" Label="PropertySheets"> + <Import Project="$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props" Condition="exists('$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props')" Label="LocalAppDataPlatform" /> + </ImportGroup> + <PropertyGroup Label="UserMacros" /> + <PropertyGroup> + <_ProjectFileVersion>10.0.30319.1</_ProjectFileVersion> + <OutDir Condition="'$(Configuration)|$(Platform)'=='Debug|Win32'">$(SolutionDir)bin\</OutDir> + <IntDir Condition="'$(Configuration)|$(Platform)'=='Debug|Win32'">$(ProjectDir)$(Configuration)\</IntDir> + <OutDir Condition="'$(Configuration)|$(Platform)'=='Debug|x64'">$(SolutionDir)bin\</OutDir> + <IntDir Condition="'$(Configuration)|$(Platform)'=='Debug|x64'">$(ProjectDir)$(Configuration)\</IntDir> + <OutDir Condition="'$(Configuration)|$(Platform)'=='Release|Win32'">$(SolutionDir)bin\</OutDir> + <IntDir Condition="'$(Configuration)|$(Platform)'=='Release|Win32'">$(ProjectDir)$(Configuration)\</IntDir> + <OutDir Condition="'$(Configuration)|$(Platform)'=='Release|x64'">$(SolutionDir)bin\</OutDir> + <IntDir Condition="'$(Configuration)|$(Platform)'=='Release|x64'">$(ProjectDir)$(Configuration)\</IntDir> + </PropertyGroup> + <ItemDefinitionGroup Condition="'$(Configuration)|$(Platform)'=='Debug|Win32'"> + <PreBuildEvent> + <Command>lib /DEF:"$(ProjectDir)Output_stream_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)output_stream.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)Statistics_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)statistics.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)Core_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)core.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)elementary_functions_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)elementary_functions.lib" 1>NUL 2>NUL</Command> + <Message>Make dependencies</Message> + </PreBuildEvent> + <ClCompile> + <Optimization>Disabled</Optimization> + <AdditionalIncludeDirectories>../../../../../libs/f2c;%(AdditionalIncludeDirectories)</AdditionalIncludeDirectories> + <PreprocessorDefinitions>__STDC__;_CRT_SECURE_NO_DEPRECATE;%(PreprocessorDefinitions)</PreprocessorDefinitions> + <RuntimeLibrary>MultiThreadedDebug</RuntimeLibrary> + <ObjectFileName>$(Configuration)/</ObjectFileName> + <WarningLevel>Level3</WarningLevel> + </ClCompile> + <PreLinkEvent> + <Message>Build $(ProjectName).def</Message> + <Command>setlocal EnableDelayedExpansion +cd $(ConfigurationName) +set LIST_OBJ= +for %%f in (*.obj) do set LIST_OBJ=!LIST_OBJ! %%f +"$(SolutionDir)bin\dumpexts" -o $(ProjectName).def $(ProjectName).dll %LIST_OBJ% +copy $(ProjectName).def ..\$(ProjectName).def >nul +del *.def >nul +cd .. +</Command> + </PreLinkEvent> + <Link> + <AdditionalDependencies>../../../../../bin/blasplus.lib;../../../../../bin/lapack.lib;../../../../../bin/libf2c.lib;output_stream.lib;statistics.lib;core.lib;elementary_functions.lib;%(AdditionalDependencies)</AdditionalDependencies> + <OutputFile>$(SolutionDir)bin\$(ProjectName).dll</OutputFile> + <ModuleDefinitionFile>dcd_f.def</ModuleDefinitionFile> + <ImportLibrary>$(SolutionDir)bin\$(ProjectName).lib</ImportLibrary> + <CLRUnmanagedCodeCheck>true</CLRUnmanagedCodeCheck> + <RandomizedBaseAddress>false</RandomizedBaseAddress> + </Link> + <PostBuildEvent> + </PostBuildEvent> + </ItemDefinitionGroup> + <ItemDefinitionGroup Condition="'$(Configuration)|$(Platform)'=='Debug|x64'"> + <PreBuildEvent> + <Command>lib /DEF:"$(ProjectDir)Output_stream_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)output_stream.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)Statistics_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)statistics.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)Core_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)core.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)elementary_functions_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)elementary_functions.lib" 1>NUL 2>NUL</Command> + <Message>Make dependencies</Message> + </PreBuildEvent> + <Midl> + <TargetEnvironment>X64</TargetEnvironment> + </Midl> + <ClCompile> + <Optimization>Disabled</Optimization> + <AdditionalIncludeDirectories>../../../../../libs/f2c;%(AdditionalIncludeDirectories)</AdditionalIncludeDirectories> + <PreprocessorDefinitions>__STDC__;_CRT_SECURE_NO_DEPRECATE;%(PreprocessorDefinitions)</PreprocessorDefinitions> + <RuntimeLibrary>MultiThreadedDebug</RuntimeLibrary> + <ObjectFileName>$(Configuration)/</ObjectFileName> + <WarningLevel>Level3</WarningLevel> + </ClCompile> + <PreLinkEvent> + <Message>Build $(ProjectName).def</Message> + <Command>setlocal EnableDelayedExpansion +cd $(ConfigurationName) +set LIST_OBJ= +for %%f in (*.obj) do set LIST_OBJ=!LIST_OBJ! %%f +"$(SolutionDir)bin\dumpexts" -o $(ProjectName).def $(ProjectName).dll %LIST_OBJ% +copy $(ProjectName).def ..\$(ProjectName).def >nul +del *.def >nul +cd .. +</Command> + </PreLinkEvent> + <Link> + <AdditionalDependencies>../../../../../bin/blasplus.lib;../../../../../bin/lapack.lib;../../../../../bin/libf2c.lib;output_stream.lib;statistics.lib;core.lib;elementary_functions.lib;%(AdditionalDependencies)</AdditionalDependencies> + <OutputFile>$(SolutionDir)bin\$(ProjectName).dll</OutputFile> + <ModuleDefinitionFile>dcd_f.def</ModuleDefinitionFile> + <ImportLibrary>$(SolutionDir)bin\$(ProjectName).lib</ImportLibrary> + <TargetMachine>MachineX64</TargetMachine> + <CLRUnmanagedCodeCheck>true</CLRUnmanagedCodeCheck> + <RandomizedBaseAddress>false</RandomizedBaseAddress> + </Link> + <PostBuildEvent> + </PostBuildEvent> + </ItemDefinitionGroup> + <ItemDefinitionGroup Condition="'$(Configuration)|$(Platform)'=='Release|Win32'"> + <PreBuildEvent> + <Command>lib /DEF:"$(ProjectDir)Output_stream_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)output_stream.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)Statistics_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)statistics.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)Core_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)core.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)elementary_functions_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)elementary_functions.lib" 1>NUL 2>NUL</Command> + <Message>Make dependencies</Message> + </PreBuildEvent> + <ClCompile> + <FavorSizeOrSpeed>Speed</FavorSizeOrSpeed> + <AdditionalIncludeDirectories>../../../../../libs/f2c;%(AdditionalIncludeDirectories)</AdditionalIncludeDirectories> + <PreprocessorDefinitions>__STDC__;_CRT_SECURE_NO_DEPRECATE;%(PreprocessorDefinitions)</PreprocessorDefinitions> + <RuntimeLibrary>MultiThreaded</RuntimeLibrary> + <ObjectFileName>$(Configuration)/</ObjectFileName> + <WarningLevel>Level3</WarningLevel> + </ClCompile> + <PreLinkEvent> + <Message>Build $(ProjectName).def</Message> + <Command>setlocal EnableDelayedExpansion +cd $(ConfigurationName) +set LIST_OBJ= +for %%f in (*.obj) do set LIST_OBJ=!LIST_OBJ! %%f +"$(SolutionDir)bin\dumpexts" -o $(ProjectName).def $(ProjectName).dll %LIST_OBJ% +copy $(ProjectName).def ..\$(ProjectName).def >nul +del *.def >nul +cd .. +</Command> + </PreLinkEvent> + <Link> + <AdditionalDependencies>../../../../../bin/blasplus.lib;../../../../../bin/lapack.lib;../../../../../bin/libf2c.lib;output_stream.lib;statistics.lib;core.lib;elementary_functions.lib;%(AdditionalDependencies)</AdditionalDependencies> + <OutputFile>$(SolutionDir)bin\$(ProjectName).dll</OutputFile> + <ModuleDefinitionFile>dcd_f.def</ModuleDefinitionFile> + <ImportLibrary>$(SolutionDir)bin\$(ProjectName).lib</ImportLibrary> + <CLRUnmanagedCodeCheck>true</CLRUnmanagedCodeCheck> + <RandomizedBaseAddress>false</RandomizedBaseAddress> + </Link> + <PostBuildEvent> + </PostBuildEvent> + </ItemDefinitionGroup> + <ItemDefinitionGroup Condition="'$(Configuration)|$(Platform)'=='Release|x64'"> + <PreBuildEvent> + <Command>lib /DEF:"$(ProjectDir)Output_stream_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)output_stream.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)Statistics_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)statistics.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)Core_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)core.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)elementary_functions_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)elementary_functions.lib" 1>NUL 2>NUL</Command> + <Message>Make dependencies</Message> + </PreBuildEvent> + <Midl> + <TargetEnvironment>X64</TargetEnvironment> + </Midl> + <ClCompile> + <FavorSizeOrSpeed>Speed</FavorSizeOrSpeed> + <AdditionalIncludeDirectories>../../../../../libs/f2c;%(AdditionalIncludeDirectories)</AdditionalIncludeDirectories> + <PreprocessorDefinitions>__STDC__;_CRT_SECURE_NO_DEPRECATE;%(PreprocessorDefinitions)</PreprocessorDefinitions> + <RuntimeLibrary>MultiThreaded</RuntimeLibrary> + <ObjectFileName>$(Configuration)/</ObjectFileName> + <WarningLevel>Level3</WarningLevel> + </ClCompile> + <PreLinkEvent> + <Message>Build $(ProjectName).def</Message> + <Command>setlocal EnableDelayedExpansion +cd $(ConfigurationName) +set LIST_OBJ= +for %%f in (*.obj) do set LIST_OBJ=!LIST_OBJ! %%f +"$(SolutionDir)bin\dumpexts" -o $(ProjectName).def $(ProjectName).dll %LIST_OBJ% +copy $(ProjectName).def ..\$(ProjectName).def >nul +del *.def >nul +cd .. +</Command> + </PreLinkEvent> + <Link> + <AdditionalDependencies>../../../../../bin/blasplus.lib;../../../../../bin/lapack.lib;../../../../../bin/libf2c.lib;output_stream.lib;statistics.lib;core.lib;elementary_functions.lib;%(AdditionalDependencies)</AdditionalDependencies> + <OutputFile>$(SolutionDir)bin\$(ProjectName).dll</OutputFile> + <ModuleDefinitionFile>dcd_f.def</ModuleDefinitionFile> + <ImportLibrary>$(SolutionDir)bin\$(ProjectName).lib</ImportLibrary> + <TargetMachine>MachineX64</TargetMachine> + <CLRUnmanagedCodeCheck>true</CLRUnmanagedCodeCheck> + <RandomizedBaseAddress>false</RandomizedBaseAddress> + </Link> + <PostBuildEvent> + </PostBuildEvent> + </ItemDefinitionGroup> + <ItemGroup> + <ClCompile Include="..\algdiv.c" /> + <ClCompile Include="..\alngam.c" /> + <ClCompile Include="..\alnrel.c" /> + <ClCompile Include="..\apser.c" /> + <ClCompile Include="..\basym.c" /> + <ClCompile Include="..\bcorr.c" /> + <ClCompile Include="..\betaln.c" /> + <ClCompile Include="..\bfrac.c" /> + <ClCompile Include="..\bgrat.c" /> + <ClCompile Include="..\bpser.c" /> + <ClCompile Include="..\bratio.c" /> + <ClCompile Include="..\brcmp1.c" /> + <ClCompile Include="..\brcomp.c" /> + <ClCompile Include="..\bup.c" /> + <ClCompile Include="..\cdfbet.c" /> + <ClCompile Include="..\cdfbin.c" /> + <ClCompile Include="..\cdfchi.c" /> + <ClCompile Include="..\cdfchn.c" /> + <ClCompile Include="..\cdff.c" /> + <ClCompile Include="..\cdffnc.c" /> + <ClCompile Include="..\cdfgam.c" /> + <ClCompile Include="..\cdfnbn.c" /> + <ClCompile Include="..\cdfnor.c" /> + <ClCompile Include="..\cdfpoi.c" /> + <ClCompile Include="..\cdft.c" /> + <ClCompile Include="..\cumbet.c" /> + <ClCompile Include="..\cumbin.c" /> + <ClCompile Include="..\cumchi.c" /> + <ClCompile Include="..\cumchn.c" /> + <ClCompile Include="..\cumf.c" /> + <ClCompile Include="..\cumfnc.c" /> + <ClCompile Include="..\cumgam.c" /> + <ClCompile Include="..\cumnbn.c" /> + <ClCompile Include="..\cumnor.c" /> + <ClCompile Include="..\cumpoi.c" /> + <ClCompile Include="..\cumt.c" /> + <ClCompile Include="..\devlpl.c" /> + <ClCompile Include="..\dexpm1.c" /> + <ClCompile Include="..\dinvnr.c" /> + <ClCompile Include="..\dinvr.c" /> + <ClCompile Include="..\dt1.c" /> + <ClCompile Include="..\dzror.c" /> + <ClCompile Include="..\erf.c" /> + <ClCompile Include="..\erfc1.c" /> + <ClCompile Include="..\esum.c" /> + <ClCompile Include="..\exparg.c" /> + <ClCompile Include="..\fpser.c" /> + <ClCompile Include="..\gam1.c" /> + <ClCompile Include="..\gaminv.c" /> + <ClCompile Include="..\gamln.c" /> + <ClCompile Include="..\gamln1.c" /> + <ClCompile Include="..\gamma.c" /> + <ClCompile Include="..\grat1.c" /> + <ClCompile Include="..\gratio.c" /> + <ClCompile Include="..\gsumln.c" /> + <ClCompile Include="..\ipmpar.c" /> + <ClCompile Include="..\psi.c" /> + <ClCompile Include="..\rcomp.c" /> + <ClCompile Include="..\rexp.c" /> + <ClCompile Include="..\rlog.c" /> + <ClCompile Include="..\rlog1.c" /> + <ClCompile Include="..\spmpar.c" /> + <ClCompile Include="..\stvaln.c" /> + </ItemGroup> + <ItemGroup> + <f2c_rule Include="..\algdiv.f" /> + <f2c_rule Include="..\alngam.f" /> + <f2c_rule Include="..\alnrel.f" /> + <f2c_rule Include="..\apser.f" /> + <f2c_rule Include="..\basym.f" /> + <f2c_rule Include="..\bcorr.f" /> + <f2c_rule Include="..\betaln.f" /> + <f2c_rule Include="..\bfrac.f" /> + <f2c_rule Include="..\bgrat.f" /> + <f2c_rule Include="..\bpser.f" /> + <f2c_rule Include="..\bratio.f" /> + <f2c_rule Include="..\brcmp1.f" /> + <f2c_rule Include="..\brcomp.f" /> + <f2c_rule Include="..\bup.f" /> + <f2c_rule Include="..\cdfbet.f" /> + <f2c_rule Include="..\cdfbin.f" /> + <f2c_rule Include="..\cdfchi.f" /> + <f2c_rule Include="..\cdfchn.f" /> + <f2c_rule Include="..\cdff.f" /> + <f2c_rule Include="..\cdffnc.f" /> + <f2c_rule Include="..\cdfgam.f" /> + <f2c_rule Include="..\cdfnbn.f" /> + <f2c_rule Include="..\cdfnor.f" /> + <f2c_rule Include="..\cdfpoi.f" /> + <f2c_rule Include="..\cdft.f" /> + <f2c_rule Include="..\cumbet.f" /> + <f2c_rule Include="..\cumbin.f" /> + <f2c_rule Include="..\cumchi.f" /> + <f2c_rule Include="..\cumchn.f" /> + <f2c_rule Include="..\cumf.f" /> + <f2c_rule Include="..\cumfnc.f" /> + <f2c_rule Include="..\cumgam.f" /> + <f2c_rule Include="..\cumnbn.f" /> + <f2c_rule Include="..\cumnor.f" /> + <f2c_rule Include="..\cumpoi.f" /> + <f2c_rule Include="..\cumt.f" /> + <f2c_rule Include="..\devlpl.f" /> + <f2c_rule Include="..\dexpm1.f" /> + <f2c_rule Include="..\dinvnr.f" /> + <f2c_rule Include="..\dinvr.f" /> + <f2c_rule Include="..\dt1.f" /> + <f2c_rule Include="..\dzror.f" /> + <f2c_rule Include="..\erf.f" /> + <f2c_rule Include="..\erfc1.f" /> + <f2c_rule Include="..\esum.f" /> + <f2c_rule Include="..\exparg.f" /> + <f2c_rule Include="..\fpser.f" /> + <f2c_rule Include="..\gam1.f" /> + <f2c_rule Include="..\gaminv.f" /> + <f2c_rule Include="..\gamln.f" /> + <f2c_rule Include="..\gamln1.f" /> + <f2c_rule Include="..\gamma.f" /> + <f2c_rule Include="..\grat1.f" /> + <f2c_rule Include="..\gratio.f" /> + <f2c_rule Include="..\gsumln.f" /> + <f2c_rule Include="..\ipmpar.f" /> + <f2c_rule Include="..\psi.f" /> + <f2c_rule Include="..\rcomp.f" /> + <f2c_rule Include="..\rexp.f" /> + <f2c_rule Include="..\rlog.f" /> + <f2c_rule Include="..\rlog1.f" /> + <f2c_rule Include="..\spmpar.f" /> + <f2c_rule Include="..\stvaln.f" /> + </ItemGroup> + <ItemGroup> + <ProjectReference Include="..\..\..\..\..\tools\Dumpexts\Dumpexts.vcxproj"> + <Project>{3170e4c2-1173-4264-a222-7ee8ccb3ddf7}</Project> + <ReferenceOutputAssembly>false</ReferenceOutputAssembly> + </ProjectReference> + </ItemGroup> + <ItemGroup> + <None Include="Core_Import.def" /> + <None Include="elementary_functions_Import.def" /> + <None Include="Output_stream_Import.def" /> + <None Include="statistics_Import.def" /> + </ItemGroup> + <Import Project="$(VCTargetsPath)\Microsoft.Cpp.targets" /> + <ImportGroup Label="ExtensionTargets"> + <Import Project="..\..\..\..\..\Visual-Studio-settings\f2c.targets" /> + </ImportGroup> +</Project>
\ No newline at end of file diff --git a/modules/statistics/src/dcdflib/dcd_f/dcd_f2c.vcxproj.filters b/modules/statistics/src/dcdflib/dcd_f/dcd_f2c.vcxproj.filters new file mode 100755 index 000000000..6b6f23664 --- /dev/null +++ b/modules/statistics/src/dcdflib/dcd_f/dcd_f2c.vcxproj.filters @@ -0,0 +1,419 @@ +<?xml version="1.0" encoding="utf-8"?> +<Project ToolsVersion="4.0" xmlns="http://schemas.microsoft.com/developer/msbuild/2003"> + <ItemGroup> + <Filter Include="Source Files"> + <UniqueIdentifier>{7d075f4e-52ed-4136-9595-24c161c733ad}</UniqueIdentifier> + <Extensions>cpp;c;cxx;def;odl;idl;hpj;bat;asm;asmx</Extensions> + </Filter> + <Filter Include="Header Files"> + <UniqueIdentifier>{e2e9018b-5554-426b-9da6-00a017f92995}</UniqueIdentifier> + <Extensions>h;hpp;hxx;hm;inl;inc;xsd</Extensions> + </Filter> + <Filter Include="Resource Files"> + <UniqueIdentifier>{1abd3bc3-5847-4224-80ef-30a7537f9d17}</UniqueIdentifier> + <Extensions>rc;ico;cur;bmp;dlg;rc2;rct;bin;rgs;gif;jpg;jpeg;jpe;resx</Extensions> + </Filter> + <Filter Include="Fortran Files"> + <UniqueIdentifier>{133e4c80-9122-491c-8021-24677524d571}</UniqueIdentifier> + </Filter> + <Filter Include="Library Dependencies"> + <UniqueIdentifier>{4417abf3-7c8c-4472-b063-06a3aac0bd43}</UniqueIdentifier> + </Filter> + </ItemGroup> + <ItemGroup> + <ClCompile Include="..\algdiv.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\alngam.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\alnrel.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\apser.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\basym.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\bcorr.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\betaln.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\bfrac.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\bgrat.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\bpser.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\bratio.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\brcmp1.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\brcomp.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\bup.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\cdfbet.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\cdfbin.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\cdfchi.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\cdfchn.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\cdff.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\cdffnc.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\cdfgam.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\cdfnbn.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\cdfnor.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\cdfpoi.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\cdft.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\cumbet.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\cumbin.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\cumchi.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\cumchn.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\cumf.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\cumfnc.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\cumgam.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\cumnbn.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\cumnor.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\cumpoi.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\cumt.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\devlpl.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\dexpm1.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\dinvnr.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\dinvr.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\dt1.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\dzror.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\erf.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\erfc1.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\esum.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\exparg.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\fpser.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\gam1.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\gaminv.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\gamln.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\gamln1.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\gamma.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\grat1.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\gratio.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\gsumln.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\ipmpar.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\psi.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\rcomp.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\rexp.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\rlog.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\rlog1.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\spmpar.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\stvaln.c"> + <Filter>Source Files</Filter> + </ClCompile> + </ItemGroup> + <ItemGroup> + <f2c_rule Include="..\algdiv.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\alngam.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\alnrel.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\apser.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\basym.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\bcorr.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\betaln.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\bfrac.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\bgrat.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\bpser.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\bratio.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\brcmp1.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\brcomp.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\bup.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\cdfbet.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\cdfbin.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\cdfchi.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\cdfchn.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\cdff.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\cdffnc.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\cdfgam.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\cdfnbn.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\cdfnor.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\cdfpoi.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\cdft.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\cumbet.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\cumbin.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\cumchi.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\cumchn.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\cumf.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\cumfnc.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\cumgam.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\cumnbn.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\cumnor.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\cumpoi.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\cumt.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\devlpl.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\dexpm1.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\dinvnr.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\dinvr.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\dt1.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\dzror.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\erf.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\erfc1.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\esum.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\exparg.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\fpser.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\gam1.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\gaminv.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\gamln.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\gamln1.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\gamma.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\grat1.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\gratio.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\gsumln.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\ipmpar.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\psi.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\rcomp.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\rexp.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\rlog.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\rlog1.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\spmpar.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="..\stvaln.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + </ItemGroup> + <ItemGroup> + <None Include="Output_stream_Import.def"> + <Filter>Library Dependencies</Filter> + </None> + <None Include="statistics_Import.def"> + <Filter>Library Dependencies</Filter> + </None> + <None Include="Core_Import.def"> + <Filter>Library Dependencies</Filter> + </None> + <None Include="elementary_functions_Import.def"> + <Filter>Library Dependencies</Filter> + </None> + </ItemGroup> +</Project>
\ No newline at end of file diff --git a/modules/statistics/src/dcdflib/dcd_f/elementary_functions_Import.def b/modules/statistics/src/dcdflib/dcd_f/elementary_functions_Import.def new file mode 100755 index 000000000..575b928ac --- /dev/null +++ b/modules/statistics/src/dcdflib/dcd_f/elementary_functions_Import.def @@ -0,0 +1,6 @@ +LIBRARY elementary_functions.dll + + +EXPORTS +; +vfinite_
\ No newline at end of file diff --git a/modules/statistics/src/dcdflib/dcd_f/statistics_Import.def b/modules/statistics/src/dcdflib/dcd_f/statistics_Import.def new file mode 100755 index 000000000..bb1cd868f --- /dev/null +++ b/modules/statistics/src/dcdflib/dcd_f/statistics_Import.def @@ -0,0 +1,6 @@ +LIBRARY statistics.dll + + +EXPORTS +; +largestint_
\ No newline at end of file diff --git a/modules/statistics/src/dcdflib/devlpl.f b/modules/statistics/src/dcdflib/devlpl.f new file mode 100755 index 000000000..222014311 --- /dev/null +++ b/modules/statistics/src/dcdflib/devlpl.f @@ -0,0 +1,48 @@ + DOUBLE PRECISION FUNCTION devlpl(a,n,x) +C********************************************************************** +C +C DOUBLE PRECISION FUNCTION DEVLPL(A,N,X) +C Double precision EVALuate a PoLynomial at X +C +C +C Function +C +C +C returns +C A(1) + A(2)*X + ... + A(N)*X**(N-1) +C +C +C Arguments +C +C +C A --> Array of coefficients of the polynomial. +C A is DOUBLE PRECISION(N) +C +C N --> Length of A, also degree of polynomial - 1. +C N is INTEGER +C +C X --> Point at which the polynomial is to be evaluated. +C X is DOUBLE PRECISION +C +C********************************************************************** +C +C .. Scalar Arguments .. + DOUBLE PRECISION x + INTEGER n +C .. +C .. Array Arguments .. + DOUBLE PRECISION a(n) +C .. +C .. Local Scalars .. + DOUBLE PRECISION term + INTEGER i +C .. +C .. Executable Statements .. + term = a(n) + DO 10,i = n - 1,1,-1 + term = a(i) + term*x + 10 CONTINUE + devlpl = term + RETURN + + END diff --git a/modules/statistics/src/dcdflib/devlpl.lo b/modules/statistics/src/dcdflib/devlpl.lo new file mode 100755 index 000000000..98a676b47 --- /dev/null +++ b/modules/statistics/src/dcdflib/devlpl.lo @@ -0,0 +1,12 @@ +# src/dcdflib/devlpl.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/devlpl.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/statistics/src/dcdflib/dexpm1.f b/modules/statistics/src/dcdflib/dexpm1.f new file mode 100755 index 000000000..25108a825 --- /dev/null +++ b/modules/statistics/src/dcdflib/dexpm1.f @@ -0,0 +1,54 @@ + DOUBLE PRECISION FUNCTION dcddexpm1(x) +C********************************************************************** +C +C DOUBLE PRECISION FUNCTION dcddexpm1(x) +C Evaluation of the function EXP(X) - 1 +C +C +C Arguments +C +C +C X --> Argument at which exp(x)-1 desired +C DOUBLE PRECISION X +C +C +C Method +C +C +C Renaming of function rexp from code of: +C +C DiDinato, A. R. and Morris, A. H. Algorithm 708: Significant +C Digit Computation of the Incomplete Beta Function Ratios. ACM +C Trans. Math. Softw. 18 (1993), 360-373. +C +C********************************************************************** +C .. Scalar Arguments .. + DOUBLE PRECISION x +C .. +C .. Local Scalars .. + DOUBLE PRECISION p1,p2,q1,q2,q3,q4,w +C .. +C .. Intrinsic Functions .. + INTRINSIC abs,exp +C .. +C .. Data statements .. + DATA p1/.914041914819518D-09/,p2/.238082361044469D-01/, + + q1/-.499999999085958D+00/,q2/.107141568980644D+00/, + + q3/-.119041179760821D-01/,q4/.595130811860248D-03/ +C .. +C .. Executable Statements .. +C + IF (abs(x).GT.0.15D0) GO TO 10 + dcddexpm1 = x* (((p2*x+p1)*x+1.0D0)/ + + ((((q4*x+q3)*x+q2)*x+q1)*x+1.0D0)) + RETURN +C + 10 w = exp(x) + IF (x.GT.0.0D0) GO TO 20 + dcddexpm1 = (w-0.5D0) - 0.5D0 + RETURN + + 20 dcddexpm1 = w* (0.5D0+ (0.5D0-1.0D0/w)) + RETURN + + END diff --git a/modules/statistics/src/dcdflib/dinvnr.f b/modules/statistics/src/dcdflib/dinvnr.f new file mode 100755 index 000000000..27293f97b --- /dev/null +++ b/modules/statistics/src/dcdflib/dinvnr.f @@ -0,0 +1,115 @@ + DOUBLE PRECISION FUNCTION dinvnr(p,q) +C********************************************************************** +C +C DOUBLE PRECISION FUNCTION DINVNR(P,Q) +C Double precision NoRmal distribution INVerse +C +C +C Function +C +C +C Returns X such that CUMNOR(X) = P, i.e., the integral from - +C infinity to X of (1/SQRT(2*PI)) EXP(-U*U/2) dU is P +C +C +C Arguments +C +C +C P --> The probability whose normal deviate is sought. +C P is DOUBLE PRECISION +C +C Q --> 1-P +C P is DOUBLE PRECISION +C +C +C Method +C +C +C The rational function on page 95 of Kennedy and Gentle, +C Statistical Computing, Marcel Dekker, NY , 1980 is used as a start +C value for the Newton method of finding roots. +C +C +C Note +C +C +C If P or Q .lt. machine EPS returns +/- DINVNR(EPS) +C +C********************************************************************** +C .. Parameters .. + INTEGER maxit + PARAMETER (maxit=100) + DOUBLE PRECISION eps + PARAMETER (eps=1.0D-13) + DOUBLE PRECISION r2pi + PARAMETER (r2pi=0.3989422804014326D0) + DOUBLE PRECISION nhalf + PARAMETER (nhalf=-0.5D0) +C .. +C .. Scalar Arguments .. + DOUBLE PRECISION p,q +C .. +C .. Local Scalars .. + DOUBLE PRECISION strtx,xcur,cum,ccum,pp,dx + INTEGER i + LOGICAL qporq +C .. +C .. External Functions .. + DOUBLE PRECISION stvaln + EXTERNAL stvaln +C .. +C .. External Subroutines .. + EXTERNAL cumnor +C .. +C .. Statement Functions .. + DOUBLE PRECISION dennor,x + + dennor(x) = r2pi*exp(nhalf*x*x) +C .. +C .. Executable Statements .. +C +C FIND MINIMUM OF P AND Q +C + qporq = p .LE. q + IF (.NOT. (qporq)) THEN + pp = q + ELSE + pp = p + ENDIF +c +c DIGITEO - M. Baudin - 2010 +c Patched for bug #8032. +c Avoid to enter in the zero-finder algorithm in trivial case. +c + IF ( pp .EQ. 0.5d0 ) THEN + dinvnr = 0.d0 + RETURN + ENDIF +C +C INITIALIZATION STEP +C + strtx = stvaln(pp) + xcur = strtx +C +C NEWTON INTERATIONS +C + DO 30,i = 1,maxit + CALL cumnor(xcur,cum,ccum) + dx = (cum-pp)/dennor(xcur) + xcur = xcur - dx + IF (abs(dx/xcur).LT.eps) GO TO 40 + 30 CONTINUE + dinvnr = strtx +C +C IF WE GET HERE, NEWTON HAS FAILED +C + IF (.NOT.qporq) dinvnr = -dinvnr + RETURN +C +C IF WE GET HERE, NEWTON HAS SUCCEDED +C + 40 dinvnr = xcur + IF (.NOT.qporq) dinvnr = -dinvnr + RETURN + + END diff --git a/modules/statistics/src/dcdflib/dinvnr.lo b/modules/statistics/src/dcdflib/dinvnr.lo new file mode 100755 index 000000000..fb5913334 --- /dev/null +++ b/modules/statistics/src/dcdflib/dinvnr.lo @@ -0,0 +1,12 @@ +# src/dcdflib/dinvnr.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/dinvnr.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/statistics/src/dcdflib/dinvr.f b/modules/statistics/src/dcdflib/dinvr.f new file mode 100755 index 000000000..69189e0d8 --- /dev/null +++ b/modules/statistics/src/dcdflib/dinvr.f @@ -0,0 +1,363 @@ + SUBROUTINE dinvr(status,x,fx,qleft,qhi) +C********************************************************************** +C +C SUBROUTINE DINVR(STATUS, X, FX, QLEFT, QHI) +C Double precision +C bounds the zero of the function and invokes zror +C Reverse Communication +C +C +C Function +C +C +C Bounds the function and invokes ZROR to perform the zero +C finding. STINVR must have been called before this routine +C in order to set its parameters. +C +C +C Arguments +C +C +C STATUS <--> At the beginning of a zero finding problem, STATUS +C should be set to 0 and INVR invoked. (The value +C of parameters other than X will be ignored on this cal +C +C When INVR needs the function evaluated, it will set +C STATUS to 1 and return. The value of the function +C should be set in FX and INVR again called without +C changing any of its other parameters. +C +C When INVR has finished without error, it will return +C with STATUS 0. In that case X is approximately a root +C of F(X). +C +C If INVR cannot bound the function, it returns status +C -1 and sets QLEFT and QHI. +C INTEGER STATUS +C +C X <-- The value of X at which F(X) is to be evaluated. +C DOUBLE PRECISION X +C +C FX --> The value of F(X) calculated when INVR returns with +C STATUS = 1. +C DOUBLE PRECISION FX +C +C QLEFT <-- Defined only if QMFINV returns .FALSE. In that +C case it is .TRUE. If the stepping search terminated +C unsucessfully at SMALL. If it is .FALSE. the search +C terminated unsucessfully at BIG. +C QLEFT is LOGICAL +C +C QHI <-- Defined only if QMFINV returns .FALSE. In that +C case it is .TRUE. if F(X) .GT. Y at the termination +C of the search and .FALSE. if F(X) .LT. Y at the +C termination of the search. +C QHI is LOGICAL + +C +C********************************************************************** +C Modified by S. Steer INRIA 1998,to replace ASSIGN instruction by +c Computed GOTO +C********************************************************************** + include 'stack.h' +C .. Scalar Arguments .. + DOUBLE PRECISION fx,x,zabsst,zabsto,zbig,zrelst,zrelto,zsmall, + + zstpmu + INTEGER status + LOGICAL qhi,qleft +C .. +C .. Local Scalars .. + DOUBLE PRECISION absstp,abstol,big,fbig,fsmall,relstp,reltol, + + small,step,stpmul,xhi,xlb,xlo,xsave,xub,yy,zx,zy, + + zz + INTEGER i99999 + LOGICAL qbdd,qcond,qdum1,qdum2,qincr,qlim,qok,qup +C .. +C .. External Subroutines .. + EXTERNAL dstzr,dzror +C .. +C .. Intrinsic Functions .. + INTRINSIC abs,max,min +C .. +C .. Statement Functions .. + LOGICAL qxmon +C .. +C .. Save statement .. + SAVE +C .. +C .. Statement Function definitions .. + qxmon(zx,zy,zz) = zx .LE. zy .AND. zy .LE. zz +C .. +C .. Executable Statements .. + + IF (status.GT.0) GO TO 310 + + qcond = .NOT. qxmon(small,x,big) + IF (qcond) then + call basout(io,wte,' SMALL, X, BIG not monotone in INVR') + status = -100 + return + endif + xsave = x +C +C See that SMALL and BIG bound the zero and set QINCR +C + x = small +C GET-FUNCTION-VALUE +c ASSIGN 10 TO i99999 + i99999=1 + GO TO 300 + + 10 fsmall = fx + x = big +C GET-FUNCTION-VALUE +c ASSIGN 20 TO i99999 + i99999=2 + GO TO 300 + + 20 fbig = fx + qincr = fbig .GT. fsmall + IF (.NOT. (qincr)) GO TO 50 + IF (fsmall.LE.0.0D0) GO TO 30 + status = -1 + qleft = .TRUE. + qhi = .TRUE. + RETURN + + 30 IF (fbig.GE.0.0D0) GO TO 40 + status = -1 + qleft = .FALSE. + qhi = .FALSE. + RETURN + + 40 GO TO 80 + + 50 IF (fsmall.GE.0.0D0) GO TO 60 + status = -1 + qleft = .TRUE. + qhi = .FALSE. + RETURN + + 60 IF (fbig.LE.0.0D0) GO TO 70 + status = -1 + qleft = .FALSE. + qhi = .TRUE. + RETURN + + 70 CONTINUE + 80 x = xsave + step = max(absstp,relstp*abs(x)) +C YY = F(X) - Y +C GET-FUNCTION-VALUE +c ASSIGN 90 TO i99999 + i99999=3 + GO TO 300 + + 90 yy = fx + IF (.NOT. (yy.EQ.0.0D0)) GO TO 100 + status = 0 + qok = .TRUE. + RETURN + + 100 qup = (qincr .AND. (yy.LT.0.0D0)) .OR. + + (.NOT.qincr .AND. (yy.GT.0.0D0)) +C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +C +C HANDLE CASE IN WHICH WE MUST STEP HIGHER +C +C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + IF (.NOT. (qup)) GO TO 170 + xlb = xsave + xub = min(xlb+step,big) + GO TO 120 + + 110 IF (qcond) GO TO 150 +C YY = F(XUB) - Y + 120 x = xub +C GET-FUNCTION-VALUE +c ASSIGN 130 TO i99999 + i99999=4 + GO TO 300 + + 130 yy = fx + qbdd = (qincr .AND. (yy.GE.0.0D0)) .OR. + + (.NOT.qincr .AND. (yy.LE.0.0D0)) + qlim = xub .GE. big + qcond = qbdd .OR. qlim + IF (qcond) GO TO 140 + step = stpmul*step + xlb = xub + xub = min(xlb+step,big) + 140 GO TO 110 + + 150 IF (.NOT. (qlim.AND..NOT.qbdd)) GO TO 160 + status = -1 + qleft = .FALSE. + qhi = .NOT. qincr + x = big + RETURN + + 160 GO TO 240 +C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +C +C HANDLE CASE IN WHICH WE MUST STEP LOWER +C +C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + 170 xub = xsave + xlb = max(xub-step,small) + GO TO 190 + + 180 IF (qcond) GO TO 220 +C YY = F(XLB) - Y + 190 x = xlb +C GET-FUNCTION-VALUE +c ASSIGN 200 TO i99999 + i99999=5 + GO TO 300 + + 200 yy = fx + qbdd = (qincr .AND. (yy.LE.0.0D0)) .OR. + + (.NOT.qincr .AND. (yy.GE.0.0D0)) + qlim = xlb .LE. small + qcond = qbdd .OR. qlim + IF (qcond) GO TO 210 + step = stpmul*step + xub = xlb + xlb = max(xub-step,small) + 210 GO TO 180 + + 220 IF (.NOT. (qlim.AND..NOT.qbdd)) GO TO 230 + status = -1 + qleft = .TRUE. + qhi = qincr + x = small + RETURN + + 230 CONTINUE + 240 CALL dstzr(xlb,xub,abstol,reltol) +C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +C +C IF WE REACH HERE, XLB AND XUB BOUND THE ZERO OF F. +C +C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + status = 0 + GO TO 260 + + 250 IF (.NOT. (status.EQ.1)) GO TO 290 + 260 CALL dzror(status,x,fx,xlo,xhi,qdum1,qdum2) + IF (.NOT. (status.EQ.1)) GO TO 280 +C GET-FUNCTION-VALUE +c ASSIGN 270 TO i99999 + i99999=6 + GO TO 300 + + 270 CONTINUE + 280 GO TO 250 + + 290 x = xlo + status = 0 + RETURN + + ENTRY dstinv(zsmall,zbig,zabsst,zrelst,zstpmu,zabsto,zrelto) +C********************************************************************** +C +C SUBROUTINE DSTINV( SMALL, BIG, ABSSTP, RELSTP, STPMUL, +C + ABSTOL, RELTOL ) +C Double Precision - SeT INverse finder - Reverse Communication +C +C +C Function +C +C +C Concise Description - Given a monotone function F finds X +C such that F(X) = Y. Uses Reverse communication -- see invr. +C This routine sets quantities needed by INVR. +C +C More Precise Description of INVR - +C +C F must be a monotone function, the results of QMFINV are +C otherwise undefined. QINCR must be .TRUE. if F is non- +C decreasing and .FALSE. if F is non-increasing. +C +C QMFINV will return .TRUE. if and only if F(SMALL) and +C F(BIG) bracket Y, i. e., +C QINCR is .TRUE. and F(SMALL).LE.Y.LE.F(BIG) or +C QINCR is .FALSE. and F(BIG).LE.Y.LE.F(SMALL) +C +C if QMFINV returns .TRUE., then the X returned satisfies +C the following condition. let +C TOL(X) = MAX(ABSTOL,RELTOL*ABS(X)) +C then if QINCR is .TRUE., +C F(X-TOL(X)) .LE. Y .LE. F(X+TOL(X)) +C and if QINCR is .FALSE. +C F(X-TOL(X)) .GE. Y .GE. F(X+TOL(X)) +C +C +C Arguments +C +C +C SMALL --> The left endpoint of the interval to be +C searched for a solution. +C SMALL is DOUBLE PRECISION +C +C BIG --> The right endpoint of the interval to be +C searched for a solution. +C BIG is DOUBLE PRECISION +C +C ABSSTP, RELSTP --> The initial step size in the search +C is MAX(ABSSTP,RELSTP*ABS(X)). See algorithm. +C ABSSTP is DOUBLE PRECISION +C RELSTP is DOUBLE PRECISION +C +C STPMUL --> When a step doesn't bound the zero, the step +C size is multiplied by STPMUL and another step +C taken. A popular value is 2.0 +C DOUBLE PRECISION STPMUL +C +C ABSTOL, RELTOL --> Two numbers that determine the accuracy +C of the solution. See function for a precise definition. +C ABSTOL is DOUBLE PRECISION +C RELTOL is DOUBLE PRECISION +C +C +C Method +C +C +C Compares F(X) with Y for the input value of X then uses QINCR +C to determine whether to step left or right to bound the +C desired x. the initial step size is +C MAX(ABSSTP,RELSTP*ABS(S)) for the input value of X. +C Iteratively steps right or left until it bounds X. +C At each step which doesn't bound X, the step size is doubled. +C The routine is careful never to step beyond SMALL or BIG. If +C it hasn't bounded X at SMALL or BIG, QMFINV returns .FALSE. +C after setting QLEFT and QHI. +C +C If X is successfully bounded then Algorithm R of the paper +C 'Two Efficient Algorithms with Guaranteed Convergence for +C Finding a Zero of a Function' by J. C. P. Bus and +C T. J. Dekker in ACM Transactions on Mathematical +C Software, Volume 1, No. 4 page 330 (DEC. '75) is employed +C to find the zero of the function F(X)-Y. This is routine +C QRZERO. +C +C********************************************************************** + small = zsmall + big = zbig + absstp = zabsst + relstp = zrelst + stpmul = zstpmu + abstol = zabsto + reltol = zrelto + RETURN + +C(jpc) STOP '*** EXECUTION FLOWING INTO FLECS PROCEDURES ***' +C TO GET-FUNCTION-VALUE + 300 status = 1 + RETURN + + 310 CONTINUE + goto(10,20,90,130,200,270) i99999 +c GO TO i99999 + + END diff --git a/modules/statistics/src/dcdflib/dinvr.lo b/modules/statistics/src/dcdflib/dinvr.lo new file mode 100755 index 000000000..78fee2669 --- /dev/null +++ b/modules/statistics/src/dcdflib/dinvr.lo @@ -0,0 +1,12 @@ +# src/dcdflib/dinvr.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/dinvr.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/statistics/src/dcdflib/dt1.f b/modules/statistics/src/dcdflib/dt1.f new file mode 100755 index 000000000..3a940381a --- /dev/null +++ b/modules/statistics/src/dcdflib/dt1.f @@ -0,0 +1,76 @@ + DOUBLE PRECISION FUNCTION dt1(p,q,df) +C********************************************************************** +C +C DOUBLE PRECISION FUNCTION DT1(P,Q,DF) +C Double precision Initalize Approximation to +C INVerse of the cumulative T distribution +C +C +C Function +C +C +C Returns the inverse of the T distribution function, i.e., +C the integral from 0 to INVT of the T density is P. This is an +C initial approximation +C +C +C Arguments +C +C +C P --> The p-value whose inverse from the T distribution is +C desired. +C P is DOUBLE PRECISION +C +C Q --> 1-P. +C Q is DOUBLE PRECISION +C +C DF --> Degrees of freedom of the T distribution. +C DF is DOUBLE PRECISION +C +C********************************************************************** +C +C .. Scalar Arguments .. + DOUBLE PRECISION df,p,q +C .. +C .. Local Scalars .. + DOUBLE PRECISION denpow,sum,term,x,xp,xx + INTEGER i +C .. +C .. Local Arrays .. + DOUBLE PRECISION coef(5,4),denom(4) + INTEGER ideg(4) +C .. +C .. External Functions .. + DOUBLE PRECISION dinvnr,devlpl + EXTERNAL dinvnr,devlpl +C .. +C .. Intrinsic Functions .. + INTRINSIC abs +C .. +C .. Data statements .. + DATA (coef(i,1),i=1,5)/1.0D0,1.0D0,3*0.0D0/ + DATA (coef(i,2),i=1,5)/3.0D0,16.0D0,5.0D0,2*0.0D0/ + DATA (coef(i,3),i=1,5)/-15.0D0,17.0D0,19.0D0,3.0D0,0.0D0/ + DATA (coef(i,4),i=1,5)/-945.0D0,-1920.0D0,1482.0D0,776.0D0,79.0D0/ + DATA ideg/2,3,4,5/ + DATA denom/4.0D0,96.0D0,384.0D0,92160.0D0/ +C .. +C .. Executable Statements .. + x = abs(dinvnr(p,q)) + xx = x*x + sum = x + denpow = 1.0D0 + DO 10,i = 1,4 + term = devlpl(coef(1,i),ideg(i),xx)*x + denpow = denpow*df + sum = sum + term/ (denpow*denom(i)) + 10 CONTINUE + IF (.NOT. (p.GE.0.5D0)) GO TO 20 + xp = sum + GO TO 30 + + 20 xp = -sum + 30 dt1 = xp + RETURN + + END diff --git a/modules/statistics/src/dcdflib/dt1.lo b/modules/statistics/src/dcdflib/dt1.lo new file mode 100755 index 000000000..c05e8a5d8 --- /dev/null +++ b/modules/statistics/src/dcdflib/dt1.lo @@ -0,0 +1,12 @@ +# src/dcdflib/dt1.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/dt1.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/statistics/src/dcdflib/dzror.f b/modules/statistics/src/dcdflib/dzror.f new file mode 100755 index 000000000..caafd7b0b --- /dev/null +++ b/modules/statistics/src/dcdflib/dzror.f @@ -0,0 +1,296 @@ + SUBROUTINE dzror(status,x,fx,xlo,xhi,qleft,qhi) +C********************************************************************** +C +C SUBROUTINE DZROR(STATUS, X, FX, XLO, XHI, QLEFT, QHI) +C Double precision ZeRo of a function -- Reverse Communication +C +C +C Function +C +C +C Performs the zero finding. STZROR must have been called before +C this routine in order to set its parameters. +C +C +C Arguments +C +C +C STATUS <--> At the beginning of a zero finding problem, STATUS +C should be set to 0 and ZROR invoked. (The value +C of other parameters will be ignored on this call.) +C +C When ZROR needs the function evaluated, it will set +C STATUS to 1 and return. The value of the function +C should be set in FX and ZROR again called without +C changing any of its other parameters. +C +C When ZROR has finished without error, it will return +C with STATUS 0. In that case (XLO,XHI) bound the answe +C +C If ZROR finds an error (which implies that F(XLO)-Y an +C F(XHI)-Y have the same sign, it returns STATUS -1. In +C this case, XLO and XHI are undefined. +C INTEGER STATUS +C +C X <-- The value of X at which F(X) is to be evaluated. +C DOUBLE PRECISION X +C +C FX --> The value of F(X) calculated when ZROR returns with +C STATUS = 1. +C DOUBLE PRECISION FX +C +C XLO <-- When ZROR returns with STATUS = 0, XLO bounds the +C inverval in X containing the solution below. +C DOUBLE PRECISION XLO +C +C XHI <-- When ZROR returns with STATUS = 0, XHI bounds the +C inverval in X containing the solution above. +C DOUBLE PRECISION XHI +C +C QLEFT <-- .TRUE. if the stepping search terminated unsucessfully +C at XLO. If it is .FALSE. the search terminated +C unsucessfully at XHI. +C QLEFT is LOGICAL +C +C QHI <-- .TRUE. if F(X) .GT. Y at the termination of the +C search and .FALSE. if F(X) .LT. Y at the +C termination of the search. +C QHI is LOGICAL +C +C********************************************************************** +C********************************************************************** +C Modified by S. Steer INRIA 1998,to replace ASSIGN instruction by +c Computed GOTO +C********************************************************************** +C .. Scalar Arguments .. + DOUBLE PRECISION fx,x,xhi,xlo,zabstl,zreltl,zxhi,zxlo + INTEGER status + LOGICAL qhi,qleft +C .. +C .. Save statement .. + SAVE +C .. +C .. Local Scalars .. + DOUBLE PRECISION a,abstol,b,c,d,fa,fb,fc,fd,fda,fdb,m,mb,p,q, + + reltol,tol,w,xxhi,xxlo,zx + INTEGER ext,i99999 + LOGICAL first,qrzero +C .. +C .. Intrinsic Functions .. + INTRINSIC abs,max,sign +C .. +C .. Statement Functions .. + DOUBLE PRECISION ftol,dlamch +C .. +C .. Statement Function definitions .. + ftol(zx) = 0.5D0*max(abstol,reltol*abs(zx)) + eps = dlamch('e') +C .. +C .. Executable Statements .. + + IF (status.GT.0) GO TO 280 + xlo = xxlo + xhi = xxhi + b = xlo + x = xlo +C GET-FUNCTION-VALUE +c ASSIGN 10 TO i99999 + i99999=1 + GO TO 270 + + 10 fb = fx + xlo = xhi + a = xlo + x = xlo +C GET-FUNCTION-VALUE +c ASSIGN 20 TO i99999 + i99999=2 + GO TO 270 +C +C Check that F(ZXLO) < 0 < F(ZXHI) or +C F(ZXLO) > 0 > F(ZXHI) +C + 20 IF (.NOT. (fb.LT.0.0D0)) GO TO 40 + IF (.NOT. (fx.LT.0.0D0)) GO TO 30 + status = -1 + qleft = fx .LT. fb + qhi = .FALSE. + RETURN + + 30 CONTINUE + 40 IF (.NOT. (fb.GT.0.0D0)) GO TO 60 + IF (.NOT. (fx.GT.0.0D0)) GO TO 50 + status = -1 + qleft = fx .GT. fb + qhi = .TRUE. + RETURN + + 50 CONTINUE + 60 fa = fx +C + first = .TRUE. + 70 c = a + fc = fa + ext = 0 + 80 IF (.NOT. (abs(fc).LT.abs(fb))) GO TO 100 + IF (.NOT. (c.NE.a)) GO TO 90 + d = a + fd = fa + 90 a = b + fa = fb + xlo = c + b = xlo + fb = fc + c = a + fc = fa + 100 tol = ftol(xlo) + m = (c+b)*.5D0 + mb = m - b + IF (.NOT. (abs(mb).GT.tol)) GO TO 240 + IF (.NOT. (ext.GT.3)) GO TO 110 + w = mb + GO TO 190 + + 110 tol = sign(tol,mb) + p = (b-a)*fb + IF (.NOT. (first)) GO TO 120 + q = fa - fb + first = .FALSE. + GO TO 130 + + 120 fdb = (fd-fb)/ (d-b) + fda = (fd-fa)/ (d-a) + p = fda*p + q = fdb*fa - fda*fb + 130 IF (.NOT. (p.LT.0.0D0)) GO TO 140 + p = -p + q = -q + 140 IF (ext.EQ.3) p = p*2.0D0 + IF (.NOT. ((p*1.0D0).EQ.0.0D0.OR.p.LE. (q*tol))) GO TO 150 + w = tol + GO TO 180 + + 150 IF (.NOT. (p.LT. (mb*q))) GO TO 160 + w = p/q + GO TO 170 + + 160 w = mb + 170 CONTINUE + 180 CONTINUE + 190 d = a + fd = fa + a = b + fa = fb + b = b + w + xlo = b + x = xlo + if (x.lt.eps) then + x=0 + status = 0 + return + endif +C GET-FUNCTION-VALUE +c ASSIGN 200 TO i99999 + i99999=3 + GO TO 270 + + 200 fb = fx + IF (.NOT. ((fc*fb).GE.0.0D0)) GO TO 210 + GO TO 70 + + 210 IF (.NOT. (w.EQ.mb)) GO TO 220 + ext = 0 + GO TO 230 + + 220 ext = ext + 1 + 230 GO TO 80 + + 240 xhi = c + qrzero = (fc.GE.0.0D0 .AND. fb.LE.0.0D0) .OR. + + (fc.LT.0.0D0 .AND. fb.GE.0.0D0) + IF (.NOT. (qrzero)) GO TO 250 + status = 0 + GO TO 260 + + 250 status = -1 + 260 RETURN + + ENTRY dstzr(zxlo,zxhi,zabstl,zreltl) +C********************************************************************** +C +C SUBROUTINE DSTZR( XLO, XHI, ABSTOL, RELTOL ) +C Double precision SeT ZeRo finder - Reverse communication version +C +C +C Function +C +C +C +C Sets quantities needed by ZROR. The function of ZROR +C and the quantities set is given here. +C +C Concise Description - Given a function F +C find XLO such that F(XLO) = 0. +C +C More Precise Description - +C +C Input condition. F is a double precision function of a single +C double precision argument and XLO and XHI are such that +C F(XLO)*F(XHI) .LE. 0.0 +C +C If the input condition is met, QRZERO returns .TRUE. +C and output values of XLO and XHI satisfy the following +C F(XLO)*F(XHI) .LE. 0. +C ABS(F(XLO) .LE. ABS(F(XHI) +C ABS(XLO-XHI) .LE. TOL(X) +C where +C TOL(X) = MAX(ABSTOL,RELTOL*ABS(X)) +C +C If this algorithm does not find XLO and XHI satisfying +C these conditions then QRZERO returns .FALSE. This +C implies that the input condition was not met. +C +C +C Arguments +C +C +C XLO --> The left endpoint of the interval to be +C searched for a solution. +C XLO is DOUBLE PRECISION +C +C XHI --> The right endpoint of the interval to be +C for a solution. +C XHI is DOUBLE PRECISION +C +C ABSTOL, RELTOL --> Two numbers that determine the accuracy +C of the solution. See function for a +C precise definition. +C ABSTOL is DOUBLE PRECISION +C RELTOL is DOUBLE PRECISION +C +C +C Method +C +C +C Algorithm R of the paper 'Two Efficient Algorithms with +C Guaranteed Convergence for Finding a Zero of a Function' +C by J. C. P. Bus and T. J. Dekker in ACM Transactions on +C Mathematical Software, Volume 1, no. 4 page 330 +C (Dec. '75) is employed to find the zero of F(X)-Y. +C +C********************************************************************** + xxlo = zxlo + xxhi = zxhi + abstol = zabstl + reltol = zreltl + RETURN + +C(jpc) STOP '*** EXECUTION FLOWING INTO FLECS PROCEDURES ***' +C TO GET-FUNCTION-VALUE + 270 status = 1 + RETURN + + 280 CONTINUE + GO TO (10,20,200) i99999 + + END diff --git a/modules/statistics/src/dcdflib/dzror.lo b/modules/statistics/src/dcdflib/dzror.lo new file mode 100755 index 000000000..c92624866 --- /dev/null +++ b/modules/statistics/src/dcdflib/dzror.lo @@ -0,0 +1,12 @@ +# src/dcdflib/dzror.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/dzror.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/statistics/src/dcdflib/erf.f b/modules/statistics/src/dcdflib/erf.f new file mode 100755 index 000000000..98b32c56a --- /dev/null +++ b/modules/statistics/src/dcdflib/erf.f @@ -0,0 +1,74 @@ + DOUBLE PRECISION FUNCTION erf(x) +C----------------------------------------------------------------------- +C EVALUATION OF THE REAL ERROR FUNCTION +C----------------------------------------------------------------------- +C .. Scalar Arguments .. + DOUBLE PRECISION x +C .. +C .. Local Scalars .. + DOUBLE PRECISION ax,bot,c,t,top,x2 +C .. +C .. Local Arrays .. + DOUBLE PRECISION a(5),b(3),p(8),q(8),r(5),s(4) +C .. +C .. Intrinsic Functions .. + INTRINSIC abs,exp,sign +C .. +C .. Data statements .. +C------------------------- +C------------------------- +C------------------------- +C------------------------- + DATA c/.564189583547756D0/ + DATA a(1)/.771058495001320D-04/,a(2)/-.133733772997339D-02/, + + a(3)/.323076579225834D-01/,a(4)/.479137145607681D-01/, + + a(5)/.128379167095513D+00/ + DATA b(1)/.301048631703895D-02/,b(2)/.538971687740286D-01/, + + b(3)/.375795757275549D+00/ + DATA p(1)/-1.36864857382717D-07/,p(2)/5.64195517478974D-01/, + + p(3)/7.21175825088309D+00/,p(4)/4.31622272220567D+01/, + + p(5)/1.52989285046940D+02/,p(6)/3.39320816734344D+02/, + + p(7)/4.51918953711873D+02/,p(8)/3.00459261020162D+02/ + DATA q(1)/1.00000000000000D+00/,q(2)/1.27827273196294D+01/, + + q(3)/7.70001529352295D+01/,q(4)/2.77585444743988D+02/, + + q(5)/6.38980264465631D+02/,q(6)/9.31354094850610D+02/, + + q(7)/7.90950925327898D+02/,q(8)/3.00459260956983D+02/ + DATA r(1)/2.10144126479064D+00/,r(2)/2.62370141675169D+01/, + + r(3)/2.13688200555087D+01/,r(4)/4.65807828718470D+00/, + + r(5)/2.82094791773523D-01/ + DATA s(1)/9.41537750555460D+01/,s(2)/1.87114811799590D+02/, + + s(3)/9.90191814623914D+01/,s(4)/1.80124575948747D+01/ +C .. +C .. Executable Statements .. +C------------------------- + ax = abs(x) + IF (ax.GT.0.5D0) GO TO 10 + t = x*x + top = ((((a(1)*t+a(2))*t+a(3))*t+a(4))*t+a(5)) + 1.0D0 + bot = ((b(1)*t+b(2))*t+b(3))*t + 1.0D0 + erf = x* (top/bot) + RETURN +C + 10 IF (ax.GT.4.0D0) GO TO 20 + top = ((((((p(1)*ax+p(2))*ax+p(3))*ax+p(4))*ax+p(5))*ax+p(6))*ax+ + + p(7))*ax + p(8) + bot = ((((((q(1)*ax+q(2))*ax+q(3))*ax+q(4))*ax+q(5))*ax+q(6))*ax+ + + q(7))*ax + q(8) + erf = 0.5D0 + (0.5D0-exp(-x*x)*top/bot) + IF (x.LT.0.0D0) erf = -erf + RETURN +C + 20 IF (ax.GE.5.8D0) GO TO 30 + x2 = x*x + t = 1.0D0/x2 + top = (((r(1)*t+r(2))*t+r(3))*t+r(4))*t + r(5) + bot = (((s(1)*t+s(2))*t+s(3))*t+s(4))*t + 1.0D0 + erf = (c-top/ (x2*bot))/ax + erf = 0.5D0 + (0.5D0-exp(-x2)*erf) + IF (x.LT.0.0D0) erf = -erf + RETURN +C + 30 erf = sign(1.0D0,x) + RETURN + + END diff --git a/modules/statistics/src/dcdflib/erf.lo b/modules/statistics/src/dcdflib/erf.lo new file mode 100755 index 000000000..cf3262d0b --- /dev/null +++ b/modules/statistics/src/dcdflib/erf.lo @@ -0,0 +1,12 @@ +# src/dcdflib/erf.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/erf.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/statistics/src/dcdflib/erfc1.f b/modules/statistics/src/dcdflib/erfc1.f new file mode 100755 index 000000000..53d602306 --- /dev/null +++ b/modules/statistics/src/dcdflib/erfc1.f @@ -0,0 +1,111 @@ + DOUBLE PRECISION FUNCTION erfc1(ind,x) +C----------------------------------------------------------------------- +C EVALUATION OF THE COMPLEMENTARY ERROR FUNCTION +C +C ERFC1(IND,X) = ERFC(X) IF IND = 0 +C ERFC1(IND,X) = EXP(X*X)*ERFC(X) OTHERWISE +C----------------------------------------------------------------------- +C .. Scalar Arguments .. + DOUBLE PRECISION x + INTEGER ind +C .. +C .. Local Scalars .. + DOUBLE PRECISION ax,bot,c,e,t,top,w +C .. +C .. Local Arrays .. + DOUBLE PRECISION a(5),b(3),p(8),q(8),r(5),s(4) +C .. +C .. External Functions .. + DOUBLE PRECISION exparg + EXTERNAL exparg +C .. +C .. Intrinsic Functions .. + INTRINSIC abs,dble,exp +C .. +C .. Data statements .. +C------------------------- +C------------------------- +C------------------------- +C------------------------- + DATA c/.564189583547756D0/ + DATA a(1)/.771058495001320D-04/,a(2)/-.133733772997339D-02/, + + a(3)/.323076579225834D-01/,a(4)/.479137145607681D-01/, + + a(5)/.128379167095513D+00/ + DATA b(1)/.301048631703895D-02/,b(2)/.538971687740286D-01/, + + b(3)/.375795757275549D+00/ + DATA p(1)/-1.36864857382717D-07/,p(2)/5.64195517478974D-01/, + + p(3)/7.21175825088309D+00/,p(4)/4.31622272220567D+01/, + + p(5)/1.52989285046940D+02/,p(6)/3.39320816734344D+02/, + + p(7)/4.51918953711873D+02/,p(8)/3.00459261020162D+02/ + DATA q(1)/1.00000000000000D+00/,q(2)/1.27827273196294D+01/, + + q(3)/7.70001529352295D+01/,q(4)/2.77585444743988D+02/, + + q(5)/6.38980264465631D+02/,q(6)/9.31354094850610D+02/, + + q(7)/7.90950925327898D+02/,q(8)/3.00459260956983D+02/ + DATA r(1)/2.10144126479064D+00/,r(2)/2.62370141675169D+01/, + + r(3)/2.13688200555087D+01/,r(4)/4.65807828718470D+00/, + + r(5)/2.82094791773523D-01/ + DATA s(1)/9.41537750555460D+01/,s(2)/1.87114811799590D+02/, + + s(3)/9.90191814623914D+01/,s(4)/1.80124575948747D+01/ +C .. +C .. Executable Statements .. +C------------------------- +C +C ABS(X) .LE. 0.5 +C + ax = abs(x) + IF (ax.GT.0.5D0) GO TO 10 + t = x*x + top = ((((a(1)*t+a(2))*t+a(3))*t+a(4))*t+a(5)) + 1.0D0 + bot = ((b(1)*t+b(2))*t+b(3))*t + 1.0D0 + erfc1 = 0.5D0 + (0.5D0-x* (top/bot)) + IF (ind.NE.0) erfc1 = exp(t)*erfc1 + RETURN +C +C 0.5 .LT. ABS(X) .LE. 4 +C + 10 IF (ax.GT.4.0D0) GO TO 20 + top = ((((((p(1)*ax+p(2))*ax+p(3))*ax+p(4))*ax+p(5))*ax+p(6))*ax+ + + p(7))*ax + p(8) + bot = ((((((q(1)*ax+q(2))*ax+q(3))*ax+q(4))*ax+q(5))*ax+q(6))*ax+ + + q(7))*ax + q(8) + erfc1 = top/bot + GO TO 40 +C +C ABS(X) .GT. 4 +C + 20 IF (x.LE.-5.6D0) GO TO 60 + IF (ind.NE.0) GO TO 30 + IF (x.GT.100.0D0) GO TO 70 + IF (x*x.GT.-exparg(1)) GO TO 70 +C + 30 t = (1.0D0/x)**2 + top = (((r(1)*t+r(2))*t+r(3))*t+r(4))*t + r(5) + bot = (((s(1)*t+s(2))*t+s(3))*t+s(4))*t + 1.0D0 + erfc1 = (c-t*top/bot)/ax +C +C FINAL ASSEMBLY +C + 40 IF (ind.EQ.0) GO TO 50 + IF (x.LT.0.0D0) erfc1 = 2.0D0*exp(x*x) - erfc1 + RETURN + + 50 w = dble(x)*dble(x) + t = w + e = w - dble(t) + erfc1 = ((0.5D0+ (0.5D0-e))*exp(-t))*erfc1 + IF (x.LT.0.0D0) erfc1 = 2.0D0 - erfc1 + RETURN +C +C LIMIT VALUE FOR LARGE NEGATIVE X +C + 60 erfc1 = 2.0D0 + IF (ind.NE.0) erfc1 = 2.0D0*exp(x*x) + RETURN +C +C LIMIT VALUE FOR LARGE POSITIVE X +C WHEN IND = 0 +C + 70 erfc1 = 0.0D0 + RETURN + + END diff --git a/modules/statistics/src/dcdflib/erfc1.lo b/modules/statistics/src/dcdflib/erfc1.lo new file mode 100755 index 000000000..9f3e63730 --- /dev/null +++ b/modules/statistics/src/dcdflib/erfc1.lo @@ -0,0 +1,12 @@ +# src/dcdflib/erfc1.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/erfc1.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/statistics/src/dcdflib/esum.f b/modules/statistics/src/dcdflib/esum.f new file mode 100755 index 000000000..b463a0b89 --- /dev/null +++ b/modules/statistics/src/dcdflib/esum.f @@ -0,0 +1,35 @@ + DOUBLE PRECISION FUNCTION esum(mu,x) +C----------------------------------------------------------------------- +C EVALUATION OF EXP(MU + X) +C----------------------------------------------------------------------- +C .. Scalar Arguments .. + DOUBLE PRECISION x + INTEGER mu +C .. +C .. Local Scalars .. + DOUBLE PRECISION w +C .. +C .. Intrinsic Functions .. + INTRINSIC exp +C .. +C .. Executable Statements .. + + IF (x.GT.0.0D0) GO TO 10 +C + IF (mu.LT.0) GO TO 20 + w = mu + x + IF (w.GT.0.0D0) GO TO 20 + esum = exp(w) + RETURN +C + 10 IF (mu.GT.0) GO TO 20 + w = mu + x + IF (w.LT.0.0D0) GO TO 20 + esum = exp(w) + RETURN +C + 20 w = mu + esum = exp(w)*exp(x) + RETURN + + END diff --git a/modules/statistics/src/dcdflib/esum.lo b/modules/statistics/src/dcdflib/esum.lo new file mode 100755 index 000000000..99b62e6d7 --- /dev/null +++ b/modules/statistics/src/dcdflib/esum.lo @@ -0,0 +1,12 @@ +# src/dcdflib/esum.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/esum.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/statistics/src/dcdflib/exparg.f b/modules/statistics/src/dcdflib/exparg.f new file mode 100755 index 000000000..fa7a4cd10 --- /dev/null +++ b/modules/statistics/src/dcdflib/exparg.f @@ -0,0 +1,51 @@ + DOUBLE PRECISION FUNCTION exparg(l) +C-------------------------------------------------------------------- +C IF L = 0 THEN EXPARG(L) = THE LARGEST POSITIVE W FOR WHICH +C EXP(W) CAN BE COMPUTED. +C +C IF L IS NONZERO THEN EXPARG(L) = THE LARGEST NEGATIVE W FOR +C WHICH THE COMPUTED VALUE OF EXP(W) IS NONZERO. +C +C NOTE... ONLY AN APPROXIMATE VALUE FOR EXPARG(L) IS NEEDED. +C-------------------------------------------------------------------- +C .. Scalar Arguments .. + INTEGER l +C .. +C .. Local Scalars .. + DOUBLE PRECISION lnb + INTEGER b,m +C .. +C .. External Functions .. + INTEGER ipmpar + EXTERNAL ipmpar +C .. +C .. Intrinsic Functions .. + INTRINSIC dble,dlog +C .. +C .. Executable Statements .. +C + b = ipmpar(4) + IF (b.NE.2) GO TO 10 + lnb = .69314718055995D0 + GO TO 40 + + 10 IF (b.NE.8) GO TO 20 + lnb = 2.0794415416798D0 + GO TO 40 + + 20 IF (b.NE.16) GO TO 30 + lnb = 2.7725887222398D0 + GO TO 40 + + 30 lnb = dlog(dble(b)) +C + 40 IF (l.EQ.0) GO TO 50 + m = ipmpar(9) - 1 + exparg = 0.99999D0* (m*lnb) + RETURN + + 50 m = ipmpar(10) + exparg = 0.99999D0* (m*lnb) + RETURN + + END diff --git a/modules/statistics/src/dcdflib/exparg.lo b/modules/statistics/src/dcdflib/exparg.lo new file mode 100755 index 000000000..3bd11dc4d --- /dev/null +++ b/modules/statistics/src/dcdflib/exparg.lo @@ -0,0 +1,12 @@ +# src/dcdflib/exparg.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/exparg.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/statistics/src/dcdflib/fpser.f b/modules/statistics/src/dcdflib/fpser.f new file mode 100755 index 000000000..ddbabb1a3 --- /dev/null +++ b/modules/statistics/src/dcdflib/fpser.f @@ -0,0 +1,51 @@ + DOUBLE PRECISION FUNCTION fpser(a,b,x,eps) +C----------------------------------------------------------------------- +C +C EVALUATION OF I (A,B) +C X +C +C FOR B .LT. MIN(EPS,EPS*A) AND X .LE. 0.5. +C +C----------------------------------------------------------------------- +C +C SET FPSER = X**A +C +C .. Scalar Arguments .. + DOUBLE PRECISION a,b,eps,x +C .. +C .. Local Scalars .. + DOUBLE PRECISION an,c,s,t,tol +C .. +C .. External Functions .. + DOUBLE PRECISION exparg + EXTERNAL exparg +C .. +C .. Intrinsic Functions .. + INTRINSIC abs,dlog,exp +C .. +C .. Executable Statements .. + + fpser = 1.0D0 + IF (a.LE.1.D-3*eps) GO TO 10 + fpser = 0.0D0 + t = a*dlog(x) + IF (t.LT.exparg(1)) RETURN + fpser = exp(t) +C +C NOTE THAT 1/B(A,B) = B +C + 10 fpser = (b/a)*fpser + tol = eps/a + an = a + 1.0D0 + t = x + s = t/an + 20 an = an + 1.0D0 + t = x*t + c = t/an + s = s + c + IF (abs(c).GT.tol) GO TO 20 +C + fpser = fpser* (1.0D0+a*s) + RETURN + + END diff --git a/modules/statistics/src/dcdflib/fpser.lo b/modules/statistics/src/dcdflib/fpser.lo new file mode 100755 index 000000000..679e1bf25 --- /dev/null +++ b/modules/statistics/src/dcdflib/fpser.lo @@ -0,0 +1,12 @@ +# src/dcdflib/fpser.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/fpser.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/statistics/src/dcdflib/gam1.f b/modules/statistics/src/dcdflib/gam1.f new file mode 100755 index 000000000..e6c8ff9b4 --- /dev/null +++ b/modules/statistics/src/dcdflib/gam1.f @@ -0,0 +1,70 @@ + DOUBLE PRECISION FUNCTION gam1(a) +C ------------------------------------------------------------------ +C COMPUTATION OF 1/GAMMA(A+1) - 1 FOR -0.5 .LE. A .LE. 1.5 +C ------------------------------------------------------------------ +C .. Scalar Arguments .. + DOUBLE PRECISION a +C .. +C .. Local Scalars .. + DOUBLE PRECISION bot,d,s1,s2,t,top,w +C .. +C .. Local Arrays .. + DOUBLE PRECISION p(7),q(5),r(9) +C .. +C .. Data statements .. +C ------------------- +C ------------------- +C ------------------- +C ------------------- + DATA p(1)/.577215664901533D+00/,p(2)/-.409078193005776D+00/, + + p(3)/-.230975380857675D+00/,p(4)/.597275330452234D-01/, + + p(5)/.766968181649490D-02/,p(6)/-.514889771323592D-02/, + + p(7)/.589597428611429D-03/ + DATA q(1)/.100000000000000D+01/,q(2)/.427569613095214D+00/, + + q(3)/.158451672430138D+00/,q(4)/.261132021441447D-01/, + + q(5)/.423244297896961D-02/ + DATA r(1)/-.422784335098468D+00/,r(2)/-.771330383816272D+00/, + + r(3)/-.244757765222226D+00/,r(4)/.118378989872749D+00/, + + r(5)/.930357293360349D-03/,r(6)/-.118290993445146D-01/, + + r(7)/.223047661158249D-02/,r(8)/.266505979058923D-03/, + + r(9)/-.132674909766242D-03/ + DATA s1/.273076135303957D+00/,s2/.559398236957378D-01/ +C .. +C .. Executable Statements .. +C ------------------- + t = a + d = a - 0.5D0 + IF (d.GT.0.0D0) t = d - 0.5D0 + if (t .lt. 0) then + goto 40 + elseif (t .eq. 0) then + goto 10 + else + goto 20 + endif +C + 10 gam1 = 0.0D0 + RETURN +C + 20 top = (((((p(7)*t+p(6))*t+p(5))*t+p(4))*t+p(3))*t+p(2))*t + p(1) + bot = (((q(5)*t+q(4))*t+q(3))*t+q(2))*t + 1.0D0 + w = top/bot + IF (d.GT.0.0D0) GO TO 30 + gam1 = a*w + RETURN + + 30 gam1 = (t/a)* ((w-0.5D0)-0.5D0) + RETURN +C + 40 top = (((((((r(9)*t+r(8))*t+r(7))*t+r(6))*t+r(5))*t+r(4))*t+r(3))* + + t+r(2))*t + r(1) + bot = (s2*t+s1)*t + 1.0D0 + w = top/bot + IF (d.GT.0.0D0) GO TO 50 + gam1 = a* ((w+0.5D0)+0.5D0) + RETURN + + 50 gam1 = t*w/a + RETURN + + END diff --git a/modules/statistics/src/dcdflib/gam1.lo b/modules/statistics/src/dcdflib/gam1.lo new file mode 100755 index 000000000..f8b53f67e --- /dev/null +++ b/modules/statistics/src/dcdflib/gam1.lo @@ -0,0 +1,12 @@ +# src/dcdflib/gam1.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/gam1.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/statistics/src/dcdflib/gaminv.f b/modules/statistics/src/dcdflib/gaminv.f new file mode 100755 index 000000000..9f57477a9 --- /dev/null +++ b/modules/statistics/src/dcdflib/gaminv.f @@ -0,0 +1,355 @@ + SUBROUTINE gaminv(a,x,x0,p,q,ierr) +C ---------------------------------------------------------------------- +C INVERSE INCOMPLETE GAMMA RATIO FUNCTION +C +C GIVEN POSITIVE A, AND NONEGATIVE P AND Q WHERE P + Q = 1. +C THEN X IS COMPUTED WHERE P(A,X) = P AND Q(A,X) = Q. SCHRODER +C ITERATION IS EMPLOYED. THE ROUTINE ATTEMPTS TO COMPUTE X +C TO 10 SIGNIFICANT DIGITS IF THIS IS POSSIBLE FOR THE +C PARTICULAR COMPUTER ARITHMETIC BEING USED. +C +C ------------ +C +C X IS A VARIABLE. IF P = 0 THEN X IS ASSIGNED THE VALUE 0, +C AND IF Q = 0 THEN X IS SET TO THE LARGEST FLOATING POINT +C NUMBER AVAILABLE. OTHERWISE, GAMINV ATTEMPTS TO OBTAIN +C A SOLUTION FOR P(A,X) = P AND Q(A,X) = Q. IF THE ROUTINE +C IS SUCCESSFUL THEN THE SOLUTION IS STORED IN X. +C +C X0 IS AN OPTIONAL INITIAL APPROXIMATION FOR X. IF THE USER +C DOES NOT WISH TO SUPPLY AN INITIAL APPROXIMATION, THEN SET +C X0 .LE. 0. +C +C IERR IS A VARIABLE THAT REPORTS THE STATUS OF THE RESULTS. +C WHEN THE ROUTINE TERMINATES, IERR HAS ONE OF THE FOLLOWING +C VALUES ... +C +C IERR = 0 THE SOLUTION WAS OBTAINED. ITERATION WAS +C NOT USED. +C IERR.GT.0 THE SOLUTION WAS OBTAINED. IERR ITERATIONS +C WERE PERFORMED. +C IERR = -2 (INPUT ERROR) A .LE. 0 +C IERR = -3 NO SOLUTION WAS OBTAINED. THE RATIO Q/A +C IS TOO LARGE. +C IERR = -4 (INPUT ERROR) P + Q .NE. 1 +C IERR = -6 20 ITERATIONS WERE PERFORMED. THE MOST +C RECENT VALUE OBTAINED FOR X IS GIVEN. +C THIS CANNOT OCCUR IF X0 .LE. 0. +C IERR = -7 ITERATION FAILED. NO VALUE IS GIVEN FOR X. +C THIS MAY OCCUR WHEN X IS APPROXIMATELY 0. +C IERR = -8 A VALUE FOR X HAS BEEN OBTAINED, BUT THE +C ROUTINE IS NOT CERTAIN OF ITS ACCURACY. +C ITERATION CANNOT BE PERFORMED IN THIS +C CASE. IF X0 .LE. 0, THIS CAN OCCUR ONLY +C WHEN P OR Q IS APPROXIMATELY 0. IF X0 IS +C POSITIVE THEN THIS CAN OCCUR WHEN A IS +C EXCEEDINGLY CLOSE TO X AND A IS EXTREMELY +C LARGE (SAY A .GE. 1.E20). +C ---------------------------------------------------------------------- +C WRITTEN BY ALFRED H. MORRIS, JR. +C NAVAL SURFACE WEAPONS CENTER +C DAHLGREN, VIRGINIA +C ------------------- +C .. Scalar Arguments .. + DOUBLE PRECISION a,p,q,x,x0 + INTEGER ierr +C .. +C .. Local Scalars .. + DOUBLE PRECISION a0,a1,a2,a3,am1,amax,ap1,ap2,ap3,apn,b,b1,b2,b3, + + b4,c,c1,c2,c3,c4,c5,d,e,e2,eps,g,h,ln10,pn,qg,qn, + + r,rta,s,s2,sum,t,tol,u,w,xmax,xmin,xn,y,z + INTEGER iop +C .. +C .. Local Arrays .. + DOUBLE PRECISION amin(2),bmin(2),dmin(2),emin(2),eps0(2) +C .. +C .. External Functions .. + DOUBLE PRECISION alnrel,gamln,gamln1,gamma,rcomp,spmpar + EXTERNAL alnrel,gamln,gamln1,gamma,rcomp,spmpar +C .. +C .. External Subroutines .. + EXTERNAL gratio +C .. +C .. Intrinsic Functions .. + INTRINSIC abs,dble,dlog,dmax1,exp,sqrt +C .. +C .. Data statements .. +C ------------------- +C LN10 = LN(10) +C C = EULER CONSTANT +C ------------------- +C ------------------- +C ------------------- +C ------------------- + DATA ln10/2.302585D0/ + DATA c/.577215664901533D0/ + DATA a0/3.31125922108741D0/,a1/11.6616720288968D0/, + + a2/4.28342155967104D0/,a3/.213623493715853D0/ + DATA b1/6.61053765625462D0/,b2/6.40691597760039D0/, + + b3/1.27364489782223D0/,b4/.036117081018842D0/ + DATA eps0(1)/1.D-10/,eps0(2)/1.D-08/ + DATA amin(1)/500.0D0/,amin(2)/100.0D0/ + DATA bmin(1)/1.D-28/,bmin(2)/1.D-13/ + DATA dmin(1)/1.D-06/,dmin(2)/1.D-04/ + DATA emin(1)/2.D-03/,emin(2)/6.D-03/ + DATA tol/1.D-5/ +C .. +C .. Executable Statements .. +C ------------------- +C ****** E, XMIN, AND XMAX ARE MACHINE DEPENDENT CONSTANTS. +C E IS THE SMALLEST NUMBER FOR WHICH 1.0 + E .GT. 1.0. +C XMIN IS THE SMALLEST POSITIVE NUMBER AND XMAX IS THE +C LARGEST POSITIVE NUMBER. +C + e = spmpar(1) + xmin = spmpar(2) + xmax = spmpar(3) +C ------------------- + x = 0.0D0 + IF (a.LE.0.0D0) GO TO 300 + t = dble(p) + dble(q) - 1.D0 + IF (abs(t).GT.e) GO TO 320 +C + ierr = 0 + IF (p.EQ.0.0D0) RETURN + IF (q.EQ.0.0D0) GO TO 270 + IF (a.EQ.1.0D0) GO TO 280 +C + e2 = 2.0D0*e + amax = 0.4D-10/ (e*e) + iop = 1 + IF (e.GT.1.D-10) iop = 2 + eps = eps0(iop) + xn = x0 + IF (x0.GT.0.0D0) GO TO 160 +C +C SELECTION OF THE INITIAL APPROXIMATION XN OF X +C WHEN A .LT. 1 +C + IF (a.GT.1.0D0) GO TO 80 + g = gamma(a+1.0D0) + qg = q*g + IF (qg.EQ.0.0D0) GO TO 360 + b = qg/a + IF (qg.GT.0.6D0*a) GO TO 40 + IF (a.GE.0.30D0 .OR. b.LT.0.35D0) GO TO 10 + t = exp(- (b+c)) + u = t*exp(t) + xn = t*exp(u) + GO TO 160 +C + 10 IF (b.GE.0.45D0) GO TO 40 + IF (b.EQ.0.0D0) GO TO 360 + y = -dlog(b) + s = 0.5D0 + (0.5D0-a) + z = dlog(y) + t = y - s*z + IF (b.LT.0.15D0) GO TO 20 + xn = y - s*dlog(t) - dlog(1.0D0+s/ (t+1.0D0)) + GO TO 220 + + 20 IF (b.LE.0.01D0) GO TO 30 + u = ((t+2.0D0* (3.0D0-a))*t+ (2.0D0-a)* (3.0D0-a))/ + + ((t+ (5.0D0-a))*t+2.0D0) + xn = y - s*dlog(t) - dlog(u) + GO TO 220 + + 30 c1 = -s*z + c2 = -s* (1.0D0+c1) + c3 = s* ((0.5D0*c1+ (2.0D0-a))*c1+ (2.5D0-1.5D0*a)) + c4 = -s* (((c1/3.0D0+ (2.5D0-1.5D0*a))*c1+ ((a-6.0D0)*a+7.0D0))* + + c1+ ((11.0D0*a-46)*a+47.0D0)/6.0D0) + c5 = -s* ((((-c1/4.0D0+ (11.0D0*a-17.0D0)/6.0D0)*c1+ ((-3.0D0*a+ + + 13.0D0)*a-13.0D0))*c1+0.5D0* (((2.0D0*a-25.0D0)*a+72.0D0)*a- + + 61.0D0))*c1+ (((25.0D0*a-195.0D0)*a+477.0D0)*a-379.0D0)/ + + 12.0D0) + xn = ((((c5/y+c4)/y+c3)/y+c2)/y+c1) + y + IF (a.GT.1.0D0) GO TO 220 + IF (b.GT.bmin(iop)) GO TO 220 + x = xn + RETURN +C + 40 IF (b*q.GT.1.D-8) GO TO 50 + xn = exp(- (q/a+c)) + GO TO 70 + + 50 IF (p.LE.0.9D0) GO TO 60 + xn = exp((alnrel(-q)+gamln1(a))/a) + GO TO 70 + + 60 xn = exp(dlog(p*g)/a) + 70 IF (xn.EQ.0.0D0) GO TO 310 + t = 0.5D0 + (0.5D0-xn/ (a+1.0D0)) + xn = xn/t + GO TO 160 +C +C SELECTION OF THE INITIAL APPROXIMATION XN OF X +C WHEN A .GT. 1 +C + 80 IF (q.LE.0.5D0) GO TO 90 + w = dlog(p) + GO TO 100 + + 90 w = dlog(q) + 100 t = sqrt(-2.0D0*w) + s = t - (((a3*t+a2)*t+a1)*t+a0)/ ((((b4*t+b3)*t+b2)*t+b1)*t+1.0D0) + IF (q.GT.0.5D0) s = -s +C + rta = sqrt(a) + s2 = s*s + xn = a + s*rta + (s2-1.0D0)/3.0D0 + s* (s2-7.0D0)/ (36.0D0*rta) - + + ((3.0D0*s2+7.0D0)*s2-16.0D0)/ (810.0D0*a) + + + s* ((9.0D0*s2+256.0D0)*s2-433.0D0)/ (38880.0D0*a*rta) + xn = dmax1(xn,0.0D0) + IF (a.LT.amin(iop)) GO TO 110 + x = xn + d = 0.5D0 + (0.5D0-x/a) + IF (abs(d).LE.dmin(iop)) RETURN +C + 110 IF (p.LE.0.5D0) GO TO 130 + IF (xn.LT.3.0D0*a) GO TO 220 + y = - (w+gamln(a)) + d = dmax1(2.0D0,a* (a-1.0D0)) + IF (y.LT.ln10*d) GO TO 120 + s = 1.0D0 - a + z = dlog(y) + GO TO 30 + + 120 t = a - 1.0D0 + xn = y + t*dlog(xn) - alnrel(-t/ (xn+1.0D0)) + xn = y + t*dlog(xn) - alnrel(-t/ (xn+1.0D0)) + GO TO 220 +C + 130 ap1 = a + 1.0D0 + IF (xn.GT.0.70D0*ap1) GO TO 170 + w = w + gamln(ap1) + IF (xn.GT.0.15D0*ap1) GO TO 140 + ap2 = a + 2.0D0 + ap3 = a + 3.0D0 + x = exp((w+x)/a) + x = exp((w+x-dlog(1.0D0+ (x/ap1)* (1.0D0+x/ap2)))/a) + x = exp((w+x-dlog(1.0D0+ (x/ap1)* (1.0D0+x/ap2)))/a) + x = exp((w+x-dlog(1.0D0+ (x/ap1)* (1.0D0+ (x/ap2)* (1.0D0+ + + x/ap3))))/a) + xn = x + IF (xn.GT.1.D-2*ap1) GO TO 140 + IF (xn.LE.emin(iop)*ap1) RETURN + GO TO 170 +C + 140 apn = ap1 + t = xn/apn + sum = 1.0D0 + t + 150 apn = apn + 1.0D0 + t = t* (xn/apn) + sum = sum + t + IF (t.GT.1.D-4) GO TO 150 + t = w - dlog(sum) + xn = exp((xn+t)/a) + xn = xn* (1.0D0- (a*dlog(xn)-xn-t)/ (a-xn)) + GO TO 170 +C +C SCHRODER ITERATION USING P +C + 160 IF (p.GT.0.5D0) GO TO 220 + 170 IF (p.LE.1.D10*xmin) GO TO 350 + am1 = (a-0.5D0) - 0.5D0 + 180 IF (a.LE.amax) GO TO 190 + d = 0.5D0 + (0.5D0-xn/a) + IF (abs(d).LE.e2) GO TO 350 +C + 190 IF (ierr.GE.20) GO TO 330 + ierr = ierr + 1 + CALL gratio(a,xn,pn,qn,0) + IF (pn.EQ.0.0D0 .OR. qn.EQ.0.0D0) GO TO 350 + r = rcomp(a,xn) + IF (r.EQ.0.0D0) GO TO 350 + t = (pn-p)/r + w = 0.5D0* (am1-xn) + IF (abs(t).LE.0.1D0 .AND. abs(w*t).LE.0.1D0) GO TO 200 + x = xn* (1.0D0-t) + IF (x.LE.0.0D0) GO TO 340 + d = abs(t) + GO TO 210 +C + 200 h = t* (1.0D0+w*t) + x = xn* (1.0D0-h) + IF (x.LE.0.0D0) GO TO 340 + IF (abs(w).GE.1.0D0 .AND. abs(w)*t*t.LE.eps) RETURN + d = abs(h) + 210 xn = x + IF (d.GT.tol) GO TO 180 + IF (d.LE.eps) RETURN + IF (abs(p-pn).LE.tol*p) RETURN + GO TO 180 +C +C SCHRODER ITERATION USING Q +C + 220 IF (q.LE.1.D10*xmin) GO TO 350 + am1 = (a-0.5D0) - 0.5D0 + 230 IF (a.LE.amax) GO TO 240 + d = 0.5D0 + (0.5D0-xn/a) + IF (abs(d).LE.e2) GO TO 350 +C + 240 IF (ierr.GE.20) GO TO 330 + ierr = ierr + 1 + CALL gratio(a,xn,pn,qn,0) + IF (pn.EQ.0.0D0 .OR. qn.EQ.0.0D0) GO TO 350 + r = rcomp(a,xn) + IF (r.EQ.0.0D0) GO TO 350 + t = (q-qn)/r + w = 0.5D0* (am1-xn) + IF (abs(t).LE.0.1D0 .AND. abs(w*t).LE.0.1D0) GO TO 250 + x = xn* (1.0D0-t) + IF (x.LE.0.0D0) GO TO 340 + d = abs(t) + GO TO 260 +C + 250 h = t* (1.0D0+w*t) + x = xn* (1.0D0-h) + IF (x.LE.0.0D0) GO TO 340 + IF (abs(w).GE.1.0D0 .AND. abs(w)*t*t.LE.eps) RETURN + d = abs(h) + 260 xn = x + IF (d.GT.tol) GO TO 230 + IF (d.LE.eps) RETURN + IF (abs(q-qn).LE.tol*q) RETURN + GO TO 230 +C +C SPECIAL CASES +C + 270 x = xmax + RETURN +C + 280 IF (q.LT.0.9D0) GO TO 290 + x = -alnrel(-p) + RETURN + + 290 x = -dlog(q) + RETURN +C +C ERROR RETURN +C + 300 ierr = -2 + RETURN +C + 310 ierr = -3 + RETURN +C + 320 ierr = -4 + RETURN +C + 330 ierr = -6 + RETURN +C + 340 ierr = -7 + RETURN +C + 350 x = xn + ierr = -8 + RETURN +C + 360 x = xmax + ierr = -8 + RETURN + + END diff --git a/modules/statistics/src/dcdflib/gaminv.lo b/modules/statistics/src/dcdflib/gaminv.lo new file mode 100755 index 000000000..c0b438897 --- /dev/null +++ b/modules/statistics/src/dcdflib/gaminv.lo @@ -0,0 +1,12 @@ +# src/dcdflib/gaminv.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/gaminv.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/statistics/src/dcdflib/gamln.f b/modules/statistics/src/dcdflib/gamln.f new file mode 100755 index 000000000..7d8c889d5 --- /dev/null +++ b/modules/statistics/src/dcdflib/gamln.f @@ -0,0 +1,57 @@ + DOUBLE PRECISION FUNCTION gamln(a) +C----------------------------------------------------------------------- +C EVALUATION OF LN(GAMMA(A)) FOR POSITIVE A +C----------------------------------------------------------------------- +C WRITTEN BY ALFRED H. MORRIS +C NAVAL SURFACE WARFARE CENTER +C DAHLGREN, VIRGINIA +C-------------------------- +C D = 0.5*(LN(2*PI) - 1) +C-------------------------- +C .. Scalar Arguments .. + DOUBLE PRECISION a +C .. +C .. Local Scalars .. + DOUBLE PRECISION c0,c1,c2,c3,c4,c5,d,t,w + INTEGER i,n +C .. +C .. External Functions .. + DOUBLE PRECISION gamln1 + EXTERNAL gamln1 +C .. +C .. Intrinsic Functions .. + INTRINSIC dlog +C .. +C .. Data statements .. +C-------------------------- + DATA d/.418938533204673D0/ + DATA c0/.833333333333333D-01/,c1/-.277777777760991D-02/, + + c2/.793650666825390D-03/,c3/-.595202931351870D-03/, + + c4/.837308034031215D-03/,c5/-.165322962780713D-02/ +C .. +C .. Executable Statements .. +C----------------------------------------------------------------------- + IF (a.GT.0.8D0) GO TO 10 + gamln = gamln1(a) - dlog(a) + RETURN + + 10 IF (a.GT.2.25D0) GO TO 20 + t = (a-0.5D0) - 0.5D0 + gamln = gamln1(t) + RETURN +C + 20 IF (a.GE.10.0D0) GO TO 40 + n = a - 1.25D0 + t = a + w = 1.0D0 + DO 30 i = 1,n + t = t - 1.0D0 + w = t*w + 30 CONTINUE + gamln = gamln1(t-1.0D0) + dlog(w) + RETURN +C + 40 t = (1.0D0/a)**2 + w = (((((c5*t+c4)*t+c3)*t+c2)*t+c1)*t+c0)/a + gamln = (d+w) + (a-0.5D0)* (dlog(a)-1.0D0) + END diff --git a/modules/statistics/src/dcdflib/gamln.lo b/modules/statistics/src/dcdflib/gamln.lo new file mode 100755 index 000000000..0bdda87fd --- /dev/null +++ b/modules/statistics/src/dcdflib/gamln.lo @@ -0,0 +1,12 @@ +# src/dcdflib/gamln.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/gamln.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/statistics/src/dcdflib/gamln1.f b/modules/statistics/src/dcdflib/gamln1.f new file mode 100755 index 000000000..4bf55bf96 --- /dev/null +++ b/modules/statistics/src/dcdflib/gamln1.f @@ -0,0 +1,42 @@ + DOUBLE PRECISION FUNCTION gamln1(a) +C----------------------------------------------------------------------- +C EVALUATION OF LN(GAMMA(1 + A)) FOR -0.2 .LE. A .LE. 1.25 +C----------------------------------------------------------------------- +C .. Scalar Arguments .. + DOUBLE PRECISION a +C .. +C .. Local Scalars .. + DOUBLE PRECISION p0,p1,p2,p3,p4,p5,p6,q1,q2,q3,q4,q5,q6,r0,r1,r2, + + r3,r4,r5,s1,s2,s3,s4,s5,w,x +C .. +C .. Data statements .. +C---------------------- + DATA p0/.577215664901533D+00/,p1/.844203922187225D+00/, + + p2/-.168860593646662D+00/,p3/-.780427615533591D+00/, + + p4/-.402055799310489D+00/,p5/-.673562214325671D-01/, + + p6/-.271935708322958D-02/ + DATA q1/.288743195473681D+01/,q2/.312755088914843D+01/, + + q3/.156875193295039D+01/,q4/.361951990101499D+00/, + + q5/.325038868253937D-01/,q6/.667465618796164D-03/ + DATA r0/.422784335098467D+00/,r1/.848044614534529D+00/, + + r2/.565221050691933D+00/,r3/.156513060486551D+00/, + + r4/.170502484022650D-01/,r5/.497958207639485D-03/ + DATA s1/.124313399877507D+01/,s2/.548042109832463D+00/, + + s3/.101552187439830D+00/,s4/.713309612391000D-02/, + + s5/.116165475989616D-03/ +C .. +C .. Executable Statements .. +C---------------------- + IF (a.GE.0.6D0) GO TO 10 + w = ((((((p6*a+p5)*a+p4)*a+p3)*a+p2)*a+p1)*a+p0)/ + + ((((((q6*a+q5)*a+q4)*a+q3)*a+q2)*a+q1)*a+1.0D0) + gamln1 = -a*w + RETURN +C + 10 x = (a-0.5D0) - 0.5D0 + w = (((((r5*x+r4)*x+r3)*x+r2)*x+r1)*x+r0)/ + + (((((s5*x+s4)*x+s3)*x+s2)*x+s1)*x+1.0D0) + gamln1 = x*w + RETURN + + END diff --git a/modules/statistics/src/dcdflib/gamln1.lo b/modules/statistics/src/dcdflib/gamln1.lo new file mode 100755 index 000000000..c34f9ee50 --- /dev/null +++ b/modules/statistics/src/dcdflib/gamln1.lo @@ -0,0 +1,12 @@ +# src/dcdflib/gamln1.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/gamln1.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/statistics/src/dcdflib/gamma.f b/modules/statistics/src/dcdflib/gamma.f new file mode 100755 index 000000000..65c254720 --- /dev/null +++ b/modules/statistics/src/dcdflib/gamma.f @@ -0,0 +1,156 @@ + DOUBLE PRECISION FUNCTION gamma(a) +C----------------------------------------------------------------------- +C +C EVALUATION OF THE GAMMA FUNCTION FOR REAL ARGUMENTS +C +C ----------- +C +C GAMMA(A) IS ASSIGNED THE VALUE 0 WHEN THE GAMMA FUNCTION CANNOT +C BE COMPUTED. +C +C----------------------------------------------------------------------- +C WRITTEN BY ALFRED H. MORRIS, JR. +C NAVAL SURFACE WEAPONS CENTER +C DAHLGREN, VIRGINIA +C----------------------------------------------------------------------- +C .. Scalar Arguments .. + DOUBLE PRECISION a +C .. +C .. Local Scalars .. + DOUBLE PRECISION bot,d,g,lnx,pi,r1,r2,r3,r4,r5,s,t,top,w,x,z + INTEGER i,j,m,n +C .. +C .. Local Arrays .. + DOUBLE PRECISION p(7),q(7) +C .. +C .. External Functions .. + DOUBLE PRECISION exparg,spmpar + EXTERNAL exparg,spmpar +C .. +C .. Intrinsic Functions .. + INTRINSIC abs,dble,dlog,exp,int,mod,sin +C .. +C .. Data statements .. +C-------------------------- +C D = 0.5*(LN(2*PI) - 1) +C-------------------------- +C-------------------------- +C-------------------------- + DATA pi/3.1415926535898D0/ + DATA d/.41893853320467274178D0/ + DATA p(1)/.539637273585445D-03/,p(2)/.261939260042690D-02/, + + p(3)/.204493667594920D-01/,p(4)/.730981088720487D-01/, + + p(5)/.279648642639792D+00/,p(6)/.553413866010467D+00/, + + p(7)/1.0D0/ + DATA q(1)/-.832979206704073D-03/,q(2)/.470059485860584D-02/, + + q(3)/.225211131035340D-01/,q(4)/-.170458969313360D+00/, + + q(5)/-.567902761974940D-01/,q(6)/.113062953091122D+01/, + + q(7)/1.0D0/ + DATA r1/.820756370353826D-03/,r2/-.595156336428591D-03/, + + r3/.793650663183693D-03/,r4/-.277777777770481D-02/, + + r5/.833333333333333D-01/ +C .. +C .. Executable Statements .. +C-------------------------- + gamma = 0.0D0 + x = a + IF (abs(a).GE.15.0D0) GO TO 110 +C----------------------------------------------------------------------- +C EVALUATION OF GAMMA(A) FOR ABS(A) .LT. 15 +C----------------------------------------------------------------------- + t = 1.0D0 + m = int(a) - 1 +C +C LET T BE THE PRODUCT OF A-J WHEN A .GE. 2 +C + if (m .lt. 0) then + goto 40 + elseif (m .eq. 0) then + goto 30 + else + goto 10 + endif + 10 DO 20 j = 1,m + x = x - 1.0D0 + t = x*t + 20 CONTINUE + 30 x = x - 1.0D0 + GO TO 80 +C +C LET T BE THE PRODUCT OF A+J WHEN A .LT. 1 +C + 40 t = a + IF (a.GT.0.0D0) GO TO 70 + m = -m - 1 + IF (m.EQ.0) GO TO 60 + DO 50 j = 1,m + x = x + 1.0D0 + t = x*t + 50 CONTINUE + 60 x = (x+0.5D0) + 0.5D0 + t = x*t + IF (t.EQ.0.0D0) RETURN +C + 70 CONTINUE +C +C THE FOLLOWING CODE CHECKS IF 1/T CAN OVERFLOW. THIS +C CODE MAY BE OMITTED IF DESIRED. +C + IF (abs(t).GE.1.D-30) GO TO 80 + IF (abs(t)*spmpar(3).LE.1.0001D0) RETURN + gamma = 1.0D0/t + RETURN +C +C COMPUTE GAMMA(1 + X) FOR 0 .LE. X .LT. 1 +C + 80 top = p(1) + bot = q(1) + DO 90 i = 2,7 + top = p(i) + x*top + bot = q(i) + x*bot + 90 CONTINUE + gamma = top/bot +C +C TERMINATION +C + IF (a.LT.1.0D0) GO TO 100 + gamma = gamma*t + RETURN + + 100 gamma = gamma/t + RETURN +C----------------------------------------------------------------------- +C EVALUATION OF GAMMA(A) FOR ABS(A) .GE. 15 +C----------------------------------------------------------------------- + 110 IF (abs(a).GE.1.D3) RETURN + IF (a.GT.0.0D0) GO TO 120 + x = -a + n = x + t = x - n + IF (t.GT.0.9D0) t = 1.0D0 - t + s = sin(pi*t)/pi + IF (mod(n,2).EQ.0) s = -s + IF (s.EQ.0.0D0) RETURN +C +C COMPUTE THE MODIFIED ASYMPTOTIC SUM +C + 120 t = 1.0D0/ (x*x) + g = ((((r1*t+r2)*t+r3)*t+r4)*t+r5)/x +C +C ONE MAY REPLACE THE NEXT STATEMENT WITH LNX = ALOG(X) +C BUT LESS ACCURACY WILL NORMALLY BE OBTAINED. +C + lnx = dlog(x) +C +C FINAL ASSEMBLY +C + z = x + g = (d+g) + (z-0.5D0)* (lnx-1.D0) + w = g + t = g - dble(w) + IF (w.GT.0.99999D0*exparg(0)) RETURN + gamma = exp(w)* (1.0D0+t) + IF (a.LT.0.0D0) gamma = (1.0D0/ (gamma*s))/x + RETURN + + END diff --git a/modules/statistics/src/dcdflib/gamma.lo b/modules/statistics/src/dcdflib/gamma.lo new file mode 100755 index 000000000..3040a0020 --- /dev/null +++ b/modules/statistics/src/dcdflib/gamma.lo @@ -0,0 +1,12 @@ +# src/dcdflib/gamma.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/gamma.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/statistics/src/dcdflib/grat1.f b/modules/statistics/src/dcdflib/grat1.f new file mode 100755 index 000000000..7968af16f --- /dev/null +++ b/modules/statistics/src/dcdflib/grat1.f @@ -0,0 +1,105 @@ + SUBROUTINE grat1(a,x,r,p,q,eps) +C .. Scalar Arguments .. + DOUBLE PRECISION a,eps,p,q,r,x +C .. +C .. Local Scalars .. + DOUBLE PRECISION a2n,a2nm1,am0,an,an0,b2n,b2nm1,c,cma,g,h,j,l,sum, + + t,tol,w,z +C .. +C .. External Functions .. + DOUBLE PRECISION erf,erfc1,gam1,rexp + EXTERNAL erf,erfc1,gam1,rexp +C .. +C .. Intrinsic Functions .. + INTRINSIC abs,dlog,exp,sqrt +C .. +C .. Executable Statements .. +C----------------------------------------------------------------------- +C EVALUATION OF THE INCOMPLETE GAMMA RATIO FUNCTIONS +C P(A,X) AND Q(A,X) +C +C IT IS ASSUMED THAT A .LE. 1. EPS IS THE TOLERANCE TO BE USED. +C THE INPUT ARGUMENT R HAS THE VALUE E**(-X)*X**A/GAMMA(A). +C----------------------------------------------------------------------- + IF (a*x.EQ.0.0D0) GO TO 120 + IF (a.EQ.0.5D0) GO TO 100 + IF (x.LT.1.1D0) GO TO 10 + GO TO 60 +C +C TAYLOR SERIES FOR P(A,X)/X**A +C + 10 an = 3.0D0 + c = x + sum = x/ (a+3.0D0) + tol = 0.1D0*eps/ (a+1.0D0) + 20 an = an + 1.0D0 + c = -c* (x/an) + t = c/ (a+an) + sum = sum + t + IF (abs(t).GT.tol) GO TO 20 + j = a*x* ((sum/6.0D0-0.5D0/ (a+2.0D0))*x+1.0D0/ (a+1.0D0)) +C + z = a*dlog(x) + h = gam1(a) + g = 1.0D0 + h + IF (x.LT.0.25D0) GO TO 30 + IF (a.LT.x/2.59D0) GO TO 50 + GO TO 40 + + 30 IF (z.GT.-.13394D0) GO TO 50 +C + 40 w = exp(z) + p = w*g* (0.5D0+ (0.5D0-j)) + q = 0.5D0 + (0.5D0-p) + RETURN +C + 50 l = rexp(z) + w = 0.5D0 + (0.5D0+l) + q = (w*j-l)*g - h + IF (q.LT.0.0D0) GO TO 90 + p = 0.5D0 + (0.5D0-q) + RETURN +C +C CONTINUED FRACTION EXPANSION +C + 60 a2nm1 = 1.0D0 + a2n = 1.0D0 + b2nm1 = x + b2n = x + (1.0D0-a) + c = 1.0D0 + 70 a2nm1 = x*a2n + c*a2nm1 + b2nm1 = x*b2n + c*b2nm1 + am0 = a2nm1/b2nm1 + c = c + 1.0D0 + cma = c - a + a2n = a2nm1 + cma*a2n + b2n = b2nm1 + cma*b2n + an0 = a2n/b2n + IF (abs(an0-am0).GE.eps*an0) GO TO 70 + q = r*an0 + p = 0.5D0 + (0.5D0-q) + RETURN +C +C SPECIAL CASES +C + 80 p = 0.0D0 + q = 1.0D0 + RETURN +C + 90 p = 1.0D0 + q = 0.0D0 + RETURN +C + 100 IF (x.GE.0.25D0) GO TO 110 + p = erf(sqrt(x)) + q = 0.5D0 + (0.5D0-p) + RETURN + + 110 q = erfc1(0,sqrt(x)) + p = 0.5D0 + (0.5D0-q) + RETURN +C + 120 IF (x.LE.a) GO TO 80 + GO TO 90 + + END diff --git a/modules/statistics/src/dcdflib/grat1.lo b/modules/statistics/src/dcdflib/grat1.lo new file mode 100755 index 000000000..4e0307458 --- /dev/null +++ b/modules/statistics/src/dcdflib/grat1.lo @@ -0,0 +1,12 @@ +# src/dcdflib/grat1.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/grat1.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/statistics/src/dcdflib/gratio.f b/modules/statistics/src/dcdflib/gratio.f new file mode 100755 index 000000000..c056d6728 --- /dev/null +++ b/modules/statistics/src/dcdflib/gratio.f @@ -0,0 +1,431 @@ + SUBROUTINE gratio(a,x,ans,qans,ind) +C ---------------------------------------------------------------------- +C EVALUATION OF THE INCOMPLETE GAMMA RATIO FUNCTIONS +C P(A,X) AND Q(A,X) +C +C ---------- +C +C IT IS ASSUMED THAT A AND X ARE NONNEGATIVE, WHERE A AND X +C ARE NOT BOTH 0. +C +C ANS AND QANS ARE VARIABLES. GRATIO ASSIGNS ANS THE VALUE +C P(A,X) AND QANS THE VALUE Q(A,X). IND MAY BE ANY INTEGER. +C IF IND = 0 THEN THE USER IS REQUESTING AS MUCH ACCURACY AS +C POSSIBLE (UP TO 14 SIGNIFICANT DIGITS). OTHERWISE, IF +C IND = 1 THEN ACCURACY IS REQUESTED TO WITHIN 1 UNIT OF THE +C 6-TH SIGNIFICANT DIGIT, AND IF IND .NE. 0,1 THEN ACCURACY +C IS REQUESTED TO WITHIN 1 UNIT OF THE 3RD SIGNIFICANT DIGIT. +C +C ERROR RETURN ... +C ANS IS ASSIGNED THE VALUE 2 WHEN A OR X IS NEGATIVE, +C WHEN A*X = 0, OR WHEN P(A,X) AND Q(A,X) ARE INDETERMINANT. +C P(A,X) AND Q(A,X) ARE COMPUTATIONALLY INDETERMINANT WHEN +C X IS EXCEEDINGLY CLOSE TO A AND A IS EXTREMELY LARGE. +C ---------------------------------------------------------------------- +C WRITTEN BY ALFRED H. MORRIS, JR. +C NAVAL SURFACE WEAPONS CENTER +C DAHLGREN, VIRGINIA +C -------------------- +C .. Scalar Arguments .. + DOUBLE PRECISION a,ans,qans,x + INTEGER ind +C .. +C .. Local Scalars .. + DOUBLE PRECISION a2n,a2nm1,acc,alog10,am0,amn,an,an0,apn,b2n, + + b2nm1,c,c0,c1,c2,c3,c4,c5,c6,cma,d10,d20,d30,d40, + + d50,d60,d70,e,e0,g,h,j,l,r,rt2pin,rta,rtpi,rtx,s, + + sum,t,t1,third,tol,twoa,u,w,x0,y,z + INTEGER i,iop,m,max,n +C .. +C .. Local Arrays .. + DOUBLE PRECISION acc0(3),big(3),d0(13),d1(12),d2(10),d3(8),d4(6), + + d5(4),d6(2),e00(3),wk(20),x00(3) +C .. +C .. External Functions .. + DOUBLE PRECISION erf,erfc1,gam1,gamma,rexp,rlog,spmpar + EXTERNAL erf,erfc1,gam1,gamma,rexp,rlog,spmpar +C .. +C .. Intrinsic Functions .. + INTRINSIC abs,dble,dlog,dmax1,exp,int,sqrt +C .. +C .. Data statements .. +C -------------------- +C -------------------- +C ALOG10 = LN(10) +C RT2PIN = 1/SQRT(2*PI) +C RTPI = SQRT(PI) +C -------------------- +C -------------------- +C -------------------- +C -------------------- +C -------------------- +C -------------------- +C -------------------- +C -------------------- +C -------------------- + DATA acc0(1)/5.D-15/,acc0(2)/5.D-7/,acc0(3)/5.D-4/ + DATA big(1)/20.0D0/,big(2)/14.0D0/,big(3)/10.0D0/ + DATA e00(1)/.25D-3/,e00(2)/.25D-1/,e00(3)/.14D0/ + DATA x00(1)/31.0D0/,x00(2)/17.0D0/,x00(3)/9.7D0/ + DATA alog10/2.30258509299405D0/ + DATA rt2pin/.398942280401433D0/ + DATA rtpi/1.77245385090552D0/ + DATA third/.333333333333333D0/ + DATA d0(1)/.833333333333333D-01/,d0(2)/-.148148148148148D-01/, + + d0(3)/.115740740740741D-02/,d0(4)/.352733686067019D-03/, + + d0(5)/-.178755144032922D-03/,d0(6)/.391926317852244D-04/, + + d0(7)/-.218544851067999D-05/,d0(8)/-.185406221071516D-05/, + + d0(9)/.829671134095309D-06/,d0(10)/-.176659527368261D-06/, + + d0(11)/.670785354340150D-08/,d0(12)/.102618097842403D-07/, + + d0(13)/-.438203601845335D-08/ + DATA d10/-.185185185185185D-02/,d1(1)/-.347222222222222D-02/, + + d1(2)/.264550264550265D-02/,d1(3)/-.990226337448560D-03/, + + d1(4)/.205761316872428D-03/,d1(5)/-.401877572016461D-06/, + + d1(6)/-.180985503344900D-04/,d1(7)/.764916091608111D-05/, + + d1(8)/-.161209008945634D-05/,d1(9)/.464712780280743D-08/, + + d1(10)/.137863344691572D-06/,d1(11)/-.575254560351770D-07/, + + d1(12)/.119516285997781D-07/ + DATA d20/.413359788359788D-02/,d2(1)/-.268132716049383D-02/, + + d2(2)/.771604938271605D-03/,d2(3)/.200938786008230D-05/, + + d2(4)/-.107366532263652D-03/,d2(5)/.529234488291201D-04/, + + d2(6)/-.127606351886187D-04/,d2(7)/.342357873409614D-07/, + + d2(8)/.137219573090629D-05/,d2(9)/-.629899213838006D-06/, + + d2(10)/.142806142060642D-06/ + DATA d30/.649434156378601D-03/,d3(1)/.229472093621399D-03/, + + d3(2)/-.469189494395256D-03/,d3(3)/.267720632062839D-03/, + + d3(4)/-.756180167188398D-04/,d3(5)/-.239650511386730D-06/, + + d3(6)/.110826541153473D-04/,d3(7)/-.567495282699160D-05/, + + d3(8)/.142309007324359D-05/ + DATA d40/-.861888290916712D-03/,d4(1)/.784039221720067D-03/, + + d4(2)/-.299072480303190D-03/,d4(3)/-.146384525788434D-05/, + + d4(4)/.664149821546512D-04/,d4(5)/-.396836504717943D-04/, + + d4(6)/.113757269706784D-04/ + DATA d50/-.336798553366358D-03/,d5(1)/-.697281375836586D-04/, + + d5(2)/.277275324495939D-03/,d5(3)/-.199325705161888D-03/, + + d5(4)/.679778047793721D-04/ + DATA d60/.531307936463992D-03/,d6(1)/-.592166437353694D-03/, + + d6(2)/.270878209671804D-03/ + DATA d70/.344367606892378D-03/ +C .. +C .. Executable Statements .. +C -------------------- +C ****** E IS A MACHINE DEPENDENT CONSTANT. E IS THE SMALLEST +C FLOATING POINT NUMBER FOR WHICH 1.0 + E .GT. 1.0 . +C + e = spmpar(1) +C +C -------------------- + IF (a.LT.0.0D0 .OR. x.LT.0.0D0) GO TO 430 + IF (a.EQ.0.0D0 .AND. x.EQ.0.0D0) GO TO 430 + IF (a*x.EQ.0.0D0) GO TO 420 +C + iop = ind + 1 + IF (iop.NE.1 .AND. iop.NE.2) iop = 3 + acc = dmax1(acc0(iop),e) + e0 = e00(iop) + x0 = x00(iop) +C +C SELECT THE APPROPRIATE ALGORITHM +C + IF (a.GE.1.0D0) GO TO 10 + IF (a.EQ.0.5D0) GO TO 390 + IF (x.LT.1.1D0) GO TO 160 + t1 = a*dlog(x) - x + u = a*exp(t1) + IF (u.EQ.0.0D0) GO TO 380 + r = u* (1.0D0+gam1(a)) + GO TO 250 +C + 10 IF (a.GE.big(iop)) GO TO 30 + IF (a.GT.x .OR. x.GE.x0) GO TO 20 + twoa = a + a + m = int(twoa) + IF (twoa.NE.dble(m)) GO TO 20 + i = m/2 + IF (a.EQ.dble(i)) GO TO 210 + GO TO 220 + + 20 t1 = a*dlog(x) - x + r = exp(t1)/gamma(a) + GO TO 40 +C + 30 l = x/a + IF (l.EQ.0.0D0) GO TO 370 + s = 0.5D0 + (0.5D0-l) + z = rlog(l) + IF (z.GE.700.0D0/a) GO TO 410 + y = a*z + rta = sqrt(a) + IF (abs(s).LE.e0/rta) GO TO 330 + IF (abs(s).LE.0.4D0) GO TO 270 +C + t = (1.0D0/a)**2 + t1 = (((0.75D0*t-1.0D0)*t+3.5D0)*t-105.0D0)/ (a*1260.0D0) + t1 = t1 - y + r = rt2pin*rta*exp(t1) +C + 40 IF (r.EQ.0.0D0) GO TO 420 + IF (x.LE.dmax1(a,alog10)) GO TO 50 + IF (x.LT.x0) GO TO 250 + GO TO 100 +C +C TAYLOR SERIES FOR P/R +C + 50 apn = a + 1.0D0 + t = x/apn + wk(1) = t + DO 60 n = 2,20 + apn = apn + 1.0D0 + t = t* (x/apn) + IF (t.LE.1.D-3) GO TO 70 + wk(n) = t + 60 CONTINUE + n = 20 +C + 70 sum = t + tol = 0.5D0*acc + 80 apn = apn + 1.0D0 + t = t* (x/apn) + sum = sum + t + IF (t.GT.tol) GO TO 80 +C + max = n - 1 + DO 90 m = 1,max + n = n - 1 + sum = sum + wk(n) + 90 CONTINUE + ans = (r/a)* (1.0D0+sum) + qans = 0.5D0 + (0.5D0-ans) + RETURN +C +C ASYMPTOTIC EXPANSION +C + 100 amn = a - 1.0D0 + t = amn/x + wk(1) = t + DO 110 n = 2,20 + amn = amn - 1.0D0 + t = t* (amn/x) + IF (abs(t).LE.1.D-3) GO TO 120 + wk(n) = t + 110 CONTINUE + n = 20 +C + 120 sum = t + 130 IF (abs(t).LE.acc) GO TO 140 + amn = amn - 1.0D0 + t = t* (amn/x) + sum = sum + t + GO TO 130 +C + 140 max = n - 1 + DO 150 m = 1,max + n = n - 1 + sum = sum + wk(n) + 150 CONTINUE + qans = (r/x)* (1.0D0+sum) + ans = 0.5D0 + (0.5D0-qans) + RETURN +C +C TAYLOR SERIES FOR P(A,X)/X**A +C + 160 an = 3.0D0 + c = x + sum = x/ (a+3.0D0) + tol = 3.0D0*acc/ (a+1.0D0) + 170 an = an + 1.0D0 + c = -c* (x/an) + t = c/ (a+an) + sum = sum + t + IF (abs(t).GT.tol) GO TO 170 + j = a*x* ((sum/6.0D0-0.5D0/ (a+2.0D0))*x+1.0D0/ (a+1.0D0)) +C + z = a*dlog(x) + h = gam1(a) + g = 1.0D0 + h + IF (x.LT.0.25D0) GO TO 180 + IF (a.LT.x/2.59D0) GO TO 200 + GO TO 190 + + 180 IF (z.GT.-.13394D0) GO TO 200 +C + 190 w = exp(z) + ans = w*g* (0.5D0+ (0.5D0-j)) + qans = 0.5D0 + (0.5D0-ans) + RETURN +C + 200 l = rexp(z) + w = 0.5D0 + (0.5D0+l) + qans = (w*j-l)*g - h + IF (qans.LT.0.0D0) GO TO 380 + ans = 0.5D0 + (0.5D0-qans) + RETURN +C +C FINITE SUMS FOR Q WHEN A .GE. 1 +C AND 2*A IS AN INTEGER +C + 210 sum = exp(-x) + t = sum + n = 1 + c = 0.0D0 + GO TO 230 +C + 220 rtx = sqrt(x) + sum = erfc1(0,rtx) + t = exp(-x)/ (rtpi*rtx) + n = 0 + c = -0.5D0 +C + 230 IF (n.EQ.i) GO TO 240 + n = n + 1 + c = c + 1.0D0 + t = (x*t)/c + sum = sum + t + GO TO 230 + + 240 qans = sum + ans = 0.5D0 + (0.5D0-qans) + RETURN +C +C CONTINUED FRACTION EXPANSION +C + 250 tol = dmax1(5.0D0*e,acc) + a2nm1 = 1.0D0 + a2n = 1.0D0 + b2nm1 = x + b2n = x + (1.0D0-a) + c = 1.0D0 + 260 a2nm1 = x*a2n + c*a2nm1 + b2nm1 = x*b2n + c*b2nm1 + am0 = a2nm1/b2nm1 + c = c + 1.0D0 + cma = c - a + a2n = a2nm1 + cma*a2n + b2n = b2nm1 + cma*b2n + an0 = a2n/b2n + IF (abs(an0-am0).GE.tol*an0) GO TO 260 +C + qans = r*an0 + ans = 0.5D0 + (0.5D0-qans) + RETURN +C +C GENERAL TEMME EXPANSION +C + 270 IF (abs(s).LE.2.0D0*e .AND. a*e*e.GT.3.28D-3) GO TO 430 + c = exp(-y) + w = 0.5D0*erfc1(1,sqrt(y)) + u = 1.0D0/a + z = sqrt(z+z) + IF (l.LT.1.0D0) z = -z + CRES=iop-2 + IF (CRES .lt. 0) then + goto 280 + ELSEIF (CRES .eq. 0) then + goto 290 + ELSE + goto 300 + ENDIF +C + 280 IF (abs(s).LE.1.D-3) GO TO 340 + c0 = ((((((((((((d0(13)*z+d0(12))*z+d0(11))*z+d0(10))*z+d0(9))*z+ + + d0(8))*z+d0(7))*z+d0(6))*z+d0(5))*z+d0(4))*z+d0(3))*z+d0(2))* + + z+d0(1))*z - third + c1 = (((((((((((d1(12)*z+d1(11))*z+d1(10))*z+d1(9))*z+d1(8))*z+ + + d1(7))*z+d1(6))*z+d1(5))*z+d1(4))*z+d1(3))*z+d1(2))*z+d1(1))* + + z + d10 + c2 = (((((((((d2(10)*z+d2(9))*z+d2(8))*z+d2(7))*z+d2(6))*z+ + + d2(5))*z+d2(4))*z+d2(3))*z+d2(2))*z+d2(1))*z + d20 + c3 = (((((((d3(8)*z+d3(7))*z+d3(6))*z+d3(5))*z+d3(4))*z+d3(3))*z+ + + d3(2))*z+d3(1))*z + d30 + c4 = (((((d4(6)*z+d4(5))*z+d4(4))*z+d4(3))*z+d4(2))*z+d4(1))*z + + + d40 + c5 = (((d5(4)*z+d5(3))*z+d5(2))*z+d5(1))*z + d50 + c6 = (d6(2)*z+d6(1))*z + d60 + t = ((((((d70*u+c6)*u+c5)*u+c4)*u+c3)*u+c2)*u+c1)*u + c0 + GO TO 310 +C + 290 c0 = (((((d0(6)*z+d0(5))*z+d0(4))*z+d0(3))*z+d0(2))*z+d0(1))*z - + + third + c1 = (((d1(4)*z+d1(3))*z+d1(2))*z+d1(1))*z + d10 + c2 = d2(1)*z + d20 + t = (c2*u+c1)*u + c0 + GO TO 310 +C + 300 t = ((d0(3)*z+d0(2))*z+d0(1))*z - third +C + 310 IF (l.LT.1.0D0) GO TO 320 + qans = c* (w+rt2pin*t/rta) + ans = 0.5D0 + (0.5D0-qans) + RETURN + + 320 ans = c* (w-rt2pin*t/rta) + qans = 0.5D0 + (0.5D0-ans) + RETURN +C +C TEMME EXPANSION FOR L = 1 +C + 330 IF (a*e*e.GT.3.28D-3) GO TO 430 + c = 0.5D0 + (0.5D0-y) + w = (0.5D0-sqrt(y)* (0.5D0+ (0.5D0-y/3.0D0))/rtpi)/c + u = 1.0D0/a + z = sqrt(z+z) + IF (l.LT.1.0D0) z = -z + CRES=iop-2 + IF (CRES .lt. 0) then + goto 340 + ELSEIF (CRES .eq. 0) then + goto 350 + ELSE + goto 360 + ENDIF + +C + 340 c0 = ((((((d0(7)*z+d0(6))*z+d0(5))*z+d0(4))*z+d0(3))*z+d0(2))*z+ + + d0(1))*z - third + c1 = (((((d1(6)*z+d1(5))*z+d1(4))*z+d1(3))*z+d1(2))*z+d1(1))*z + + + d10 + c2 = ((((d2(5)*z+d2(4))*z+d2(3))*z+d2(2))*z+d2(1))*z + d20 + c3 = (((d3(4)*z+d3(3))*z+d3(2))*z+d3(1))*z + d30 + c4 = (d4(2)*z+d4(1))*z + d40 + c5 = (d5(2)*z+d5(1))*z + d50 + c6 = d6(1)*z + d60 + t = ((((((d70*u+c6)*u+c5)*u+c4)*u+c3)*u+c2)*u+c1)*u + c0 + GO TO 310 +C + 350 c0 = (d0(2)*z+d0(1))*z - third + c1 = d1(1)*z + d10 + t = (d20*u+c1)*u + c0 + GO TO 310 +C + 360 t = d0(1)*z - third + GO TO 310 +C +C SPECIAL CASES +C + 370 ans = 0.0D0 + qans = 1.0D0 + RETURN +C + 380 ans = 1.0D0 + qans = 0.0D0 + RETURN +C + 390 IF (x.GE.0.25D0) GO TO 400 + ans = erf(sqrt(x)) + qans = 0.5D0 + (0.5D0-ans) + RETURN + + 400 qans = erfc1(0,sqrt(x)) + ans = 0.5D0 + (0.5D0-qans) + RETURN +C + 410 IF (abs(s).LE.2.0D0*e) GO TO 430 + 420 IF (x.LE.a) GO TO 370 + GO TO 380 +C +C ERROR RETURN +C + 430 ans = 2.0D0 + RETURN + + END diff --git a/modules/statistics/src/dcdflib/gratio.lo b/modules/statistics/src/dcdflib/gratio.lo new file mode 100755 index 000000000..b271cd046 --- /dev/null +++ b/modules/statistics/src/dcdflib/gratio.lo @@ -0,0 +1,12 @@ +# src/dcdflib/gratio.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/gratio.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/statistics/src/dcdflib/gsumln.f b/modules/statistics/src/dcdflib/gsumln.f new file mode 100755 index 000000000..6eec02559 --- /dev/null +++ b/modules/statistics/src/dcdflib/gsumln.f @@ -0,0 +1,32 @@ + DOUBLE PRECISION FUNCTION gsumln(a,b) +C----------------------------------------------------------------------- +C EVALUATION OF THE FUNCTION LN(GAMMA(A + B)) +C FOR 1 .LE. A .LE. 2 AND 1 .LE. B .LE. 2 +C----------------------------------------------------------------------- +C .. Scalar Arguments .. + DOUBLE PRECISION a,b +C .. +C .. Local Scalars .. + DOUBLE PRECISION x +C .. +C .. External Functions .. + DOUBLE PRECISION alnrel,gamln1 + EXTERNAL alnrel,gamln1 +C .. +C .. Intrinsic Functions .. + INTRINSIC dble,dlog +C .. +C .. Executable Statements .. + x = dble(a) + dble(b) - 2.D0 + IF (x.GT.0.25D0) GO TO 10 + gsumln = gamln1(1.0D0+x) + RETURN + + 10 IF (x.GT.1.25D0) GO TO 20 + gsumln = gamln1(x) + alnrel(x) + RETURN + + 20 gsumln = gamln1(x-1.0D0) + dlog(x* (1.0D0+x)) + RETURN + + END diff --git a/modules/statistics/src/dcdflib/gsumln.lo b/modules/statistics/src/dcdflib/gsumln.lo new file mode 100755 index 000000000..4001f54f4 --- /dev/null +++ b/modules/statistics/src/dcdflib/gsumln.lo @@ -0,0 +1,12 @@ +# src/dcdflib/gsumln.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/gsumln.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/statistics/src/dcdflib/ipmpar.f b/modules/statistics/src/dcdflib/ipmpar.f new file mode 100755 index 000000000..e8bd41f6e --- /dev/null +++ b/modules/statistics/src/dcdflib/ipmpar.f @@ -0,0 +1,54 @@ + INTEGER FUNCTION ipmpar(i) +C----------------------------------------------------------------------- +C INTEGERS. +C +C ASSUME INTEGERS ARE REPRESENTED IN THE N-DIGIT, BASE-A FORM +C +C SIGN ( X(N-1)*A**(N-1) + ... + X(1)*A + X(0) ) +C +C WHERE 0 .LE. X(I) .LT. A FOR I=0,...,N-1. +C +C IPMPAR(1) = A, THE BASE. +C IPMPAR(2) = N, THE NUMBER OF BASE-A DIGITS. +C IPMPAR(3) = A**N - 1, THE LARGEST MAGNITUDE. +C +C FLOATING-POINT NUMBERS. +C +C IT IS ASSUMED THAT THE SINGLE AND DOUBLE PRECISION FLOATING +C POINT ARITHMETICS HAVE THE SAME BASE, SAY B, AND THAT THE +C NONZERO NUMBERS ARE REPRESENTED IN THE FORM +C +C SIGN (B**E) * (X(1)/B + ... + X(M)/B**M) +C +C WHERE X(I) = 0,1,...,B-1 FOR I=1,...,M, +C X(1) .GE. 1, AND EMIN .LE. E .LE. EMAX. +C +C IPMPAR(4) = B, THE BASE. +C SINGLE-PRECISION +C IPMPAR(5) = M, THE NUMBER OF BASE-B DIGITS. +C IPMPAR(6) = EMIN, THE SMALLEST EXPONENT E. +C IPMPAR(7) = EMAX, THE LARGEST EXPONENT E. +C DOUBLE-PRECISION +C IPMPAR(8) = M, THE NUMBER OF BASE-B DIGITS. +C IPMPAR(9) = EMIN, THE SMALLEST EXPONENT E. +C IPMPAR(10) = EMAX, THE LARGEST EXPONENT E. +C----------------------------------------------------------------------- +C RWRITTEN BY JPC to use lapack dlamch + a small c program +C for ipmpar(3) +C----------------------------------------------------------------------- + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH + include 'stack.h' + goto (1,1,3,4,1,1,1,1,9,10) i + 1 continue + call basout(io,wte,'ipmpar called with wrong argument') + ipmpar = 0 + return + 3 ipmpar = largestint() + return + 4 ipmpar=dlamch('b') + return + 9 ipmpar=dlamch('m') + return + 10 ipmpar= dlamch('l') + END diff --git a/modules/statistics/src/dcdflib/ipmpar.f.dist b/modules/statistics/src/dcdflib/ipmpar.f.dist new file mode 100755 index 000000000..a52a8d77f --- /dev/null +++ b/modules/statistics/src/dcdflib/ipmpar.f.dist @@ -0,0 +1,429 @@ + INTEGER FUNCTION ipmpar(i) +C----------------------------------------------------------------------- +C +C IPMPAR PROVIDES THE INTEGER MACHINE CONSTANTS FOR THE COMPUTER +C THAT IS USED. IT IS ASSUMED THAT THE ARGUMENT I IS AN INTEGER +C HAVING ONE OF THE VALUES 1-10. IPMPAR(I) HAS THE VALUE ... +C +C INTEGERS. +C +C ASSUME INTEGERS ARE REPRESENTED IN THE N-DIGIT, BASE-A FORM +C +C SIGN ( X(N-1)*A**(N-1) + ... + X(1)*A + X(0) ) +C +C WHERE 0 .LE. X(I) .LT. A FOR I=0,...,N-1. +C +C IPMPAR(1) = A, THE BASE. +C +C IPMPAR(2) = N, THE NUMBER OF BASE-A DIGITS. +C +C IPMPAR(3) = A**N - 1, THE LARGEST MAGNITUDE. +C +C FLOATING-POINT NUMBERS. +C +C IT IS ASSUMED THAT THE SINGLE AND DOUBLE PRECISION FLOATING +C POINT ARITHMETICS HAVE THE SAME BASE, SAY B, AND THAT THE +C NONZERO NUMBERS ARE REPRESENTED IN THE FORM +C +C SIGN (B**E) * (X(1)/B + ... + X(M)/B**M) +C +C WHERE X(I) = 0,1,...,B-1 FOR I=1,...,M, +C X(1) .GE. 1, AND EMIN .LE. E .LE. EMAX. +C +C IPMPAR(4) = B, THE BASE. +C +C SINGLE-PRECISION +C +C IPMPAR(5) = M, THE NUMBER OF BASE-B DIGITS. +C +C IPMPAR(6) = EMIN, THE SMALLEST EXPONENT E. +C +C IPMPAR(7) = EMAX, THE LARGEST EXPONENT E. +C +C DOUBLE-PRECISION +C +C IPMPAR(8) = M, THE NUMBER OF BASE-B DIGITS. +C +C IPMPAR(9) = EMIN, THE SMALLEST EXPONENT E. +C +C IPMPAR(10) = EMAX, THE LARGEST EXPONENT E. +C +C----------------------------------------------------------------------- +C +C TO DEFINE THIS FUNCTION FOR THE COMPUTER BEING USED, ACTIVATE +C THE DATA STATMENTS FOR THE COMPUTER BY REMOVING THE C FROM +C COLUMN 1. (ALL THE OTHER DATA STATEMENTS SHOULD HAVE C IN +C COLUMN 1.) +C +C----------------------------------------------------------------------- +C +C IPMPAR IS AN ADAPTATION OF THE FUNCTION I1MACH, WRITTEN BY +C P.A. FOX, A.D. HALL, AND N.L. SCHRYER (BELL LABORATORIES). +C IPMPAR WAS FORMED BY A.H. MORRIS (NSWC). THE CONSTANTS ARE +C FROM BELL LABORATORIES, NSWC, AND OTHER SOURCES. +C +C----------------------------------------------------------------------- +C .. Scalar Arguments .. + INTEGER i +C .. +C .. Local Arrays .. + INTEGER imach(10) +C .. +C .. Data statements .. +C +C MACHINE CONSTANTS FOR AMDAHL MACHINES. +C +C DATA IMACH( 1) / 2 / +C DATA IMACH( 2) / 31 / +C DATA IMACH( 3) / 2147483647 / +C DATA IMACH( 4) / 16 / +C DATA IMACH( 5) / 6 / +C DATA IMACH( 6) / -64 / +C DATA IMACH( 7) / 63 / +C DATA IMACH( 8) / 14 / +C DATA IMACH( 9) / -64 / +C DATA IMACH(10) / 63 / +C +C MACHINE CONSTANTS FOR THE AT&T 3B SERIES, AT&T +C PC 7300, AND AT&T 6300. +C +C DATA IMACH( 1) / 2 / +C DATA IMACH( 2) / 31 / +C DATA IMACH( 3) / 2147483647 / +C DATA IMACH( 4) / 2 / +C DATA IMACH( 5) / 24 / +C DATA IMACH( 6) / -125 / +C DATA IMACH( 7) / 128 / +C DATA IMACH( 8) / 53 / +C DATA IMACH( 9) / -1021 / +C DATA IMACH(10) / 1024 / +C +C MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM. +C +C DATA IMACH( 1) / 2 / +C DATA IMACH( 2) / 33 / +C DATA IMACH( 3) / 8589934591 / +C DATA IMACH( 4) / 2 / +C DATA IMACH( 5) / 24 / +C DATA IMACH( 6) / -256 / +C DATA IMACH( 7) / 255 / +C DATA IMACH( 8) / 60 / +C DATA IMACH( 9) / -256 / +C DATA IMACH(10) / 255 / +C +C MACHINE CONSTANTS FOR THE BURROUGHS 5700 SYSTEM. +C +C DATA IMACH( 1) / 2 / +C DATA IMACH( 2) / 39 / +C DATA IMACH( 3) / 549755813887 / +C DATA IMACH( 4) / 8 / +C DATA IMACH( 5) / 13 / +C DATA IMACH( 6) / -50 / +C DATA IMACH( 7) / 76 / +C DATA IMACH( 8) / 26 / +C DATA IMACH( 9) / -50 / +C DATA IMACH(10) / 76 / +C +C MACHINE CONSTANTS FOR THE BURROUGHS 6700/7700 SYSTEMS. +C +C DATA IMACH( 1) / 2 / +C DATA IMACH( 2) / 39 / +C DATA IMACH( 3) / 549755813887 / +C DATA IMACH( 4) / 8 / +C DATA IMACH( 5) / 13 / +C DATA IMACH( 6) / -50 / +C DATA IMACH( 7) / 76 / +C DATA IMACH( 8) / 26 / +C DATA IMACH( 9) / -32754 / +C DATA IMACH(10) / 32780 / +C +C MACHINE CONSTANTS FOR THE CDC 6000/7000 SERIES +C 60 BIT ARITHMETIC, AND THE CDC CYBER 995 64 BIT +C ARITHMETIC (NOS OPERATING SYSTEM). +C +C DATA IMACH( 1) / 2 / +C DATA IMACH( 2) / 48 / +C DATA IMACH( 3) / 281474976710655 / +C DATA IMACH( 4) / 2 / +C DATA IMACH( 5) / 48 / +C DATA IMACH( 6) / -974 / +C DATA IMACH( 7) / 1070 / +C DATA IMACH( 8) / 95 / +C DATA IMACH( 9) / -926 / +C DATA IMACH(10) / 1070 / +C +C MACHINE CONSTANTS FOR THE CDC CYBER 995 64 BIT +C ARITHMETIC (NOS/VE OPERATING SYSTEM). +C +C DATA IMACH( 1) / 2 / +C DATA IMACH( 2) / 63 / +C DATA IMACH( 3) / 9223372036854775807 / +C DATA IMACH( 4) / 2 / +C DATA IMACH( 5) / 48 / +C DATA IMACH( 6) / -4096 / +C DATA IMACH( 7) / 4095 / +C DATA IMACH( 8) / 96 / +C DATA IMACH( 9) / -4096 / +C DATA IMACH(10) / 4095 / +C +C MACHINE CONSTANTS FOR THE CRAY 1, XMP, 2, AND 3. +C +C DATA IMACH( 1) / 2 / +C DATA IMACH( 2) / 63 / +C DATA IMACH( 3) / 9223372036854775807 / +C DATA IMACH( 4) / 2 / +C DATA IMACH( 5) / 47 / +C DATA IMACH( 6) / -8189 / +C DATA IMACH( 7) / 8190 / +C DATA IMACH( 8) / 94 / +C DATA IMACH( 9) / -8099 / +C DATA IMACH(10) / 8190 / +C +C MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200. +C +C DATA IMACH( 1) / 2 / +C DATA IMACH( 2) / 15 / +C DATA IMACH( 3) / 32767 / +C DATA IMACH( 4) / 16 / +C DATA IMACH( 5) / 6 / +C DATA IMACH( 6) / -64 / +C DATA IMACH( 7) / 63 / +C DATA IMACH( 8) / 14 / +C DATA IMACH( 9) / -64 / +C DATA IMACH(10) / 63 / +C +C MACHINE CONSTANTS FOR THE HARRIS 220. +C +C DATA IMACH( 1) / 2 / +C DATA IMACH( 2) / 23 / +C DATA IMACH( 3) / 8388607 / +C DATA IMACH( 4) / 2 / +C DATA IMACH( 5) / 23 / +C DATA IMACH( 6) / -127 / +C DATA IMACH( 7) / 127 / +C DATA IMACH( 8) / 38 / +C DATA IMACH( 9) / -127 / +C DATA IMACH(10) / 127 / +C +C MACHINE CONSTANTS FOR THE HONEYWELL 600/6000 +C AND DPS 8/70 SERIES. +C +C DATA IMACH( 1) / 2 / +C DATA IMACH( 2) / 35 / +C DATA IMACH( 3) / 34359738367 / +C DATA IMACH( 4) / 2 / +C DATA IMACH( 5) / 27 / +C DATA IMACH( 6) / -127 / +C DATA IMACH( 7) / 127 / +C DATA IMACH( 8) / 63 / +C DATA IMACH( 9) / -127 / +C DATA IMACH(10) / 127 / +C +C MACHINE CONSTANTS FOR THE HP 2100 +C 3 WORD DOUBLE PRECISION OPTION WITH FTN4 +C +C DATA IMACH( 1) / 2 / +C DATA IMACH( 2) / 15 / +C DATA IMACH( 3) / 32767 / +C DATA IMACH( 4) / 2 / +C DATA IMACH( 5) / 23 / +C DATA IMACH( 6) / -128 / +C DATA IMACH( 7) / 127 / +C DATA IMACH( 8) / 39 / +C DATA IMACH( 9) / -128 / +C DATA IMACH(10) / 127 / +C +C MACHINE CONSTANTS FOR THE HP 2100 +C 4 WORD DOUBLE PRECISION OPTION WITH FTN4 +C +C DATA IMACH( 1) / 2 / +C DATA IMACH( 2) / 15 / +C DATA IMACH( 3) / 32767 / +C DATA IMACH( 4) / 2 / +C DATA IMACH( 5) / 23 / +C DATA IMACH( 6) / -128 / +C DATA IMACH( 7) / 127 / +C DATA IMACH( 8) / 55 / +C DATA IMACH( 9) / -128 / +C DATA IMACH(10) / 127 / +C +C MACHINE CONSTANTS FOR THE HP 9000. +C +C DATA IMACH( 1) / 2 / +C DATA IMACH( 2) / 31 / +C DATA IMACH( 3) / 2147483647 / +C DATA IMACH( 4) / 2 / +C DATA IMACH( 5) / 24 / +C DATA IMACH( 6) / -126 / +C DATA IMACH( 7) / 128 / +C DATA IMACH( 8) / 53 / +C DATA IMACH( 9) / -1021 / +C DATA IMACH(10) / 1024 / +C +C MACHINE CONSTANTS FOR THE IBM 360/370 SERIES, +C THE ICL 2900, THE ITEL AS/6, THE XEROX SIGMA +C 5/7/9 AND THE SEL SYSTEMS 85/86. +C +C DATA IMACH( 1) / 2 / +C DATA IMACH( 2) / 31 / +C DATA IMACH( 3) / 2147483647 / +C DATA IMACH( 4) / 16 / +C DATA IMACH( 5) / 6 / +C DATA IMACH( 6) / -64 / +C DATA IMACH( 7) / 63 / +C DATA IMACH( 8) / 14 / +C DATA IMACH( 9) / -64 / +C DATA IMACH(10) / 63 / +C +C MACHINE CONSTANTS FOR THE IBM PC. +C +C DATA imach(1)/2/ +C DATA imach(2)/31/ +C DATA imach(3)/2147483647/ +C DATA imach(4)/2/ +C DATA imach(5)/24/ +C DATA imach(6)/-125/ +C DATA imach(7)/128/ +C DATA imach(8)/53/ +C DATA imach(9)/-1021/ +C DATA imach(10)/1024/ +C +C MACHINE CONSTANTS FOR THE MACINTOSH II - ABSOFT +C MACFORTRAN II. +C +C DATA IMACH( 1) / 2 / +C DATA IMACH( 2) / 31 / +C DATA IMACH( 3) / 2147483647 / +C DATA IMACH( 4) / 2 / +C DATA IMACH( 5) / 24 / +C DATA IMACH( 6) / -125 / +C DATA IMACH( 7) / 128 / +C DATA IMACH( 8) / 53 / +C DATA IMACH( 9) / -1021 / +C DATA IMACH(10) / 1024 / +C +C MACHINE CONSTANTS FOR THE MICROVAX - VMS FORTRAN. +C +C DATA IMACH( 1) / 2 / +C DATA IMACH( 2) / 31 / +C DATA IMACH( 3) / 2147483647 / +C DATA IMACH( 4) / 2 / +C DATA IMACH( 5) / 24 / +C DATA IMACH( 6) / -127 / +C DATA IMACH( 7) / 127 / +C DATA IMACH( 8) / 56 / +C DATA IMACH( 9) / -127 / +C DATA IMACH(10) / 127 / +C +C MACHINE CONSTANTS FOR THE PDP-10 (KA PROCESSOR). +C +C DATA IMACH( 1) / 2 / +C DATA IMACH( 2) / 35 / +C DATA IMACH( 3) / 34359738367 / +C DATA IMACH( 4) / 2 / +C DATA IMACH( 5) / 27 / +C DATA IMACH( 6) / -128 / +C DATA IMACH( 7) / 127 / +C DATA IMACH( 8) / 54 / +C DATA IMACH( 9) / -101 / +C DATA IMACH(10) / 127 / +C +C MACHINE CONSTANTS FOR THE PDP-10 (KI PROCESSOR). +C +C DATA IMACH( 1) / 2 / +C DATA IMACH( 2) / 35 / +C DATA IMACH( 3) / 34359738367 / +C DATA IMACH( 4) / 2 / +C DATA IMACH( 5) / 27 / +C DATA IMACH( 6) / -128 / +C DATA IMACH( 7) / 127 / +C DATA IMACH( 8) / 62 / +C DATA IMACH( 9) / -128 / +C DATA IMACH(10) / 127 / +C +C MACHINE CONSTANTS FOR THE PDP-11 FORTRAN SUPPORTING +C 32-BIT INTEGER ARITHMETIC. +C +C DATA IMACH( 1) / 2 / +C DATA IMACH( 2) / 31 / +C DATA IMACH( 3) / 2147483647 / +C DATA IMACH( 4) / 2 / +C DATA IMACH( 5) / 24 / +C DATA IMACH( 6) / -127 / +C DATA IMACH( 7) / 127 / +C DATA IMACH( 8) / 56 / +C DATA IMACH( 9) / -127 / +C DATA IMACH(10) / 127 / +C +C MACHINE CONSTANTS FOR THE SEQUENT BALANCE 8000. +C +C DATA IMACH( 1) / 2 / +C DATA IMACH( 2) / 31 / +C DATA IMACH( 3) / 2147483647 / +C DATA IMACH( 4) / 2 / +C DATA IMACH( 5) / 24 / +C DATA IMACH( 6) / -125 / +C DATA IMACH( 7) / 128 / +C DATA IMACH( 8) / 53 / +C DATA IMACH( 9) / -1021 / +C DATA IMACH(10) / 1024 / +C +C MACHINE CONSTANTS FOR THE SILICON GRAPHICS IRIS-4D +C SERIES (MIPS R3000 PROCESSOR). +C +C DATA IMACH( 1) / 2 / +C DATA IMACH( 2) / 31 / +C DATA IMACH( 3) / 2147483647 / +C DATA IMACH( 4) / 2 / +C DATA IMACH( 5) / 24 / +C DATA IMACH( 6) / -125 / +C DATA IMACH( 7) / 128 / +C DATA IMACH( 8) / 53 / +C DATA IMACH( 9) / -1021 / +C DATA IMACH(10) / 1024 / +C +C MACHINE CONSTANTS FOR IEEE ARITHMETIC MACHINES, SUCH AS THE AT&T +C 3B SERIES, MOTOROLA 68000 BASED MACHINES (E.G. SUN 3 AND AT&T +C PC 7300), AND 8087 BASED MICROS (E.G. IBM PC AND AT&T 6300). +C + DATA IMACH( 1) / 2 / + DATA IMACH( 2) / 31 / + DATA IMACH( 3) / 2147483647 / + DATA IMACH( 4) / 2 / + DATA IMACH( 5) / 24 / + DATA IMACH( 6) / -125 / + DATA IMACH( 7) / 128 / + DATA IMACH( 8) / 53 / + DATA IMACH( 9) / -1021 / + DATA IMACH(10) / 1024 / +C +C MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES. +C +C DATA IMACH( 1) / 2 / +C DATA IMACH( 2) / 35 / +C DATA IMACH( 3) / 34359738367 / +C DATA IMACH( 4) / 2 / +C DATA IMACH( 5) / 27 / +C DATA IMACH( 6) / -128 / +C DATA IMACH( 7) / 127 / +C DATA IMACH( 8) / 60 / +C DATA IMACH( 9) /-1024 / +C DATA IMACH(10) / 1023 / +C +C MACHINE CONSTANTS FOR THE VAX 11/780. +C +C DATA IMACH( 1) / 2 / +C DATA IMACH( 2) / 31 / +C DATA IMACH( 3) / 2147483647 / +C DATA IMACH( 4) / 2 / +C DATA IMACH( 5) / 24 / +C DATA IMACH( 6) / -127 / +C DATA IMACH( 7) / 127 / +C DATA IMACH( 8) / 56 / +C DATA IMACH( 9) / -127 / +C DATA IMACH(10) / 127 / +C + ipmpar = imach(i) + RETURN + + END diff --git a/modules/statistics/src/dcdflib/ipmpar.lo b/modules/statistics/src/dcdflib/ipmpar.lo new file mode 100755 index 000000000..482d3e5cf --- /dev/null +++ b/modules/statistics/src/dcdflib/ipmpar.lo @@ -0,0 +1,12 @@ +# src/dcdflib/ipmpar.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/ipmpar.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/statistics/src/dcdflib/psi.f b/modules/statistics/src/dcdflib/psi.f new file mode 100755 index 000000000..8304f5584 --- /dev/null +++ b/modules/statistics/src/dcdflib/psi.f @@ -0,0 +1,193 @@ + DOUBLE PRECISION FUNCTION psi1(xx) +C--------------------------------------------------------------------- +C +C EVALUATION OF THE DIGAMMA FUNCTION +C +C ----------- +C +C PSI1(XX) IS ASSIGNED THE VALUE 0 WHEN THE DIGAMMA FUNCTION CANNOT +C BE COMPUTED. +C +C THE MAIN COMPUTATION INVOLVES EVALUATION OF RATIONAL CHEBYSHEV +C APPROXIMATIONS PUBLISHED IN MATH. COMP. 27, 123-127(1973) BY +C CODY, STRECOK AND THACHER. +C +C--------------------------------------------------------------------- +C PSI1 WAS WRITTEN AT ARGONNE NATIONAL LABORATORY FOR THE FUNPACK +C PACKAGE OF SPECIAL FUNCTION SUBROUTINES. PSI1 WAS MODIFIED BY +C A.H. MORRIS (NSWC). +C--------------------------------------------------------------------- +C .. Scalar Arguments .. + DOUBLE PRECISION xx +C .. +C .. Local Scalars .. + DOUBLE PRECISION aug,den,dx0,piov4,sgn,upper,w,x,xmax1,xmx0, + + xsmall,z + INTEGER i,m,n,nq +C .. +C .. Local Arrays .. + DOUBLE PRECISION p1(7),p2(4),q1(6),q2(4) +C .. +C .. External Functions .. + DOUBLE PRECISION spmpar + INTEGER ipmpar + EXTERNAL spmpar,ipmpar +C .. +C .. Intrinsic Functions .. + INTRINSIC abs,cos,dble,dlog,dmin1,int,sin +C .. +C .. Data statements .. +C--------------------------------------------------------------------- +C +C PIOV4 = PI/4 +C DX0 = ZERO OF PSI1 TO EXTENDED PRECISION +C +C--------------------------------------------------------------------- +C--------------------------------------------------------------------- +C +C COEFFICIENTS FOR RATIONAL APPROXIMATION OF +C PSI1(X) / (X - X0), 0.5 .LE. X .LE. 3.0 +C +C--------------------------------------------------------------------- +C--------------------------------------------------------------------- +C +C COEFFICIENTS FOR RATIONAL APPROXIMATION OF +C PSI1(X) - LN(X) + 1 / (2*X), X .GT. 3.0 +C +C--------------------------------------------------------------------- + DATA piov4/.785398163397448D0/ + DATA dx0/1.461632144968362341262659542325721325D0/ + DATA p1(1)/.895385022981970D-02/,p1(2)/.477762828042627D+01/, + + p1(3)/.142441585084029D+03/,p1(4)/.118645200713425D+04/, + + p1(5)/.363351846806499D+04/,p1(6)/.413810161269013D+04/, + + p1(7)/.130560269827897D+04/ + DATA q1(1)/.448452573429826D+02/,q1(2)/.520752771467162D+03/, + + q1(3)/.221000799247830D+04/,q1(4)/.364127349079381D+04/, + + q1(5)/.190831076596300D+04/,q1(6)/.691091682714533D-05/ + DATA p2(1)/-.212940445131011D+01/,p2(2)/-.701677227766759D+01/, + + p2(3)/-.448616543918019D+01/,p2(4)/-.648157123766197D+00/ + DATA q2(1)/.322703493791143D+02/,q2(2)/.892920700481861D+02/, + + q2(3)/.546117738103215D+02/,q2(4)/.777788548522962D+01/ +C .. +C .. Executable Statements .. +C--------------------------------------------------------------------- +C +C MACHINE DEPENDENT CONSTANTS ... +C +C XMAX1 = THE SMALLEST POSITIVE FLOATING POINT CONSTANT +C WITH ENTIRELY INTEGER REPRESENTATION. ALSO USED +C AS NEGATIVE OF LOWER BOUND ON ACCEPTABLE NEGATIVE +C ARGUMENTS AND AS THE POSITIVE ARGUMENT BEYOND WHICH +C PSI1 MAY BE REPRESENTED AS ALOG(X). +C +C XSMALL = ABSOLUTE ARGUMENT BELOW WHICH PI*COTAN(PI*X) +C MAY BE REPRESENTED BY 1/X. +C +C--------------------------------------------------------------------- + xmax1 = ipmpar(3) + xmax1 = dmin1(xmax1,1.0D0/spmpar(1)) + xsmall = 1.D-9 +C--------------------------------------------------------------------- + x = xx + aug = 0.0D0 + IF (x.GE.0.5D0) GO TO 50 +C--------------------------------------------------------------------- +C X .LT. 0.5, USE REFLECTION FORMULA +C PSI1(1-X) = PSI1(X) + PI * COTAN(PI*X) +C--------------------------------------------------------------------- + IF (abs(x).GT.xsmall) GO TO 10 + IF (x.EQ.0.0D0) GO TO 100 +C--------------------------------------------------------------------- +C 0 .LT. ABS(X) .LE. XSMALL. USE 1/X AS A SUBSTITUTE +C FOR PI*COTAN(PI*X) +C--------------------------------------------------------------------- + aug = -1.0D0/x + GO TO 40 +C--------------------------------------------------------------------- +C REDUCTION OF ARGUMENT FOR COTAN +C--------------------------------------------------------------------- + 10 w = -x + sgn = piov4 + IF (w.GT.0.0D0) GO TO 20 + w = -w + sgn = -sgn +C--------------------------------------------------------------------- +C MAKE AN ERROR EXIT IF X .LE. -XMAX1 +C--------------------------------------------------------------------- + 20 IF (w.GE.xmax1) GO TO 100 + nq = int(w) + w = w - dble(nq) + nq = int(w*4.0D0) + w = 4.0D0* (w-dble(nq)*.25D0) +C--------------------------------------------------------------------- +C W IS NOW RELATED TO THE FRACTIONAL PART OF 4.0 * X. +C ADJUST ARGUMENT TO CORRESPOND TO VALUES IN FIRST +C QUADRANT AND DETERMINE SIGN +C--------------------------------------------------------------------- + n = nq/2 + IF ((n+n).NE.nq) w = 1.0D0 - w + z = piov4*w + m = n/2 + IF ((m+m).NE.n) sgn = -sgn +C--------------------------------------------------------------------- +C DETERMINE FINAL VALUE FOR -PI*COTAN(PI*X) +C--------------------------------------------------------------------- + n = (nq+1)/2 + m = n/2 + m = m + m + IF (m.NE.n) GO TO 30 +C--------------------------------------------------------------------- +C CHECK FOR SINGULARITY +C--------------------------------------------------------------------- + IF (z.EQ.0.0D0) GO TO 100 +C--------------------------------------------------------------------- +C USE COS/SIN AS A SUBSTITUTE FOR COTAN, AND +C SIN/COS AS A SUBSTITUTE FOR TAN +C--------------------------------------------------------------------- + aug = sgn* ((cos(z)/sin(z))*4.0D0) + GO TO 40 + + 30 aug = sgn* ((sin(z)/cos(z))*4.0D0) + 40 x = 1.0D0 - x + 50 IF (x.GT.3.0D0) GO TO 70 +C--------------------------------------------------------------------- +C 0.5 .LE. X .LE. 3.0 +C--------------------------------------------------------------------- + den = x + upper = p1(1)*x +C + DO 60 i = 1,5 + den = (den+q1(i))*x + upper = (upper+p1(i+1))*x + 60 CONTINUE +C + den = (upper+p1(7))/ (den+q1(6)) + xmx0 = dble(x) - dx0 + psi1 = den*xmx0 + aug + RETURN +C--------------------------------------------------------------------- +C IF X .GE. XMAX1, PSI1 = LN(X) +C--------------------------------------------------------------------- + 70 IF (x.GE.xmax1) GO TO 90 +C--------------------------------------------------------------------- +C 3.0 .LT. X .LT. XMAX1 +C--------------------------------------------------------------------- + w = 1.0D0/ (x*x) + den = w + upper = p2(1)*w +C + DO 80 i = 1,3 + den = (den+q2(i))*w + upper = (upper+p2(i+1))*w + 80 CONTINUE +C + aug = upper/ (den+q2(4)) - 0.5D0/x + aug + 90 psi1 = aug + dlog(x) + RETURN +C--------------------------------------------------------------------- +C ERROR RETURN +C--------------------------------------------------------------------- + 100 psi1 = 0.0D0 + RETURN + + END diff --git a/modules/statistics/src/dcdflib/psi.lo b/modules/statistics/src/dcdflib/psi.lo new file mode 100755 index 000000000..17bef6137 --- /dev/null +++ b/modules/statistics/src/dcdflib/psi.lo @@ -0,0 +1,12 @@ +# src/dcdflib/psi.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/psi.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/statistics/src/dcdflib/rcomp.f b/modules/statistics/src/dcdflib/rcomp.f new file mode 100755 index 000000000..55d2c7edb --- /dev/null +++ b/modules/statistics/src/dcdflib/rcomp.f @@ -0,0 +1,43 @@ + DOUBLE PRECISION FUNCTION rcomp(a,x) +C ------------------- +C EVALUATION OF EXP(-X)*X**A/GAMMA(A) +C ------------------- +C RT2PIN = 1/SQRT(2*PI) +C ------------------- +C .. Scalar Arguments .. + DOUBLE PRECISION a,x +C .. +C .. Local Scalars .. + DOUBLE PRECISION rt2pin,t,t1,u +C .. +C .. External Functions .. + DOUBLE PRECISION gam1,gamma,rlog + EXTERNAL gam1,gamma,rlog +C .. +C .. Intrinsic Functions .. + INTRINSIC dlog,exp,sqrt +C .. +C .. Data statements .. + DATA rt2pin/.398942280401433D0/ +C .. +C .. Executable Statements .. +C ------------------- + rcomp = 0.0D0 + IF (a.GE.20.0D0) GO TO 20 + t = a*dlog(x) - x + IF (a.GE.1.0D0) GO TO 10 + rcomp = (a*exp(t))* (1.0D0+gam1(a)) + RETURN + + 10 rcomp = exp(t)/gamma(a) + RETURN +C + 20 u = x/a + IF (u.EQ.0.0D0) RETURN + t = (1.0D0/a)**2 + t1 = (((0.75D0*t-1.0D0)*t+3.5D0)*t-105.0D0)/ (a*1260.0D0) + t1 = t1 - a*rlog(u) + rcomp = rt2pin*sqrt(a)*exp(t1) + RETURN + + END diff --git a/modules/statistics/src/dcdflib/rcomp.lo b/modules/statistics/src/dcdflib/rcomp.lo new file mode 100755 index 000000000..7a29a9d1c --- /dev/null +++ b/modules/statistics/src/dcdflib/rcomp.lo @@ -0,0 +1,12 @@ +# src/dcdflib/rcomp.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/rcomp.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/statistics/src/dcdflib/rexp.f b/modules/statistics/src/dcdflib/rexp.f new file mode 100755 index 000000000..cc29c414f --- /dev/null +++ b/modules/statistics/src/dcdflib/rexp.f @@ -0,0 +1,33 @@ + DOUBLE PRECISION FUNCTION rexp(x) +C----------------------------------------------------------------------- +C EVALUATION OF THE FUNCTION EXP(X) - 1 +C----------------------------------------------------------------------- +C .. Scalar Arguments .. + DOUBLE PRECISION x +C .. +C .. Local Scalars .. + DOUBLE PRECISION p1,p2,q1,q2,q3,q4,w +C .. +C .. Intrinsic Functions .. + INTRINSIC abs,exp +C .. +C .. Data statements .. + DATA p1/.914041914819518D-09/,p2/.238082361044469D-01/, + + q1/-.499999999085958D+00/,q2/.107141568980644D+00/, + + q3/-.119041179760821D-01/,q4/.595130811860248D-03/ +C .. +C .. Executable Statements .. +C----------------------- + IF (abs(x).GT.0.15D0) GO TO 10 + rexp = x* (((p2*x+p1)*x+1.0D0)/ ((((q4*x+q3)*x+q2)*x+q1)*x+1.0D0)) + RETURN +C + 10 w = exp(x) + IF (x.GT.0.0D0) GO TO 20 + rexp = (w-0.5D0) - 0.5D0 + RETURN + + 20 rexp = w* (0.5D0+ (0.5D0-1.0D0/w)) + RETURN + + END diff --git a/modules/statistics/src/dcdflib/rexp.lo b/modules/statistics/src/dcdflib/rexp.lo new file mode 100755 index 000000000..a0fe77bdd --- /dev/null +++ b/modules/statistics/src/dcdflib/rexp.lo @@ -0,0 +1,12 @@ +# src/dcdflib/rexp.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/rexp.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/statistics/src/dcdflib/rlog.f b/modules/statistics/src/dcdflib/rlog.f new file mode 100755 index 000000000..94faa6c3e --- /dev/null +++ b/modules/statistics/src/dcdflib/rlog.f @@ -0,0 +1,55 @@ + DOUBLE PRECISION FUNCTION rlog(x) +C ------------------- +C COMPUTATION OF X - 1 - LN(X) +C ------------------- +C .. Scalar Arguments .. + DOUBLE PRECISION x +C .. +C .. Local Scalars .. + DOUBLE PRECISION a,b,p0,p1,p2,q1,q2,r,t,u,w,w1 +C .. +C .. Intrinsic Functions .. + INTRINSIC dble,dlog +C .. +C .. Data statements .. +C ------------------- + DATA a/.566749439387324D-01/ + DATA b/.456512608815524D-01/ + DATA p0/.333333333333333D+00/,p1/-.224696413112536D+00/, + + p2/.620886815375787D-02/ + DATA q1/-.127408923933623D+01/,q2/.354508718369557D+00/ +C .. +C .. Executable Statements .. +C ------------------- + IF (x.LT.0.61D0 .OR. x.GT.1.57D0) GO TO 40 + IF (x.LT.0.82D0) GO TO 10 + IF (x.GT.1.18D0) GO TO 20 +C +C ARGUMENT REDUCTION +C + u = (x-0.5D0) - 0.5D0 + w1 = 0.0D0 + GO TO 30 +C + 10 u = dble(x) - 0.7D0 + u = u/0.7D0 + w1 = a - u*0.3D0 + GO TO 30 +C + 20 u = 0.75D0*dble(x) - 1.D0 + w1 = b + u/3.0D0 +C +C SERIES EXPANSION +C + 30 r = u/ (u+2.0D0) + t = r*r + w = ((p2*t+p1)*t+p0)/ ((q2*t+q1)*t+1.0D0) + rlog = 2.0D0*t* (1.0D0/ (1.0D0-r)-r*w) + w1 + RETURN +C +C + 40 r = (x-0.5D0) - 0.5D0 + rlog = r - dlog(x) + RETURN + + END diff --git a/modules/statistics/src/dcdflib/rlog.lo b/modules/statistics/src/dcdflib/rlog.lo new file mode 100755 index 000000000..3df434c18 --- /dev/null +++ b/modules/statistics/src/dcdflib/rlog.lo @@ -0,0 +1,12 @@ +# src/dcdflib/rlog.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/rlog.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/statistics/src/dcdflib/rlog1.f b/modules/statistics/src/dcdflib/rlog1.f new file mode 100755 index 000000000..8b215eba8 --- /dev/null +++ b/modules/statistics/src/dcdflib/rlog1.f @@ -0,0 +1,55 @@ + DOUBLE PRECISION FUNCTION rlog1(x) +C----------------------------------------------------------------------- +C EVALUATION OF THE FUNCTION X - LN(1 + X) +C----------------------------------------------------------------------- +C .. Scalar Arguments .. + DOUBLE PRECISION x +C .. +C .. Local Scalars .. + DOUBLE PRECISION a,b,h,p0,p1,p2,q1,q2,r,t,w,w1 +C .. +C .. Intrinsic Functions .. + INTRINSIC dble,dlog +C .. +C .. Data statements .. +C------------------------ + DATA a/.566749439387324D-01/ + DATA b/.456512608815524D-01/ + DATA p0/.333333333333333D+00/,p1/-.224696413112536D+00/, + + p2/.620886815375787D-02/ + DATA q1/-.127408923933623D+01/,q2/.354508718369557D+00/ +C .. +C .. Executable Statements .. +C------------------------ + IF (x.LT.-0.39D0 .OR. x.GT.0.57D0) GO TO 40 + IF (x.LT.-0.18D0) GO TO 10 + IF (x.GT.0.18D0) GO TO 20 +C +C ARGUMENT REDUCTION +C + h = x + w1 = 0.0D0 + GO TO 30 +C + 10 h = dble(x) + 0.3D0 + h = h/0.7D0 + w1 = a - h*0.3D0 + GO TO 30 +C + 20 h = 0.75D0*dble(x) - 0.25D0 + w1 = b + h/3.0D0 +C +C SERIES EXPANSION +C + 30 r = h/ (h+2.0D0) + t = r*r + w = ((p2*t+p1)*t+p0)/ ((q2*t+q1)*t+1.0D0) + rlog1 = 2.0D0*t* (1.0D0/ (1.0D0-r)-r*w) + w1 + RETURN +C +C + 40 w = (x+0.5D0) + 0.5D0 + rlog1 = x - dlog(w) + RETURN + + END diff --git a/modules/statistics/src/dcdflib/rlog1.lo b/modules/statistics/src/dcdflib/rlog1.lo new file mode 100755 index 000000000..33178b74c --- /dev/null +++ b/modules/statistics/src/dcdflib/rlog1.lo @@ -0,0 +1,12 @@ +# src/dcdflib/rlog1.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/rlog1.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/statistics/src/dcdflib/spmpar.f b/modules/statistics/src/dcdflib/spmpar.f new file mode 100755 index 000000000..4f371707f --- /dev/null +++ b/modules/statistics/src/dcdflib/spmpar.f @@ -0,0 +1,29 @@ + DOUBLE PRECISION FUNCTION spmpar(i) +C----------------------------------------------------------------------- +C SPMPAR PROVIDES THE SINGLE PRECISION MACHINE CONSTANTS FOR +C THE COMPUTER BEING USED. IT IS ASSUMED THAT THE ARGUMENT +C I IS AN INTEGER HAVING ONE OF THE VALUES 1, 2, OR 3. IF THE +C SINGLE PRECISION ARITHMETIC BEING USED HAS M BASE B DIGITS AND +C ITS SMALLEST AND LARGEST EXPONENTS ARE EMIN AND EMAX, THEN +C +C SPMPAR(1) = B**(1 - M), THE MACHINE PRECISION, +C +C SPMPAR(2) = B**(EMIN - 1), THE SMALLEST MAGNITUDE, +C +C SPMPAR(3) = B**EMAX*(1 - B**(-M)), THE LARGEST MAGNITUDE. +C +C----------------------------------------------------------------------- +C RWRITTEN BY JPC to use lapack dlamch +C----------------------------------------------------------------------- + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH + goto (1,2,3) i + spmpar=0.0 + RETURN + 1 spmpar=dlamch('p') + return + 2 spmpar=dlamch('u') + return + 3 spmpar=dlamch('o') + return + END diff --git a/modules/statistics/src/dcdflib/spmpar.f.dist b/modules/statistics/src/dcdflib/spmpar.f.dist new file mode 100755 index 000000000..4cfafb1a3 --- /dev/null +++ b/modules/statistics/src/dcdflib/spmpar.f.dist @@ -0,0 +1,72 @@ + DOUBLE PRECISION FUNCTION spmpar(i) +C----------------------------------------------------------------------- +C +C SPMPAR PROVIDES THE SINGLE PRECISION MACHINE CONSTANTS FOR +C THE COMPUTER BEING USED. IT IS ASSUMED THAT THE ARGUMENT +C I IS AN INTEGER HAVING ONE OF THE VALUES 1, 2, OR 3. IF THE +C SINGLE PRECISION ARITHMETIC BEING USED HAS M BASE B DIGITS AND +C ITS SMALLEST AND LARGEST EXPONENTS ARE EMIN AND EMAX, THEN +C +C SPMPAR(1) = B**(1 - M), THE MACHINE PRECISION, +C +C SPMPAR(2) = B**(EMIN - 1), THE SMALLEST MAGNITUDE, +C +C SPMPAR(3) = B**EMAX*(1 - B**(-M)), THE LARGEST MAGNITUDE. +C +C----------------------------------------------------------------------- +C WRITTEN BY +C ALFRED H. MORRIS, JR. +C NAVAL SURFACE WARFARE CENTER +C DAHLGREN VIRGINIA +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- +C MODIFIED BY BARRY W. BROWN TO RETURN DOUBLE PRECISION MACHINE +C CONSTANTS FOR THE COMPUTER BEING USED. THIS MODIFICATION WAS +C MADE AS PART OF CONVERTING BRATIO TO DOUBLE PRECISION +C----------------------------------------------------------------------- +C .. Scalar Arguments .. + INTEGER i +C .. +C .. Local Scalars .. + DOUBLE PRECISION b,binv,bm1,one,w,z + INTEGER emax,emin,ibeta,m +C .. +C .. External Functions .. + INTEGER ipmpar + EXTERNAL ipmpar +C .. +C .. Intrinsic Functions .. + INTRINSIC dble +C .. +C .. Executable Statements .. +C + IF (i.GT.1) GO TO 10 + b = ipmpar(4) + m = ipmpar(8) + spmpar = b** (1-m) + RETURN +C + 10 IF (i.GT.2) GO TO 20 + b = ipmpar(4) + emin = ipmpar(9) + one = dble(1) + binv = one/b + w = b** (emin+2) + spmpar = ((w*binv)*binv)*binv + RETURN +C + 20 ibeta = ipmpar(4) + m = ipmpar(8) + emax = ipmpar(10) +C + b = ibeta + bm1 = ibeta - 1 + one = dble(1) + z = b** (m-1) + w = ((z-one)*b+bm1)/ (b*z) +C + z = b** (emax-2) + spmpar = ((w*z)*b)*b + RETURN + + END diff --git a/modules/statistics/src/dcdflib/spmpar.lo b/modules/statistics/src/dcdflib/spmpar.lo new file mode 100755 index 000000000..f6c176baf --- /dev/null +++ b/modules/statistics/src/dcdflib/spmpar.lo @@ -0,0 +1,12 @@ +# src/dcdflib/spmpar.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/spmpar.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/statistics/src/dcdflib/stvaln.f b/modules/statistics/src/dcdflib/stvaln.f new file mode 100755 index 000000000..51d1526ca --- /dev/null +++ b/modules/statistics/src/dcdflib/stvaln.f @@ -0,0 +1,67 @@ + DOUBLE PRECISION FUNCTION stvaln(p) +C +C********************************************************************** +C +C DOUBLE PRECISION FUNCTION STVALN(P) +C STarting VALue for Neton-Raphon +C calculation of Normal distribution Inverse +C +C +C Function +C +C +C Returns X such that CUMNOR(X) = P, i.e., the integral from - +C infinity to X of (1/SQRT(2*PI)) EXP(-U*U/2) dU is P +C +C +C Arguments +C +C +C P --> The probability whose normal deviate is sought. +C P is DOUBLE PRECISION +C +C +C Method +C +C +C The rational function on page 95 of Kennedy and Gentle, +C Statistical Computing, Marcel Dekker, NY , 1980. +C +C********************************************************************** +C +C .. Scalar Arguments .. + DOUBLE PRECISION p +C .. +C .. Local Scalars .. + DOUBLE PRECISION sign,y,z +C .. +C .. Local Arrays .. + DOUBLE PRECISION xden(5),xnum(5) +C .. +C .. External Functions .. + DOUBLE PRECISION devlpl + EXTERNAL devlpl +C .. +C .. Intrinsic Functions .. + INTRINSIC dble,log,sqrt +C .. +C .. Data statements .. + DATA xnum/-0.322232431088D0,-1.000000000000D0,-0.342242088547D0, + + -0.204231210245D-1,-0.453642210148D-4/ + DATA xden/0.993484626060D-1,0.588581570495D0,0.531103462366D0, + + 0.103537752850D0,0.38560700634D-2/ +C .. +C .. Executable Statements .. + IF (.NOT. (p.LE.0.5D0)) GO TO 10 + sign = -1.0D0 + z = p + GO TO 20 + + 10 sign = 1.0D0 + z = 1.0D0 - p + 20 y = sqrt(-2.0D0*log(z)) + stvaln = y + devlpl(xnum,5,y)/devlpl(xden,5,y) + stvaln = sign*stvaln + RETURN + + END diff --git a/modules/statistics/src/dcdflib/stvaln.lo b/modules/statistics/src/dcdflib/stvaln.lo new file mode 100755 index 000000000..4927f6dfe --- /dev/null +++ b/modules/statistics/src/dcdflib/stvaln.lo @@ -0,0 +1,12 @@ +# src/dcdflib/stvaln.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/stvaln.o' + +# Name of the non-PIC object +non_pic_object=none + |