SUBROUTINE AAD(X,N,IWRITE,XTEMP,MAXNXT,XAAD,IBUGA3,IERROR) C C PURPOSE--THIS SUBROUTINE COMPUTES THE C SAMPLE AVERAGE ABSOLUTE DEVIATION (WITH DENOMINATOR N) C OF THE DATA IN THE INPUT VECTOR X. C THE SAMPLE AVERAGE ABSOLUTE DEVIATION = (THE SUM OF THE C ABSOLUTE DEVIATIONS ABOUT THE SAMPLE MEDIAN) / N). C INPUT ARGUMENTS--X = THE SINGLE PRECISION VECTOR OF C (UNSORTED OR SORTED) OBSERVATIONS. C --N = THE INTEGER NUMBER OF OBSERVATIONS C IN THE VECTOR X. C OUTPUT ARGUMENTS--XAAD = THE SINGLE PRECISION VALUE OF THE C COMPUTED SAMPLE AVERAGE ABSOLUTE DEVIATION. C OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE C SAMPLE AVERAGE ABSOLUTE DEVIATION (WITH DENOMINATOR N-1). C OTHER DATAPAC SUBROUTINES NEEDED--MEDIAN AND SORT. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--SNEDECOR AND COCHRAN, STATISTICAL METHODS, C EDITION 6, 1967, PAGE 44. C --DIXON AND MASSEY, INTRODUCTION TO STATISTICAL C ANALYSIS, EDITION 2, 1957, PAGES 19, 76. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-921-3651 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--82/7 C ORIGINAL VERSION--JULY 1981. C UPDATED --AUGUST 1981. C UPDATED --MAY 1982. C UPDATED --JANUARY 1989. FIX COMPUTATIONAL BUG (ALAN) C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IWRITE CHARACTER*4 IBUGA3 CHARACTER*4 IERROR C CHARACTER*4 IWRIT2 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C DOUBLE PRECISION DN DOUBLE PRECISION DX DOUBLE PRECISION DDEL DOUBLE PRECISION DSUM DOUBLE PRECISION DMED C DIMENSION X(*) DIMENSION XTEMP(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='AAD ' ISUBN2=' ' C IERROR='NO' C DMED=0.0D0 DDEL=0.0D0 C IF(IBUGA3.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF AAD--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA3 52 FORMAT('IBUGA3 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)N 53 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') DO55I=1,N WRITE(ICOUT,56)I,X(I) 56 FORMAT('I,X(I) = ',I8,E15.7) CALL DPWRST('XXX','BUG ') 55 CONTINUE 90 CONTINUE C C ****************************************** C ** COMPUTE AVERAGE ABSOLUTE DEVIATION ** C ****************************************** C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C AN=N C IF(N.GE.1)GOTO119 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,111) 111 FORMAT('***** ERROR IN AAD--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,112) 112 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,113) 113 FORMAT(' IN THE VARIABLE FOR WHICH') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,114) 114 FORMAT(' THE AVERAGE ABSOLUTE DEVIATION IS TO BE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,115) 115 FORMAT(' COMPUTED, MUST BE 1 OR LARGER.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,116) 116 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,117)N 117 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8, 1'.') CALL DPWRST('XXX','BUG ') GOTO9000 119 CONTINUE C IF(N.EQ.1)GOTO120 GOTO129 120 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,121) 121 FORMAT('***** NON-FATAL DIAGNOSTIC IN AAD--', 1'THE SECOND INPUT ARGUMENT (N) HAS THE VALUE 1') CALL DPWRST('XXX','BUG ') XAAD=0.0 GOTO9000 129 CONTINUE C HOLD=X(1) DO135I=2,N IF(X(I).NE.HOLD)GOTO139 135 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,136)HOLD 136 FORMAT('***** NON-FATAL DIAGNOSTIC IN AAD--', 1'THE FIRST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7) CALL DPWRST('XXX','BUG ') XAAD=0.0 GOTO9000 139 CONTINUE C 190 CONTINUE C C *********************************************** C ** STEP 2-- ** C ** COMPUTE THE AVERAGE ABSOLUTE DEVIATION. ** C *************************************** C IWRIT2='OFF' CALL MEDIAN(X,N,IWRIT2,XTEMP,MAXNXT,XMED,IBUGA3,IERROR) DMED=XMED C DN=N DSUM=0.0D0 DO300I=1,N DX=X(I) DDEL=DX-DMED IF(DDEL.LT.0.0D0)DDEL=-DDEL DSUM=DSUM+DDEL 300 CONTINUE C BUG FIX: AUGUST, 1987 CCCCC XAAD=DDEL/DN XAAD=DSUM/DN C END BUG FIX C C ******************************* C ** STEP 3-- ** C ** WRITE OUT A LINE ** C ** OF SUMMARY INFORMATION. ** C ******************************* C IF(IFEEDB.EQ.'OFF')GOTO890 IF(IWRITE.EQ.'OFF')GOTO890 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,811)N,XAAD 811 FORMAT('THE AVERAGE ABSOLUTE DEVIATION OF THE ',I8, 1' OBSERVATIONS = ',E15.7) CALL DPWRST('XXX','BUG ') 890 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C 9000 CONTINUE IF(IBUGA3.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF AAD--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGA3,IERROR 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)N 9013 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)DMED 9014 FORMAT('DMED = ',D15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)XAAD 9015 FORMAT('XAAD = ',E15.7) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END DOUBLE PRECISION FUNCTION ABRAM0(XVALUE) C C DESCRIPTION: C This function calculates the Abramowitz function of order 0, C defined as C C ABRAM0(x) = integral{ 0 to infinity } exp( -t*t - x/t ) dt C C The code uses Chebyshev expansions with the coefficients C given to an accuracy of 20 decimal places. C C C ERROR RETURNS: C If XVALUE < 0.0, the function prints a message and returns the C value 0.0. C C C MACHINE-DEPENDENT CONSTANTS: C C NTERMF - INTEGER - No. of terms needed for the array AB0F. C Recommended value such that C ABS( AB0F(NTERMF) ) < EPS/100 C C NTERMG - INTEGER - No. of terms needed for array AB0G. C Recommended value such that C ABS( AB0G(NTERMG) ) < EPS/100 C C NTERMH - INTEGER - No. of terms needed for array AB0H. C Recommended value such that C ABS( AB0H(NTERMH) ) < EPS/100 C C NTERMA - INTEGER - No. of terms needed for array AB0AS. C Recommended value such that C ABS( AB0AS(NTERMA) ) < EPS/100 C C XLOW1 - DOUBLE PRECISION - The value below which C ABRAM0 = root(pi)/2 + X ( ln X - GVAL0 ) C Recommended value is SQRT(2*EPSNEG) C C LNXMIN - DOUBLE PRECISION - The value of ln XMIN. Used to prevent C exponential underflow for large X. C C For values of EPS, EPSNEG, XMIN refer to the file MACHCON.TXT. C C The machine-dependent constants are computed internally by C using the D1MACH subroutine. C C C INTRINSIC FUNCTIONS USED: C C LOG, EXP, SQRT C C C OTHER MISCFUN SUBROUTINES USED: C C CHEVAL , ERRPRN, D1MACH C C C AUTHOR: C C DR. ALLAN J. MACLEOD, C DEPT. OF MATHEMATICS AND STATISTICS, C UNIVERSITY OF PAISLEY , C HIGH ST., C PAISLEY, C SCOTLAND. C PA1 2BE C C ( e-mail: macl_ms0@paisley.ac.uk ) C C C LATEST REVISION: 23 January C C INTEGER NTERMA,NTERMF,NTERMG,NTERMH DOUBLE PRECISION AB0F(0:8),AB0G(0:8),AB0H(0:8),AB0AS(0:27), & ASLN,ASVAL,CHEVAL,FVAL,GVAL,GVAL0,HALF,HVAL, & LNXMIN,ONEHUN,ONERPI,RTPIB2,RT3BPI,SIX,T, & THREE,TWO,V,X,XLOW1,XVALUE,ZERO CCCCC CHARACTER FNNAME*6,ERRMSG*33 C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOMC.INC' CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C CCCCC DATA FNNAME/'ABRAM0'/ CCCCC DATA ERRMSG/'FUNCTION CALLED WITH ARGUMENT < 0'/ DATA AB0F/-0.68121 92709 35494 69816 D 0, 1 -0.78867 91981 61492 52495 D 0, 2 0.51215 81776 81881 9543 D -1, 3 -0.71092 35289 45412 96 D -3, 4 0.36868 18085 04287 D -5, 5 -0.91783 23372 37 D -8, 6 0.12702 02563 D -10, 7 -0.10768 88 D -13, 8 0.599 D -17/ DATA AB0G/-0.60506 03943 08682 73190 D 0, 1 -0.41950 39816 32017 79803 D 0, 2 0.17032 65125 19037 0333 D -1, 3 -0.16938 91784 24913 97 D -3, 4 0.67638 08951 9710 D -6, 5 -0.13572 36362 55 D -8, 6 0.15629 7065 D -11, 7 -0.11288 7 D -14, 8 0.55 D -18/ DATA AB0H/1.38202 65523 05749 89705 D 0, 1 -0.30097 92907 39749 04355 D 0, 2 0.79428 88093 64887 241 D -2, 3 -0.64319 10276 84756 3 D -4, 4 0.22549 83068 4374 D -6, 5 -0.41220 96619 5 D -9, 6 0.44185 282 D -12, 7 -0.30123 D -15, 8 0.14 D -18/ DATA AB0AS(0)/ 1.97755 49972 36930 67407 D 0/ DATA AB0AS(1)/ -0.10460 24792 00481 9485 D -1/ DATA AB0AS(2)/ 0.69680 79025 36253 66 D -3/ DATA AB0AS(3)/ -0.58982 98299 99659 9 D -4/ DATA AB0AS(4)/ 0.57716 44553 05320 D -5/ DATA AB0AS(5)/ -0.61523 01336 5756 D -6/ DATA AB0AS(6)/ 0.67853 96884 767 D -7/ DATA AB0AS(7)/ -0.72306 25379 07 D -8/ DATA AB0AS(8)/ 0.63306 62736 5 D -9/ DATA AB0AS(9)/ -0.98945 3793 D -11/ DATA AB0AS(10)/-0.16819 80530 D -10/ DATA AB0AS(11)/ 0.67379 9551 D -11/ DATA AB0AS(12)/-0.20099 7939 D -11/ DATA AB0AS(13)/ 0.54055 903 D -12/ DATA AB0AS(14)/-0.13816 679 D -12/ DATA AB0AS(15)/ 0.34222 05 D -13/ DATA AB0AS(16)/-0.82668 6 D -14/ DATA AB0AS(17)/ 0.19456 6 D -14/ DATA AB0AS(18)/-0.44268 D -15/ DATA AB0AS(19)/ 0.9562 D -16/ DATA AB0AS(20)/-0.1883 D -16/ DATA AB0AS(21)/ 0.301 D -17/ DATA AB0AS(22)/-0.19 D -18/ DATA AB0AS(23)/-0.14 D -18/ DATA AB0AS(24)/ 0.11 D -18/ DATA AB0AS(25)/-0.4 D -19/ DATA AB0AS(26)/ 0.2 D -19/ DATA AB0AS(27)/-0.1 D -19/ DATA ZERO,HALF,TWO/ 0.0 D 0 , 0.5 D 0, 2.0 D 0/ DATA THREE,SIX,ONEHUN/ 3.0 D 0, 6.0 D 0 , 100.0 D 0/ DATA RT3BPI/0.97720 50238 05839 84317 D 0/ DATA RTPIB2/0.88622 69254 52758 01365 D 0/ DATA GVAL0/0.13417 65026 47700 70909 D 0/ DATA ONERPI/0.56418 95835 47756 28695 D 0/ C C Start computation C X = XVALUE C C Error test C IF ( X .LT. ZERO ) THEN CCCCC CALL ERRPRN(FNNAME,ERRMSG) WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,101)X CALL DPWRST('XXX','BUG ') ABRAM0 = ZERO RETURN ENDIF 999 FORMAT(1X) 101 FORMAT('***** ERROR FROM ABRAM0--ARGUMENT MUST BE ', 1 'NON-NEGATIVE, ARGUMENT = ',G15.7) C C Compute the machine-dependent constants. C T = D1MACH(4) / ONEHUN IF ( X .LE. TWO ) THEN DO 10 NTERMF = 8 , 0 , -1 IF ( ABS(AB0F(NTERMF)) .GT. T ) GOTO 19 10 CONTINUE 19 DO 20 NTERMG = 8 , 0 , -1 IF ( ABS(AB0G(NTERMG)) .GT. T ) GOTO 29 20 CONTINUE 29 DO 30 NTERMH = 8 , 0 , -1 IF ( ABS(AB0H(NTERMH)) .GT. T ) GOTO 39 30 CONTINUE 39 XLOW1 = SQRT ( TWO * D1MACH(3) ) ELSE DO 40 NTERMA = 27 , 0 , -1 IF ( ABS(AB0AS(NTERMA)) .GT. T ) GOTO 49 40 CONTINUE 49 LNXMIN = LOG(D1MACH(1)) ENDIF C C Code for 0 <= XVALUE <= 2 C IF ( X .LE. TWO ) THEN IF ( X .EQ. ZERO ) THEN ABRAM0 = RTPIB2 RETURN ENDIF IF ( X .LT. XLOW1 ) THEN ABRAM0 = RTPIB2 + X * ( LOG( X ) - GVAL0 ) RETURN ELSE T = ( X * X / TWO - HALF ) - HALF FVAL = CHEVAL( NTERMF,AB0F,T ) GVAL = CHEVAL( NTERMG,AB0G,T ) HVAL = CHEVAL( NTERMH,AB0H,T ) ABRAM0 = FVAL/ONERPI + X * ( LOG( X ) * HVAL- GVAL ) RETURN ENDIF ELSE C C Code for XVALUE > 2 C V = THREE * ( (X / TWO) ** ( TWO / THREE ) ) T = ( SIX/V - HALF ) - HALF ASVAL = CHEVAL( NTERMA,AB0AS,T ) ASLN = LOG( ASVAL / RT3BPI ) - V IF ( ASLN .LT. LNXMIN ) THEN ABRAM0 = ZERO ELSE ABRAM0 = EXP( ASLN ) ENDIF RETURN ENDIF END DOUBLE PRECISION FUNCTION ABRAM1(XVALUE) C C DESCRIPTION: C This function calculates the Abramowitz function of order 1, C defined as C C ABRAM1(x) = integral{ 0 to infinity } t * exp( -t*t - x/t ) dt C C The code uses Chebyshev expansions with the coefficients C given to an accuracy of 20 decimal places. C C C ERROR RETURNS: C If XVALUE < 0.0, the function prints a message and returns the C value 0.0. C C C MACHINE-DEPENDENT CONSTANTS: C C NTERMF - INTEGER - No. of terms needed for the array AB1F. C Recommended value such that C ABS( AB1F(NTERMF) ) < EPS/100 C C NTERMG - INTEGER - No. of terms needed for array AB1G. C Recommended value such that C ABS( AB1G(NTERMG) ) < EPS/100 C C NTERMH - INTEGER - No. of terms needed for array AB1H. C Recommended value such that C ABS( AB1H(NTERMH) ) < EPS/100 C C NTERMA - INTEGER - No. of terms needed for array AB1AS. C Recommended value such that C ABS( AB1AS(NTERMA) ) < EPS/100 C C XLOW - DOUBLE PRECISION - The value below which C ABRAM1(x) = 0.5 to machine precision. C The recommended value is EPSNEG/2 C C XLOW1 - DOUBLE PRECISION - The value below which C ABRAM1(x) = (1 - x ( sqrt(pi) + xln(x) ) / 2 C Recommended value is SQRT(2*EPSNEG) C C LNXMIN - DOUBLE PRECISION - The value of ln XMIN. Used to prevent C exponential underflow for large X. C C For values of EPS, EPSNEG, XMIN refer to the file MACHCON.TXT C C The machine-dependent constants are computed internally by using C the D1MACH subroutine. C C C INTRINSIC FUNCTIONS USED: C C LOG, EXP, SQRT C C C OTHER MISCFUN SUBROUTINES USED: C C CHEVAL , ERRPRN, D1MACH C C C AUTHOR: C C DR. ALLAN J. MACLEOD, C DEPT. OF MATHEMATICS AND STATISTICS, C UNIVERSITY OF PAISLEY, C HIGH ST., C PAISLEY, C SCOTLAND. C PA1 2BE C C ( e-mail: macl_ms0@paisley.ac.uk ) C C C LATEST REVISION: 23 January, 1996 C C INTEGER NTERMA,NTERMF,NTERMG,NTERMH DOUBLE PRECISION AB1F(0:9),AB1G(0:8),AB1H(0:8),AB1AS(0:27), & ASLN,ASVAL,CHEVAL,FVAL,GVAL,HALF,HVAL, & LNXMIN,ONE,ONEHUN,ONERPI,RT3BPI,SIX,T,THREE,TWO, & V,X,XLOW,XLOW1,XVALUE,ZERO CCCCC CHARACTER FNNAME*6,ERRMSG*33 C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOMC.INC' CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C CCCCC DATA FNNAME/'ABRAM1'/ CCCCC DATA ERRMSG/'FUNCTION CALLED WITH ARGUMENT < 0'/ DATA AB1F/1.47285 19257 79788 07369 D 0, 1 0.10903 49757 01689 56257 D 0, 2 -0.12430 67536 00565 69753 D 0, 3 0.30619 79468 53493 315 D -2, 4 -0.22184 10323 07651 1 D -4, 5 0.69899 78834 451 D -7, 6 -0.11597 07644 4 D -9, 7 0.11389 776 D -12, 8 -0.7173 D -16, 9 0.3 D -19/ DATA AB1G/0.39791 27794 90545 03528 D 0, 1 -0.29045 28522 64547 20849 D 0, 2 0.10487 84695 46536 3504 D -1, 3 -0.10249 86952 26913 36 D -3, 4 0.41150 27939 9110 D -6, 5 -0.83652 63894 0 D -9, 6 0.97862 595 D -12, 7 -0.71868 D -15, 8 0.35 D -18/ DATA AB1H/0.84150 29215 22749 47030 D 0, 1 -0.77900 50698 77414 3395 D -1, 2 0.13399 24558 78390 993 D -2, 3 -0.80850 39071 52788 D -5, 4 0.22618 58281 728 D -7, 5 -0.34413 95838 D -10, 6 0.31598 58 D -13, 7 -0.1884 D -16, 8 0.1 D -19/ DATA AB1AS(0)/ 2.13013 64342 90655 49448 D 0/ DATA AB1AS(1)/ 0.63715 26795 21853 9933 D -1/ DATA AB1AS(2)/ -0.12933 49174 77510 647 D -2/ DATA AB1AS(3)/ 0.56783 28753 22826 5 D -4/ DATA AB1AS(4)/ -0.27943 49391 77646 D -5/ DATA AB1AS(5)/ 0.56002 14736 787 D -7/ DATA AB1AS(6)/ 0.23920 09242 798 D -7/ DATA AB1AS(7)/ -0.75098 48650 09 D -8/ DATA AB1AS(8)/ 0.17301 53307 76 D -8/ DATA AB1AS(9)/ -0.36648 87795 5 D -9/ DATA AB1AS(10)/ 0.75207 58307 D -10/ DATA AB1AS(11)/-0.15179 90208 D -10/ DATA AB1AS(12)/ 0.30171 3710 D -11/ DATA AB1AS(13)/-0.58596 718 D -12/ DATA AB1AS(14)/ 0.10914 455 D -12/ DATA AB1AS(15)/-0.18705 36 D -13/ DATA AB1AS(16)/ 0.26254 2 D -14/ DATA AB1AS(17)/-0.14627 D -15/ DATA AB1AS(18)/-0.9500 D -16/ DATA AB1AS(19)/ 0.5873 D -16/ DATA AB1AS(20)/-0.2420 D -16/ DATA AB1AS(21)/ 0.868 D -17/ DATA AB1AS(22)/-0.290 D -17/ DATA AB1AS(23)/ 0.93 D -18/ DATA AB1AS(24)/-0.29 D -18/ DATA AB1AS(25)/ 0.9 D -19/ DATA AB1AS(26)/-0.3 D -19/ DATA AB1AS(27)/ 0.1 D -19/ DATA ZERO,HALF,ONE/ 0.0 D 0, 0.5 D 0, 1.0 D 0/ DATA TWO,THREE,SIX/ 2.0 D 0, 3.0 D 0, 6.0 D 0/ DATA ONEHUN/100.0 D 0/ DATA RT3BPI/ 0.97720 50238 05839 84317 D 0/ DATA ONERPI/ 0.56418 95835 47756 28695 D 0/ C C Start calculation C X = XVALUE C C Error test C IF ( X .LT. ZERO ) THEN CCCCC CALL ERRPRN(FNNAME,ERRMSG) WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,101)X CALL DPWRST('XXX','BUG ') ABRAM1 = ZERO RETURN ENDIF 999 FORMAT(1X) 101 FORMAT('***** ERROR FROM ABRAM1--ARGUMENT MUST BE ', 1 'NON-NEGATIVE, ARGUMENT = ',G15.7) C C Compute the machine-dependent constants. C T = D1MACH(4) / ONEHUN IF ( X .LE. TWO ) THEN DO 10 NTERMF = 9 , 0 , -1 IF ( ABS(AB1F(NTERMF)) .GT. T ) GOTO 19 10 CONTINUE 19 DO 20 NTERMG = 8 , 0 , -1 IF ( ABS(AB1G(NTERMG)) .GT. T ) GOTO 29 20 CONTINUE 29 DO 30 NTERMH = 8 , 0 , -1 IF ( ABS(AB1H(NTERMH)) .GT. T ) GOTO 39 30 CONTINUE 39 T = D1MACH(3) XLOW1 = SQRT ( TWO * T ) XLOW = T / TWO ELSE DO 40 NTERMA = 27 , 0 , -1 IF ( ABS(AB1AS(NTERMA)) .GT. T ) GOTO 49 40 CONTINUE 49 LNXMIN = LOG(D1MACH(1)) ENDIF C C Code for 0 <= XVALUE <= 2 C IF ( X .LE. TWO ) THEN IF ( X .EQ. ZERO ) THEN ABRAM1 = HALF RETURN ENDIF IF ( X .LT. XLOW1 ) THEN IF ( X .LT. XLOW ) THEN ABRAM1 = HALF ELSE ABRAM1 = ( ONE - X / ONERPI - X * X * LOG( X ) ) * HALF ENDIF RETURN ELSE T = ( X * X / TWO - HALF ) - HALF FVAL = CHEVAL( NTERMF,AB1F,T ) GVAL = CHEVAL( NTERMG,AB1G,T ) HVAL = CHEVAL( NTERMH,AB1H,T ) ABRAM1 = FVAL - X * ( GVAL / ONERPI + X * LOG( X ) * HVAL ) RETURN ENDIF ELSE C C Code for XVALUE > 2 C V = THREE * ( (X / TWO) ** ( TWO / THREE ) ) T = ( SIX / V - HALF ) - HALF ASVAL = CHEVAL( NTERMA,AB1AS,T ) ASLN = LOG( ASVAL * SQRT ( V / THREE ) / RT3BPI ) - V IF ( ASLN .LT. LNXMIN ) THEN ABRAM1 = ZERO ELSE ABRAM1 = EXP( ASLN ) ENDIF RETURN ENDIF END DOUBLE PRECISION FUNCTION ABRAM2(XVALUE) C C DESCRIPTION: C This function calculates the Abramowitz function of order 2, C defined as C C ABRAM2(x) = integral{ 0 to infinity } (t**2) * exp( -t*t - x/t ) dt C C The code uses Chebyshev expansions with the coefficients C given to an accuracy of 20 decimal places. C C C ERROR RETURNS: C If XVALUE < 0.0, the function prints a message and returns the C value 0.0. C C C MACHINE-DEPENDENT CONSTANTS: C C NTERMF - INTEGER - No. of terms needed for the array AB2F. C Recommended value such that C ABS( AB2F(NTERMF) ) < EPS/100 C C NTERMG - INTEGER - No. of terms needed for array AB2G. C Recommended value such that C ABS( AB2G(NTERMG) ) < EPS/100 C C NTERMH - INTEGER - No. of terms needed for array AB2H. C Recommended value such that C ABS( AB2H(NTERMH) ) < EPS/100 C C NTERMA - INTEGER - No. of terms needed for array AB2AS. C Recommended value such that C ABS( AB2AS(NTERMA) ) < EPS/100 C C XLOW - DOUBLE PRECISION - The value below which C ABRAM2 = root(pi)/4 to machine precision. C The recommended value is EPSNEG C C XLOW1 - DOUBLE PRECISION - The value below which C ABRAM2 = root(pi)/4 - x/2 + x**3ln(x)/6 C Recommended value is SQRT(2*EPSNEG) C C LNXMIN - DOUBLE PRECISION - The value of ln XMIN. Used to prevent C exponential underflow for large X. C C For values of EPS, EPSNEG, XMIN refer to the file MACHCON.TXT C C The machine-dependent constants are computed internally by C using the D1MACH subroutine. C C C INTRINSIC FUNCTIONS USED: C C LOG, EXP C C C OTHER MISCFUN SUBROUTINES USED: C C CHEVAL , ERRPRN, D1MACH C C C AUTHOR: C C DR. ALLAN J. MACLEOD, C DEPT. OF MATHEMATICS AND STATISTICS, C UNIVERSITY OF PAISLEY, C HIGH ST., C PAISLEY, C SCOTLAND. C PA1 2BE C C ( e-mail: macl_ms0@paisley.ac.uk ) C C C LATEST REVISION: 23 January, 1996 C C INTEGER NTERMA,NTERMF,NTERMG,NTERMH DOUBLE PRECISION AB2F(0:9),AB2G(0:8),AB2H(0:7),AB2AS(0:26), & ASLN,ASVAL,CHEVAL,FVAL,GVAL,HALF,HVAL,LNXMIN, & ONEHUN,ONERPI,RTPIB4,RT3BPI,SIX,T,THREE,TWO, & V,X,XLOW,XLOW1,XVALUE,ZERO CCCCC CHARACTER FNNAME*6,ERRMSG*33 C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOMC.INC' CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C CCCCC DATA FNNAME/'ABRAM2'/ CCCCC DATA ERRMSG/'FUNCTION CALLED WITH ARGUMENT < 0'/ DATA AB2F/1.03612 16280 42437 13846 D 0, 1 0.19371 24662 67945 70012 D 0, 2 -0.72587 58839 23300 7378 D -1, 3 0.17479 05908 64327 399 D -2, 4 -0.12812 23233 75654 9 D -4, 5 0.41150 18153 651 D -7, 6 -0.69710 47256 D -10, 7 0.69901 83 D -13, 8 -0.4492 D -16, 9 0.2 D -19/ DATA AB2G/1.46290 15719 86307 41150 D 0, 1 0.20189 46688 31540 14317 D 0, 2 -0.29082 92087 99712 9022 D -1, 3 0.47061 04903 52700 50 D -3, 4 -0.25792 20803 59333 D -5, 5 0.65613 37129 46 D -8, 6 -0.91411 0203 D -11, 7 0.77427 6 D -14, 8 -0.429 D -17/ DATA AB2H/0.30117 22501 09104 88881 D 0, 1 -0.15886 67818 31762 3783 D -1, 2 0.19295 93693 55845 26 D -3, 3 -0.90199 58784 9300 D -6, 4 0.20610 50418 37 D -8, 5 -0.26511 1806 D -11, 6 0.21086 4 D -14, 7 -0.111 D -17/ DATA AB2AS(0)/ 2.46492 32530 43348 56893 D 0/ DATA AB2AS(1)/ 0.23142 79742 22489 05432 D 0/ DATA AB2AS(2)/ -0.94068 17301 00857 73 D -3/ DATA AB2AS(3)/ 0.82902 70038 08973 3 D -4/ DATA AB2AS(4)/ -0.88389 47042 45866 D -5/ DATA AB2AS(5)/ 0.10663 85435 67985 D -5/ DATA AB2AS(6)/ -0.13991 12853 8529 D -6/ DATA AB2AS(7)/ 0.19397 93208 445 D -7/ DATA AB2AS(8)/ -0.27704 99383 75 D -8/ DATA AB2AS(9)/ 0.39590 68718 6 D -9/ DATA AB2AS(10)/-0.54083 54342 D -10/ DATA AB2AS(11)/ 0.63554 6076 D -11/ DATA AB2AS(12)/-0.38461 613 D -12/ DATA AB2AS(13)/-0.11696 067 D -12/ DATA AB2AS(14)/ 0.68966 71 D -13/ DATA AB2AS(15)/-0.25031 13 D -13/ DATA AB2AS(16)/ 0.78558 6 D -14/ DATA AB2AS(17)/-0.23033 4 D -14/ DATA AB2AS(18)/ 0.64914 D -15/ DATA AB2AS(19)/-0.17797 D -15/ DATA AB2AS(20)/ 0.4766 D -16/ DATA AB2AS(21)/-0.1246 D -16/ DATA AB2AS(22)/ 0.316 D -17/ DATA AB2AS(23)/-0.77 D -18/ DATA AB2AS(24)/ 0.18 D -18/ DATA AB2AS(25)/-0.4 D -19/ DATA AB2AS(26)/ 0.1 D -19/ DATA ZERO,HALF,TWO/ 0.0 D 0 , 0.5 D 0, 2.0 D 0/ DATA THREE,SIX,ONEHUN/ 3.0 D 0, 6.0 D 0 , 100.0 D 0/ DATA RT3BPI/ 0.97720 50238 05839 84317 D 0/ DATA RTPIB4/ 0.44311 34627 26379 00682 D 0/ DATA ONERPI/ 0.56418 95835 47756 28695 D 0/ C C Start calculation C X = XVALUE C C Error test C IF ( X .LT. ZERO ) THEN CCCCC CALL ERRPRN(FNNAME,ERRMSG) WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,101)X CALL DPWRST('XXX','BUG ') ABRAM2 = ZERO RETURN ENDIF 999 FORMAT(1X) 101 FORMAT('***** ERROR FROM ABRAM2--ARGUMENT MUST BE ', 1 'NON-NEGATIVE, ARGUMENT = ',G15.7) C C Compute the machine-dependent constants. C T = D1MACH(4) / ONEHUN IF ( X .LE. TWO ) THEN DO 10 NTERMF = 9 , 0 , -1 IF ( ABS(AB2F(NTERMF)) .GT. T ) GOTO 19 10 CONTINUE 19 DO 20 NTERMG = 8 , 0 , -1 IF ( ABS(AB2G(NTERMG)) .GT. T ) GOTO 29 20 CONTINUE 29 DO 30 NTERMH = 7 , 0 , -1 IF ( ABS(AB2H(NTERMH)) .GT. T ) GOTO 39 30 CONTINUE 39 XLOW = D1MACH(3) XLOW1 = SQRT ( TWO * XLOW ) ELSE DO 40 NTERMA = 26 , 0 , -1 IF ( ABS(AB2AS(NTERMA)) .GT. T ) GOTO 49 40 CONTINUE 49 LNXMIN = LOG(D1MACH(1)) ENDIF C C Code for 0 <= XVALUE <= 2 C IF ( X .LE. TWO ) THEN IF ( X .EQ. ZERO ) THEN ABRAM2 = RTPIB4 RETURN ENDIF IF ( X .LT. XLOW1 ) THEN IF ( X .LT. XLOW ) THEN ABRAM2 = RTPIB4 ELSE ABRAM2 = RTPIB4 - HALF * X + X * X * X * LOG( X ) / SIX ENDIF RETURN ELSE T = ( X * X / TWO - HALF ) - HALF FVAL = CHEVAL( NTERMF,AB2F,T ) GVAL = CHEVAL( NTERMG,AB2G,T ) HVAL = CHEVAL( NTERMH,AB2H,T ) ABRAM2 = FVAL/ONERPI + X * ( X * X * LOG(X) * HVAL- GVAL ) RETURN ENDIF ELSE C C Code for XVALUE > 2 C V = THREE * ( (X / TWO) ** ( TWO / THREE ) ) T = ( SIX / V - HALF ) - HALF ASVAL = CHEVAL( NTERMA,AB2AS,T ) ASLN = LOG( ASVAL / RT3BPI ) + LOG( V / THREE ) - V IF ( ASLN .LT. LNXMIN ) THEN ABRAM2 = ZERO ELSE ABRAM2 = EXP( ASLN ) ENDIF RETURN ENDIF END SUBROUTINE ADAPT(NDIM, MINCLS, MAXCLS, FUNCTN, & ABSREQ, RELREQ, LENWRK, WORK, ABSEST, FINEST, INFORM) * * Adaptive Multidimensional Integration Subroutine * * Author: Alan Genz * Department of Mathematics * Washington State University * Pullman, WA 99164-3113 USA * * This subroutine computes an approximation to the integral * * 1 1 1 * I I ... I FUNCTN(NDIM,X) dx(NDIM)...dx(2)dx(1) * 0 0 0 * *************** Parameters for ADAPT ******************************** * ****** Input Parameters * * NDIM Integer number of integration variables. * MINCLS Integer minimum number of FUNCTN calls to be allowed; MINCLS * must not exceed MAXCLS. If MINCLS < 0, then ADAPT assumes * that a previous call of ADAPT has been made with the same * integrand and continues that calculation. * MAXCLS Integer maximum number of FUNCTN calls to be used; MAXCLS * must be >= RULCLS, the number of function calls required for * one application of the basic integration rule. * IF ( NDIM .EQ. 1 ) THEN * RULCLS = 11 * ELSE IF ( NDIM .LT. 15 ) THEN * RULCLS = 2**NDIM + 2*NDIM*(NDIM+3) + 1 * ELSE * RULCLS = 1 + NDIM*(24-NDIM*(6-NDIM*4))/3 * ENDIF * FUNCTN Externally declared real user defined integrand. Its * parameters must be (NDIM, Z), where Z is a real array of * length NDIM. * ABSREQ Real required absolute accuracy. * RELREQ Real required relative accuracy. * LENWRK Integer length of real array WORK (working storage); ADAPT * needs LENWRK >= 16*NDIM + 27. For maximum efficiency LENWRK * should be about 2*NDIM*MAXCLS/RULCLS if MAXCLS FUNCTN * calls are needed. If LENWRK is significantly less than this, * ADAPT may be less efficient. * ****** Output Parameters * * MINCLS Actual number of FUNCTN calls used by ADAPT. * WORK Real array (length LENWRK) of working storage. This contains * information that is needed for additional calls of ADAPT * using the same integrand (input MINCLS < 0). * ABSEST Real estimated absolute accuracy. * FINEST Real estimated value of integral. * INFORM INFORM = 0 for normal exit, when ABSEST <= ABSREQ or * ABSEST <= |FINEST|*RELREQ with MINCLS <= MAXCLS. * INFORM = 1 if MAXCLS was too small for ADAPT to obtain the * result FINEST to within the requested accuracy. * INFORM = 2 if MINCLS > MAXCLS, LENWRK < 16*NDIM + 27 or * RULCLS > MAXCLS. * ************************************************************************ * * Begin driver routine. This routine partitions the working storage * array and then calls the main subroutine ADBASE. * EXTERNAL FUNCTN INTEGER NDIM, MINCLS, MAXCLS, LENWRK, INFORM DOUBLE PRECISION & FUNCTN, ABSREQ, RELREQ, WORK(LENWRK), ABSEST, FINEST INTEGER SBRGNS, MXRGNS, RULCLS, LENRUL, & INERRS, INVALS, INPTRS, INLWRS, INUPRS, INMSHS, INPNTS, INWGTS, & INLOWR, INUPPR, INWDTH, INMESH, INWORK IF ( NDIM .EQ. 1 ) THEN LENRUL = 5 RULCLS = 9 ELSE IF ( NDIM .LT. 12 ) THEN LENRUL = 6 RULCLS = 2**NDIM + 2*NDIM*(NDIM+2) + 1 ELSE LENRUL = 6 RULCLS = 1 + 2*NDIM*(1+2*NDIM) ENDIF IF ( LENWRK .GE. LENRUL*(NDIM+4) + 10*NDIM + 3 .AND. & RULCLS. LE. MAXCLS .AND. MINCLS .LE. MAXCLS ) THEN MXRGNS = ( LENWRK - LENRUL*(NDIM+4) - 7*NDIM )/( 3*NDIM + 3 ) INERRS = 1 INVALS = INERRS + MXRGNS INPTRS = INVALS + MXRGNS INLWRS = INPTRS + MXRGNS INUPRS = INLWRS + MXRGNS*NDIM INMSHS = INUPRS + MXRGNS*NDIM INWGTS = INMSHS + MXRGNS*NDIM INPNTS = INWGTS + LENRUL*4 INLOWR = INPNTS + LENRUL*NDIM INUPPR = INLOWR + NDIM INWDTH = INUPPR + NDIM INMESH = INWDTH + NDIM INWORK = INMESH + NDIM IF ( MINCLS .LT. 0 ) SBRGNS = WORK(LENWRK) CALL ADBASE(NDIM, MINCLS, MAXCLS, FUNCTN, ABSREQ, RELREQ, & ABSEST, FINEST, SBRGNS, MXRGNS, RULCLS, LENRUL, & WORK(INERRS), WORK(INVALS), WORK(INPTRS), WORK(INLWRS), & WORK(INUPRS), WORK(INMSHS), WORK(INWGTS), WORK(INPNTS), & WORK(INLOWR), WORK(INUPPR), WORK(INWDTH), WORK(INMESH), & WORK(INWORK), INFORM) WORK(LENWRK) = SBRGNS ELSE INFORM = 2 MINCLS = RULCLS ENDIF C RETURN END SUBROUTINE ADBASE(NDIM, MINCLS, MAXCLS, FUNCTN, ABSREQ, RELREQ, & ABSEST, FINEST, SBRGNS, MXRGNS, RULCLS, LENRUL, & ERRORS, VALUES, PONTRS, LOWERS, & UPPERS, MESHES, WEGHTS, POINTS, & LOWER, UPPER, WIDTH, MESH, WORK, INFORM) * * Main adaptive integration subroutine * EXTERNAL FUNCTN INTEGER I, J, NDIM, MINCLS, MAXCLS, SBRGNS, MXRGNS, & RULCLS, LENRUL, INFORM, NWRGNS DOUBLE PRECISION FUNCTN, ABSREQ, RELREQ, ABSEST, FINEST, & ERRORS(*), VALUES(*), PONTRS(*), & LOWERS(NDIM,*), UPPERS(NDIM,*), & MESHES(NDIM,*),WEGHTS(*), POINTS(*), & LOWER(*), UPPER(*), WIDTH(*), MESH(*), WORK(*) INTEGER DIVAXN, TOP, RGNCLS, FUNCLS, DIFCLS * * Initialization of subroutine * INFORM = 2 FUNCLS = 0 CALL BSINIT(NDIM, WEGHTS, LENRUL, POINTS) IF ( MINCLS .GE. 0) THEN * * When MINCLS >= 0 determine initial subdivision of the * integration region and apply basic rule to each subregion. * SBRGNS = 0 DO 100 I = 1,NDIM LOWER(I) = 0 MESH(I) = 1 WIDTH(I) = 1/(2*MESH(I)) UPPER(I) = 1 100 CONTINUE DIVAXN = 0 RGNCLS = RULCLS NWRGNS = 1 10 CALL DIFFER(NDIM, LOWER, UPPER, WIDTH, WORK, WORK(NDIM+1), & FUNCTN, DIVAXN, DIFCLS) FUNCLS = FUNCLS + DIFCLS IF ( FUNCLS + RGNCLS*(MESH(DIVAXN)+1)/MESH(DIVAXN) & .LE. MINCLS ) THEN RGNCLS = RGNCLS*(MESH(DIVAXN)+1)/MESH(DIVAXN) NWRGNS = NWRGNS*(MESH(DIVAXN)+1)/MESH(DIVAXN) MESH(DIVAXN) = MESH(DIVAXN) + 1 WIDTH(DIVAXN) = 1/( 2*MESH(DIVAXN) ) GO TO 10 ENDIF IF ( NWRGNS .LE. MXRGNS ) THEN DO 200 I = 1,NDIM UPPER(I) = LOWER(I) + 2*WIDTH(I) MESH(I) = 1 200 CONTINUE ENDIF * * Apply basic rule to subregions and store results in heap. * 20 SBRGNS = SBRGNS + 1 CALL BASRUL(NDIM, LOWER, UPPER, WIDTH, FUNCTN, & WEGHTS, LENRUL, POINTS, WORK, WORK(NDIM+1), & ERRORS(SBRGNS),VALUES(SBRGNS)) CALL TRESTR(SBRGNS, SBRGNS, PONTRS, ERRORS) DO 300 I = 1,NDIM LOWERS(I,SBRGNS) = LOWER(I) UPPERS(I,SBRGNS) = UPPER(I) MESHES(I,SBRGNS) = MESH(I) 300 CONTINUE DO 400 I = 1,NDIM LOWER(I) = UPPER(I) UPPER(I) = LOWER(I) + 2*WIDTH(I) IF ( LOWER(I)+WIDTH(I) .LT. 1 ) GO TO 20 LOWER(I) = 0 UPPER(I) = LOWER(I) + 2*WIDTH(I) 400 CONTINUE FUNCLS = FUNCLS + SBRGNS*RULCLS ENDIF * * Check for termination * 30 FINEST = 0 ABSEST = 0 DO 500 I = 1, SBRGNS FINEST = FINEST + VALUES(I) ABSEST = ABSEST + ERRORS(I) 500 CONTINUE IF ( ABSEST .GT. MAX( ABSREQ, RELREQ*ABS(FINEST) ) & .OR. FUNCLS .LT. MINCLS ) THEN * * Prepare to apply basic rule in (parts of) subregion with * largest error. * TOP = PONTRS(1) RGNCLS = RULCLS DO 600 I = 1,NDIM LOWER(I) = LOWERS(I,TOP) UPPER(I) = UPPERS(I,TOP) MESH(I) = MESHES(I,TOP) WIDTH(I) = (UPPER(I)-LOWER(I))/(2*MESH(I)) RGNCLS = RGNCLS*MESH(I) 600 CONTINUE CALL DIFFER(NDIM, LOWER, UPPER, WIDTH, WORK, WORK(NDIM+1), & FUNCTN, DIVAXN, DIFCLS) FUNCLS = FUNCLS + DIFCLS RGNCLS = RGNCLS*(MESH(DIVAXN)+1)/MESH(DIVAXN) IF ( FUNCLS + RGNCLS .LE. MAXCLS ) THEN IF ( SBRGNS + 1 .LE. MXRGNS ) THEN * * Prepare to subdivide into two pieces. * NWRGNS = 1 WIDTH(DIVAXN) = WIDTH(DIVAXN)/2 ELSE NWRGNS = 0 WIDTH(DIVAXN) = WIDTH(DIVAXN) & *MESH(DIVAXN)/( MESH(DIVAXN) + 1 ) MESHES(DIVAXN,TOP) = MESH(DIVAXN) + 1 ENDIF IF ( NWRGNS .GT. 0 ) THEN * * Only allow local subdivision when space is available. * DO 700 J = SBRGNS+1,SBRGNS+NWRGNS DO 800 I = 1,NDIM LOWERS(I,J) = LOWER(I) UPPERS(I,J) = UPPER(I) MESHES(I,J) = MESH(I) 800 CONTINUE 700 CONTINUE UPPERS(DIVAXN,TOP) = LOWER(DIVAXN) + 2*WIDTH(DIVAXN) LOWERS(DIVAXN,SBRGNS+1) = UPPERS(DIVAXN,TOP) ENDIF FUNCLS = FUNCLS + RGNCLS CALL BASRUL(NDIM, LOWERS(1,TOP), UPPERS(1,TOP), WIDTH, & FUNCTN, WEGHTS, LENRUL, POINTS, WORK, WORK(NDIM+1), & ERRORS(TOP), VALUES(TOP)) CALL TRESTR(TOP, SBRGNS, PONTRS, ERRORS) DO 900 I = SBRGNS+1, SBRGNS+NWRGNS * * Apply basic rule and store results in heap. * CALL BASRUL(NDIM, LOWERS(1,I), UPPERS(1,I), WIDTH, & FUNCTN, WEGHTS, LENRUL, POINTS, WORK, WORK(NDIM+1), & ERRORS(I), VALUES(I)) CALL TRESTR(I, I, PONTRS, ERRORS) 900 CONTINUE SBRGNS = SBRGNS + NWRGNS GO TO 30 ELSE INFORM = 1 ENDIF ELSE INFORM = 0 ENDIF MINCLS = FUNCLS C RETURN END SUBROUTINE ADECDF(X,AK,IADEDF,CDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION C FUNCTION VALUE FOR THE ASYMMETRIC LAPLACE DISTRIBUTION C (OR ASYMMETRIC DOUBLE EXPONENTIAL) C WITH SHAPE PARAMETER = K. C THIS DISTRIBUTION IS DEFINED FOR ALL X AND HAS C THE PROBABILITY DENSITY FUNCTION C ADECDF(X,K) = 1 - (1/(1+K*K))* C EXP(-SQRT(2)*K*ABS(X)) X >= 0 C ADECDF(X,K) = (K*K/(1+K*K))* C EXP((-SQRT(2)/K)*ABS(X)) X >= 0 C ADECDF(X,K) = (SQRT(2)*K/(1+K^2))* C EXP((-SQRT(2)/K)*ABS(X)) X < 0 C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE AT C WHICH THE CUMULATIVE DISTRIBUTION C FUNCTION IS TO BE EVALUATED. C X SHOULD BE NON-NEGATIVE. C --AK = THE SHAPE PARAMETER C OUTPUT ARGUMENTS--CDF = THE SINGLE PRECISION CUMULATIVE C DISTRIBUTION FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION FUNCTION C VALUE CDF FOR THE ASYMMETRIC LAPLACE DISTRIBUTION C WITH SHAPE PARAMETER = K. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--NONE. C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--EXP. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--KOTZ, KOZUBOWSKI, AND PODGORSKI, "THE LAPLACE C DISTRIBUTION AND GENERALIZATIONS: A REVISIT WITH C APPLICATIONS TO COMMUNICATIONS, ECONOMICS, C ENGINEERING, AND FINANCE", BIRKHAUSR, 2001, C PP. 134. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2004.6 C ORIGINAL VERSION--JUNE 2004. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DX DOUBLE PRECISION DK DOUBLE PRECISION DCDF DOUBLE PRECISION DTERM1 C CHARACTER*4 IADEDF C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----DATA STATEMENTS------------------------------------------------- C C-----START POINT----------------------------------------------------- C C ************************************ C ** STEP 1-- ** C ** COMPUTE THE CDF FUNCTION ** C ************************************ C IF(IADEDF.EQ.'K')THEN IF(AK.LE.0.0)THEN WRITE(ICOUT,5) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,48)AK CALL DPWRST('XXX','WRIT') CDF=0.0 GOTO9000 ENDIF ELSE AK=SQRT(2.0)/(AK + SQRT(2.0 + AK*AK)) ENDIF 5 FORMAT('***** ERROR: VALUE OF SHAPE PARAMETER (K) IN ADECDF ', 1 'ROUTINE IS NEGATIVE.') 48 FORMAT(' VALUE OF ARGUMENT IS: ',G15.7) C DX=DBLE(X) DK=DBLE(AK) C IF(X.LT.0.0)THEN DTERM1=DK*DK/(1.0D0 + DK*DK) DCDF=DTERM1*DEXP((-DSQRT(2.0D0)/DK)*DABS(DX)) ELSE DTERM1=1.0D0/(1.0D0 + DK*DK) DCDF=1.0D0 - DTERM1*DEXP(-DSQRT(2.0D0)*DK*DABS(DX)) ENDIF CDF=REAL(DCDF) C 9000 CONTINUE RETURN END SUBROUTINE ADEPDF(X,AK,IADEDF,PDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY C FUNCTION VALUE FOR THE ASYMMETRIC LAPLACE DISTRIBUTION C (OR ASYMMETRIC DOUBLE EXPONENTIAL) C WITH SHAPE PARAMETER = K. C THIS DISTRIBUTION IS DEFINED FOR ALL X AND HAS C THE PROBABILITY DENSITY FUNCTION C ADEPDF(X,K) = (SQRT(2)*K/(1+K^2))* C EXP(-SQRT(2)*K*ABS(X)) X >= 0 C ADEPDF(X,K) = (SQRT(2)*K/(1+K^2))* C EXP((-SQRT(2)/K)*ABS(X)) X < 0 C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE AT C WHICH THE PROBABILITY DENSITY C FUNCTION IS TO BE EVALUATED. C X SHOULD BE NON-NEGATIVE. C --AK = THE SHAPE PARAMETER C OUTPUT ARGUMENTS--PDF = THE SINGLE PRECISION PROBABILITY C DENSITY FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY FUNCTION C VALUE PDF FOR THE ASYMMETRIC LAPLACE DISTRIBUTION C WITH SHAPE PARAMETER = K. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--NONE. C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--EXP. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--KOTZ, KOZUBOWSKI, AND PODGORSKI, "THE LAPLACE C DISTRIBUTION AND GENERALIZATIONS: A REVISIT WITH C APPLICATIONS TO COMMUNICATIONS, ECONOMICS, C ENGINEERING, AND FINANCE", BIRKHAUSR, 2001, C PP. 134. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2004.6 C ORIGINAL VERSION--JUNE 2004. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DX DOUBLE PRECISION DK DOUBLE PRECISION DPDF DOUBLE PRECISION DTERM1 C CHARACTER*4 IADEDF C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----DATA STATEMENTS------------------------------------------------- C C-----START POINT----------------------------------------------------- C C ************************************ C ** STEP 1-- ** C ** COMPUTE THE DENSITY FUNCTION ** C ************************************ C IF(IADEDF.EQ.'K')THEN IF(AK.LE.0.0)THEN WRITE(ICOUT,5) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,48)AK CALL DPWRST('XXX','WRIT') PDF=0.0 GOTO9000 ENDIF ELSE AK=SQRT(2.0)/(AK + SQRT(2.0 + AK*AK)) ENDIF 5 FORMAT('***** ERROR: VALUE OF SHAPE PARAMETER (K) IN ADEPDF ', 1 'ROUTINE IS NEGATIVE.') 48 FORMAT(' VALUE OF ARGUMENT IS: ',G15.7) C DX=DBLE(X) DK=DBLE(AK) C DTERM1=DSQRT(2.0D0)*DK/(1.0D0+DK*DK) IF(X.LT.0.0)THEN DPDF=DTERM1*DEXP((-DSQRT(2.0D0)/DK)*DABS(DX)) ELSE DPDF=DTERM1*DEXP(-DSQRT(2.0D0)*DK*DABS(DX)) ENDIF PDF=REAL(DPDF) C 9000 CONTINUE RETURN END SUBROUTINE ADEPPF(P,AK,IADEDF,PPF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT C FUNCTION VALUE FOR THE ASYMMETRIC LAPLACE DISTRIBUTION C (OR ASYMMETRIC DOUBLE EXPONENTIAL) C WITH SHAPE PARAMETER = K. C THIS DISTRIBUTION IS DEFINED FOR ALL X AND HAS C THE PERCENT POINT FUNCTION C G(P,K) = (K/SQRT(2))*LOG[((1+K**2)/K**2)*P] C 0 < P < K**2/(1+K**2) C G(P,K) = (-1/(K*SQRT(2)))*LOG[((1+K**2)*(1-P)] C K**2/(1+K**2) < P < 1 C INPUT ARGUMENTS--P = THE SINGLE PRECISION VALUE AT C WHICH THE PERCENT POINT C FUNCTION IS TO BE EVALUATED. C P SHOULD BE IN THE INTERVAL (0,1). C --AK = THE SHAPE PARAMETER C OUTPUT ARGUMENTS--PPF = THE SINGLE PRECISION PERCENT POINT C FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION PERCENT POINT FUNCTION C VALUE PPF FOR THE ASYMMETRIC LAPLACE DISTRIBUTION C WITH SHAPE PARAMETER = K. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--NONE. C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--LOG. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--KOTZ, KOZUBOWSKI, AND PODGORSKI, "THE LAPLACE C DISTRIBUTION AND GENERALIZATIONS: A REVISIT WITH C APPLICATIONS TO COMMUNICATIONS, ECONOMICS, C ENGINEERING, AND FINANCE", BIRKHAUSR, 2001, C PP. 134. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2004.6 C ORIGINAL VERSION--JUNE 2004. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DP DOUBLE PRECISION DK DOUBLE PRECISION DPPF DOUBLE PRECISION DTERM1 C CHARACTER*4 IADEDF C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----DATA STATEMENTS------------------------------------------------- C C-----START POINT----------------------------------------------------- C C ************************************ C ** STEP 1-- ** C ** COMPUTE THE DENSITY FUNCTION ** C ************************************ C IF(P.LE.0.0.OR.P.GE.1.0)THEN WRITE(ICOUT,61) 61 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT ', 1 'TO THE ADEPPF SUBROUTINE ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,62) 62 FORMAT(' IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,63)P 63 FORMAT(' VALUE OF ARGUMENT = ',G15.7) CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9000 ENDIF C C IF(IADEDF.EQ.'K')THEN IF(AK.LE.0.0)THEN WRITE(ICOUT,5) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,48)AK CALL DPWRST('XXX','WRIT') PPF=0.0 GOTO9000 ENDIF ELSE AK=SQRT(2.0)/(AK + SQRT(2.0 + AK*AK)) ENDIF 5 FORMAT('***** ERROR: VALUE OF SHAPE PARAMETER (K) IN ADEPPF ', 1 'ROUTINE IS NEGATIVE.') 48 FORMAT(' VALUE OF ARGUMENT IS: ',G15.7) C DP=DBLE(P) DK=DBLE(AK) PCUT=AK**2/(1.0+AK**2) C IF(P.LT.PCUT)THEN DPPF=(DK/DSQRT(2.0D0))*DLOG(((1.0D0+DK*DK)/(DK*DK))*DP) ELSE DPPF=(-1.0D0/(DSQRT(2.0D0)*DK))*DLOG((1.0D0+DK*DK)*(1.0D0-DP)) ENDIF PPF=REAL(DPPF) C 9000 CONTINUE RETURN END SUBROUTINE ADERAN(N,AK,IADEDF,ISEED,X) C C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N C FROM THE ASYMMETRIC DOUBLE EXPONENTIAL (LAPLACE) C DISTRIBUTION WITH SHAPE PARAMETER = AK. C THIS DISTRIBUTION IS DEFINED FOR ALL X AND HAS C THE PROBABILITY DENSITY FUNCTION C ADEPDF(X,K) = (SQRT(2)*K/(1+K^2))* C EXP(-SQRT(2)*K*ABS(X)) X >= 0 C ADEPDF(X,K) = (SQRT(2)*K/(1+K^2))* C EXP((-SQRT(2)/K)*ABS(X)) X < 0 C INPUT ARGUMENTS--N = THE DESIRED INTEGER NUMBER C OF RANDOM NUMBERS TO BE C GENERATED. C --AK = THE SHAPE (PARAMETER) FOR THE C ASYMMETRIC DOUBLE EXPONENTIAL C DISTRIBUTION. C OUTPUT ARGUMENTS--X = A SINGLE PRECISION VECTOR C (OF DIMENSION AT LEAST N) C INTO WHICH THE GENERATED C RANDOM SAMPLE WILL BE PLACED. C OUTPUT--A RANDOM SAMPLE OF SIZE N C FROM THE ASYMMETRIC DOUBLE EXPONENTIAL DISTRIBUTION C WITH SHAPE PARAMETER = AK. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C --AK CAN BE ANY REAL NUMBER. C OTHER DATAPAC SUBROUTINES NEEDED--UNIRAN. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--KOTZ, KOZUBOWSKI, AND PODGORSKI, "THE LAPLACE C DISTRIBUTION AND GENERALIZATIONS: A REVISIT WITH C APPLICATIONS TO COMMUNICATIONS, ECONOMICS, C ENGINEERING, AND FINANCE", BIRKHAUSR, 2001, C PP. 134-149. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATION INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2004.6 C ORIGINAL VERSION--JUNE 2004. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DIMENSION X(*) DIMENSION Y(2) C CHARACTER*4 IADEDF C DOUBLE PRECISION U1 DOUBLE PRECISION U2 DOUBLE PRECISION DK DOUBLE PRECISION DPPF C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----DATA STATEMENTS------------------------------------------------- C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(N.LT.1)THEN WRITE(ICOUT,5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,6) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)N CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF IF(IADEDF.EQ.'K')THEN IF(AK.LE.0.0)THEN WRITE(ICOUT,15) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,48)AK CALL DPWRST('XXX','WRIT') PDF=0.0 GOTO9999 ENDIF ELSE AK=SQRT(2.0)/(AK + SQRT(2.0 + AK*AK)) ENDIF 15 FORMAT('***** ERROR: VALUE OF SHAPE PARAMETER (K) IS ', 1 'NON-POSITIVE.') C 5 FORMAT('***** ERROR--FOR THE ASYMMETRIC DOUBLE EXPONENTIAL ', 1 'DISTRIBUTION,') 6 FORMAT(' THE REQUESTED NUMBER OF RANDOM NUMBERS WAS ', 1 'NON-POSITIVE.') 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,'.') 48 FORMAT(' VALUE OF ARGUMENT IS: ',G15.7) C C USE PERCENT POINT TRANSFORMATION METHOD. C NTEMP=2 DK=DBLE(AK) DO100I=1,N CALL UNIRAN(NTEMP,ISEED,Y) U1=DBLE(Y(1)) U2=DBLE(Y(2)) DPPF=(1.0D0/DSQRT(2.0D0))*DLOG(U1**DK/(U2**(1.0D0/DK))) X(I)=REAL(DPPF) 100 CONTINUE C 9999 CONTINUE RETURN END SUBROUTINE ADJUS2(IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) C C PURPOSE--PACK < = INTO <= C PACK = < INTO =< C PACK > = INTO >= C PACK = > INTO => C PACK < > INTO <> C NOTE--THIS PACKING IS DONE BECAUSE SUBROUTINE DPTYPE C AUTOMATICALLY PUTS SPACES AROUND C AN EQUAL SIGN AND PUTS THE EQUAL SIGN C IN A SEPARATE WORD. C NOTE--NUMARG IS CHANGED BY THIS SUBROUTINE. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-921-3651 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION--SEPTEMBER 1981. C UPDATED --MAY 1982. C UPDATED --MARCH 1988. ALLOW NOT EQUAL <> >< NOT= C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 IHARG2 CHARACTER*4 IARGT C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C DIMENSION IHARG(*) DIMENSION IHARG2(*) DIMENSION IARG(*) DIMENSION ARG(*) DIMENSION IARGT(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='ADJU' ISUBN2='S2 ' C IMAX=NUMARG-1 IF(1.GT.IMAX)GOTO9000 DO100I=1,IMAX IP1=I+1 IF(IP1.GT.NUMARG)GOTO9000 IF(IHARG(I).EQ.'< '.AND.IHARG(IP1).EQ.'= ')GOTO110 IF(IHARG(I).EQ.'= '.AND.IHARG(IP1).EQ.'< ')GOTO120 IF(IHARG(I).EQ.'> '.AND.IHARG(IP1).EQ.'= ')GOTO130 IF(IHARG(I).EQ.'= '.AND.IHARG(IP1).EQ.'> ')GOTO140 IF(IHARG(I).EQ.'< '.AND.IHARG(IP1).EQ.'> ')GOTO150 IF(IHARG(I).EQ.'> '.AND.IHARG(IP1).EQ.'< ')GOTO160 IF(IHARG(I).EQ.'NOT '.AND.IHARG(IP1).EQ.'= ')GOTO170 GOTO100 C 110 CONTINUE IHARG(I)='<= ' IHARG2(I)=' ' GOTO250 120 CONTINUE IHARG(I)='=< ' IHARG2(I)=' ' GOTO250 130 CONTINUE IHARG(I)='>= ' IHARG2(I)=' ' GOTO250 140 CONTINUE IHARG(I)='=> ' IHARG2(I)=' ' GOTO250 150 CONTINUE IHARG(I)='<> ' IHARG2(I)=' ' GOTO250 160 CONTINUE IHARG(I)='>< ' IHARG2(I)=' ' GOTO250 170 CONTINUE IHARG(I)='NOT=' IHARG2(I)=' ' GOTO250 C 250 CONTINUE JMAX=NUMARG-1 IF(IP1.GT.JMAX)GOTO265 DO260J=IP1,JMAX JP1=J+1 IHARG(J)=IHARG(JP1) IHARG2(J)=IHARG2(JP1) IARGT(J)=IARGT(JP1) IARG(J)=IARG(JP1) ARG(J)=ARG(JP1) 260 CONTINUE 265 CONTINUE NUMARG=NUMARG-1 100 CONTINUE C 9000 CONTINUE C RETURN END SUBROUTINE ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) C C PURPOSE--ADJUST THE IHARG,IHARG2, IARG, ARG, AND IARGT VECTORS C AS WELL AS THE VALUE OF NUMARG C WHEN HAVE MULTIPLE-WORD COMMANDS; C THE ADJUSTMENT RESULTS IN THE C FIRST AREGUMENT AFTER THE LAST WORD OF THE COMMAND C BEING MAPPED INTO IHARG(1), ETC. C NOTE--ILASTC IS THE CURRENT ARGUMENT NUMBER IN IHARG C OF THE CURRENT LAST WORD IN THE COMMAND PART C OF THE COMMAND STATEMENT. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-921-3651 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION--APRIL 1978. C UPDATED --JUNE 1978. C UPDATED --JANUARY 1981. C UPDATED --JULY 1981. C UPDATED --NOVEMBER 1981. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 IHARG2 CHARACTER*4 IARGT C CHARACTER*4 IBUGAD C C--------------------------------------------------------------------- C DIMENSION IHARG(*) DIMENSION IHARG2(*) DIMENSION IARG(*) DIMENSION ARG(*) DIMENSION IARGT(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IBUGAD='OFF' C IF(IBUGAD.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF ADJUST--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)ILASTC,NUMARG 52 FORMAT('ILASTC,NUMARG = ',2I8) CALL DPWRST('XXX','BUG ') DO55I=1,NUMARG WRITE(ICOUT,56)I,IHARG(I),IHARG2(I),IARG(I),ARG(I),IARGT(I) 56 FORMAT('I,IHARG(I),IHARG2(I),IARG(I),ARG(I),IARGT(I) = ', 1I8,2X,A4,A4,I8,E15.7,2X,A4) CALL DPWRST('XXX','BUG ') 55 CONTINUE 90 CONTINUE C ILASTP=ILASTC+1 IF(ILASTP.GT.NUMARG)GOTO150 J=0 DO100I=ILASTP,NUMARG J=J+1 IHARG(J)=IHARG(I) IHARG2(J)=IHARG2(I) IARG(J)=IARG(I) ARG(J)=ARG(I) IARGT(J)=IARGT(I) 100 CONTINUE NUMARG=J GOTO9000 C 150 CONTINUE NUMARG=0 GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGAD.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF ADJUST--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)ILASTC,NUMARG 9012 FORMAT('ILASTC,NUMARG = ',2I8) CALL DPWRST('XXX','BUG ') DO9015I=1,NUMARG WRITE(ICOUT,9016)I,IHARG(I),IHARG2(I),IARG(I),ARG(I),IARGT(I) 9016 FORMAT('I,IHARG(I),IHARG2(I),IARG(I),ARG(I),IARGT(I) = ', 1I8,2X,A4,A4,I8,E15.7,2X,A4) CALL DPWRST('XXX','BUG ') 9015 CONTINUE 9090 CONTINUE C RETURN END FUNCTION AI (X) C***BEGIN PROLOGUE AI C***PURPOSE Evaluate the Airy function. C***LIBRARY SLATEC (FNLIB) C***CATEGORY C10D C***TYPE SINGLE PRECISION (AI-S, DAI-D) C***KEYWORDS AIRY FUNCTION, FNLIB, SPECIAL FUNCTIONS C***AUTHOR Fullerton, W., (LANL) C***DESCRIPTION C C AI(X) computes the Airy function Ai(X) C Series for AIF on the interval -1.00000D+00 to 1.00000D+00 C with weighted error 1.09E-19 C log weighted error 18.96 C significant figures required 17.76 C decimal places required 19.44 C C Series for AIG on the interval -1.00000D+00 to 1.00000D+00 C with weighted error 1.51E-17 C log weighted error 16.82 C significant figures required 15.19 C decimal places required 17.27 C C***REFERENCES (NONE) C***ROUTINES CALLED AIE, CSEVL, INITS, R1MACH, R9AIMP, XERMSG C***REVISION HISTORY (YYMMDD) C 770701 DATE WRITTEN C 890531 Changed all specific intrinsics to generic. (WRB) C 890531 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) C 900326 Removed duplicate information from DESCRIPTION section. C (WRB) C 920618 Removed space from variable names. (RWC, WRB) C***END PROLOGUE AI C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOMC.INC' CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C DIMENSION AIFCS(9), AIGCS(8) LOGICAL FIRST SAVE AIFCS, AIGCS, NAIF, NAIG, X3SML, XMAX, FIRST DATA AIFCS( 1) / -.0379713584 9666999750E0 / DATA AIFCS( 2) / .0591918885 3726363857E0 / DATA AIFCS( 3) / .0009862928 0577279975E0 / DATA AIFCS( 4) / .0000068488 4381907656E0 / DATA AIFCS( 5) / .0000000259 4202596219E0 / DATA AIFCS( 6) / .0000000000 6176612774E0 / DATA AIFCS( 7) / .0000000000 0010092454E0 / DATA AIFCS( 8) / .0000000000 0000012014E0 / DATA AIFCS( 9) / .0000000000 0000000010E0 / DATA AIGCS( 1) / .0181523655 8116127E0 / DATA AIGCS( 2) / .0215725631 6601076E0 / DATA AIGCS( 3) / .0002567835 6987483E0 / DATA AIGCS( 4) / .0000014265 2141197E0 / DATA AIGCS( 5) / .0000000045 7211492E0 / DATA AIGCS( 6) / .0000000000 0952517E0 / DATA AIGCS( 7) / .0000000000 0001392E0 / DATA AIGCS( 8) / .0000000000 0000001E0 / DATA FIRST /.TRUE./ C***FIRST EXECUTABLE STATEMENT AI IF (FIRST) THEN NAIF = INITS (AIFCS, 9, 0.1*R1MACH(3)) NAIG = INITS (AIGCS, 8, 0.1*R1MACH(3)) C X3SML = R1MACH(3)**0.3334 XMAXT = (-1.5*LOG(R1MACH(1)))**0.6667 XMAX = XMAXT - XMAXT*LOG(XMAXT)/ * (4.0*SQRT(XMAXT)+1.0) - 0.01 ENDIF FIRST = .FALSE. C IF (X.GE.(-1.0)) GO TO 20 CALL R9AIMP (X, XM, THETA) AI = XM * COS(THETA) RETURN C 20 IF (X.GT.1.0) GO TO 30 Z = 0.0 IF (ABS(X).GT.X3SML) Z = X**3 AI = 0.375 + (CSEVL (Z, AIFCS, NAIF) - X*(0.25 + 1 CSEVL (Z, AIGCS, NAIG)) ) RETURN C 30 IF (X.GT.XMAX) GO TO 40 AI = AIE(X) * EXP(-2.0*X*SQRT(X)/3.0) RETURN C 40 AI = 0.0 WRITE(ICOUT,1) CALL DPWRST('XXX','BUG ') 1 FORMAT('***** WARNING FROM AI, UNDERFLOW BECAUSE THE ', 1 'VALUE OF X IS SO BIG. ****') RETURN C END FUNCTION AIE (X) C***BEGIN PROLOGUE AIE C***PURPOSE Calculate the Airy function for a negative argument and an C exponentially scaled Airy function for a non-negative C argument. C***LIBRARY SLATEC (FNLIB) C***CATEGORY C10D C***TYPE SINGLE PRECISION (AIE-S, DAIE-D) C***KEYWORDS EXPONENTIALLY SCALED AIRY FUNCTION, FNLIB, C SPECIAL FUNCTIONS C***AUTHOR Fullerton, W., (LANL) C***DESCRIPTION C C AIE(X) computes the exponentially scaled Airy function for C non-negative X. It evaluates AI(X) for X .LE. 0.0 and C EXP(ZETA)*AI(X) for X .GE. 0.0 where ZETA = (2.0/3.0)*(X**1.5). C C Series for AIF on the interval -1.00000D+00 to 1.00000D+00 C with weighted error 1.09E-19 C log weighted error 18.96 C significant figures required 17.76 C decimal places required 19.44 C C Series for AIG on the interval -1.00000D+00 to 1.00000D+00 C with weighted error 1.51E-17 C log weighted error 16.82 C significant figures required 15.19 C decimal places required 17.27 C C Series for AIP on the interval 0. to 1.00000D+00 C with weighted error 5.10E-17 C log weighted error 16.29 C significant figures required 14.41 C decimal places required 17.06 C C***REFERENCES (NONE) C***ROUTINES CALLED CSEVL, INITS, R1MACH, R9AIMP C***REVISION HISTORY (YYMMDD) C 770701 DATE WRITTEN C 890206 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 920618 Removed space from variable names. (RWC, WRB) C***END PROLOGUE AIE C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOMC.INC' CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C DIMENSION AIFCS(9), AIGCS(8), AIPCS(34) LOGICAL FIRST SAVE AIFCS, AIGCS, AIPCS, NAIF, NAIG, 1 NAIP, X3SML, X32SML, XBIG, FIRST DATA AIFCS( 1) / -.0379713584 9666999750E0 / DATA AIFCS( 2) / .0591918885 3726363857E0 / DATA AIFCS( 3) / .0009862928 0577279975E0 / DATA AIFCS( 4) / .0000068488 4381907656E0 / DATA AIFCS( 5) / .0000000259 4202596219E0 / DATA AIFCS( 6) / .0000000000 6176612774E0 / DATA AIFCS( 7) / .0000000000 0010092454E0 / DATA AIFCS( 8) / .0000000000 0000012014E0 / DATA AIFCS( 9) / .0000000000 0000000010E0 / DATA AIGCS( 1) / .0181523655 8116127E0 / DATA AIGCS( 2) / .0215725631 6601076E0 / DATA AIGCS( 3) / .0002567835 6987483E0 / DATA AIGCS( 4) / .0000014265 2141197E0 / DATA AIGCS( 5) / .0000000045 7211492E0 / DATA AIGCS( 6) / .0000000000 0952517E0 / DATA AIGCS( 7) / .0000000000 0001392E0 / DATA AIGCS( 8) / .0000000000 0000001E0 / DATA AIPCS( 1) / -.0187519297 793868E0 / DATA AIPCS( 2) / -.0091443848 250055E0 / DATA AIPCS( 3) / .0009010457 337825E0 / DATA AIPCS( 4) / -.0001394184 127221E0 / DATA AIPCS( 5) / .0000273815 815785E0 / DATA AIPCS( 6) / -.0000062750 421119E0 / DATA AIPCS( 7) / .0000016064 844184E0 / DATA AIPCS( 8) / -.0000004476 392158E0 / DATA AIPCS( 9) / .0000001334 635874E0 / DATA AIPCS(10) / -.0000000420 735334E0 / DATA AIPCS(11) / .0000000139 021990E0 / DATA AIPCS(12) / -.0000000047 831848E0 / DATA AIPCS(13) / .0000000017 047897E0 / DATA AIPCS(14) / -.0000000006 268389E0 / DATA AIPCS(15) / .0000000002 369824E0 / DATA AIPCS(16) / -.0000000000 918641E0 / DATA AIPCS(17) / .0000000000 364278E0 / DATA AIPCS(18) / -.0000000000 147475E0 / DATA AIPCS(19) / .0000000000 060851E0 / DATA AIPCS(20) / -.0000000000 025552E0 / DATA AIPCS(21) / .0000000000 010906E0 / DATA AIPCS(22) / -.0000000000 004725E0 / DATA AIPCS(23) / .0000000000 002076E0 / DATA AIPCS(24) / -.0000000000 000924E0 / DATA AIPCS(25) / .0000000000 000417E0 / DATA AIPCS(26) / -.0000000000 000190E0 / DATA AIPCS(27) / .0000000000 000087E0 / DATA AIPCS(28) / -.0000000000 000040E0 / DATA AIPCS(29) / .0000000000 000019E0 / DATA AIPCS(30) / -.0000000000 000009E0 / DATA AIPCS(31) / .0000000000 000004E0 / DATA AIPCS(32) / -.0000000000 000002E0 / DATA AIPCS(33) / .0000000000 000001E0 / DATA AIPCS(34) / -.0000000000 000000E0 / DATA FIRST /.TRUE./ C***FIRST EXECUTABLE STATEMENT AIE IF (FIRST) THEN ETA = 0.1*R1MACH(3) NAIF = INITS (AIFCS, 9, ETA) NAIG = INITS (AIGCS, 8, ETA) NAIP = INITS (AIPCS, 34, ETA) C X3SML = ETA**0.3333 X32SML = 1.3104*X3SML**2 XBIG = R1MACH(2)**0.6666 ENDIF FIRST = .FALSE. C IF (X.GE.(-1.0)) GO TO 20 CALL R9AIMP (X, XM, THETA) AIE = XM * COS(THETA) RETURN C 20 IF (X.GT.1.0) GO TO 30 Z = 0.0 IF (ABS(X).GT.X3SML) Z = X**3 AIE = 0.375 + (CSEVL (Z, AIFCS, NAIF) - X*(0.25 + 1 CSEVL (Z, AIGCS, NAIG)) ) IF (X.GT.X32SML) AIE = AIE * EXP(2.0*X*SQRT(X)/3.0) RETURN C 30 SQRTX = SQRT(X) Z = -1.0 IF (X.LT.XBIG) Z = 2.0/(X*SQRTX) - 1.0 AIE = (.28125 + CSEVL (Z, AIPCS, NAIP))/SQRT(SQRTX) RETURN C END DOUBLE PRECISION FUNCTION AIRINT(XVALUE) C C DESCRIPTION: C C This function calculates the integral of the Airy function Ai, C defined as C C AIRINT(x) = {integral 0 to x} Ai(t) dt C C The program uses Chebyshev expansions, the coefficients of which C are given to 20 decimal places. C C C ERROR RETURNS: C C If the argument is too large and negative, it is impossible C to accurately compute the necessary SIN and COS functions. C An error message is printed, and the program returns the C value -2/3 (the value at -infinity). C C C MACHINE-DEPENDENT CONSTANTS: C C NTERM1 - INTEGER - The no. of terms to be used from the array C AAINT1. The recommended value is such that C ABS(AAINT1(NTERM1)) < EPS/100, C subject to 1 <= NTERM1 <= 25. C C NTERM2 - INTEGER - The no. of terms to be used from the array C AAINT2. The recommended value is such that C ABS(AAINT2(NTERM2)) < EPS/100, C subject to 1 <= NTERM2 <= 21. C C NTERM3 - INTEGER - The no. of terms to be used from the array C AAINT3. The recommended value is such that C ABS(AAINT3(NTERM3)) < EPS/100, C subject to 1 <= NTERM3 <= 40. C C NTERM4 - INTEGER - The no. of terms to be used from the array C AAINT4. The recommended value is such that C ABS(AAINT4(NTERM4)) < EPS/100, C subject to 1 <= NTERM4 <= 17. C C NTERM5 - INTEGER - The no. of terms to be used from the array C AAINT5. The recommended value is such that C ABS(AAINT5(NTERM5)) < EPS/100, C subject to 1 <= NTERM5 <= 17. C C XLOW1 - DOUBLE PRECISION - The value such that, if |x| < XLOW1, C AIRINT(x) = x * Ai(0) C to machine precision. The recommended value is C 2 * EPSNEG. C C XHIGH1 - DOUBLE PRECISION - The value such that, if x > XHIGH1, C AIRINT(x) = 1/3, C to machine precision. The recommended value is C (-1.5*LOG(EPSNEG)) ** (2/3). C C XNEG1 - DOUBLE PRECISION - The value such that, if x < XNEG1, C the trigonometric functions in the asymptotic C expansion cannot be calculated accurately. C The recommended value is C -(1/((EPS)**2/3)) C C For values of EPS and EPSNEG, refer to the file MACHCON.TXT. C C The machine-dependent constants are computed internally by C using the D1MACH subroutine. C C C INTRINSIC FUNCTIONS USED: C COS, EXP, SIN, SQRT C C C OTHER MISCFUN SUBROUTINES USED: C C CHEVAL , ERRPRN, D1MACH C C C AUTHOR: Dr. Allan J. MacLeod, C Dept. of Mathematics and Statistics, C Univ. of Paisley, C High St., C Paisley, C SCOTLAND. C PA1 2BE C C (e-mail:macl_ms0@paisley.ac.uk) C C C LATEST REVISION: 23 January, 1996 C INTEGER NTERM1,NTERM2,NTERM3,NTERM4,NTERM5 DOUBLE PRECISION AAINT1(0:25),AAINT2(0:21),AAINT3(0:40), 1 AAINT4(0:17),AAINT5(0:17), 2 AIRZER,ARG,CHEVAL,EIGHT,FORTY1,FOUR,FR996,GVAL, 3 HVAL,NINE,NINHUN,ONE,ONEHUN,PIBY4,PITIM6,RT2B3P,T,TEMP, 4 THREE,TWO,X,XHIGH1,XLOW1,XNEG1,XVALUE,Z,ZERO CCCCC CHARACTER FNNAME*6,ERRMSG*46 CCCCC DATA FNNAME/'AIRINT'/ CCCCC DATA ERRMSG/'FUNCTION TOO NEGATIVE FOR ACCURATE COMPUTATION'/ C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOMC.INC' CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C DATA AAINT1(0)/ 0.37713 51769 46836 95526 D 0/ DATA AAINT1(1)/ -0.13318 86843 24079 47431 D 0/ DATA AAINT1(2)/ 0.31524 97374 78288 4809 D -1/ DATA AAINT1(3)/ -0.31854 30764 36574 077 D -2/ DATA AAINT1(4)/ -0.87398 76469 86219 15 D -3/ DATA AAINT1(5)/ 0.46699 49765 53969 71 D -3/ DATA AAINT1(6)/ -0.95449 36738 98369 2 D -4/ DATA AAINT1(7)/ 0.54270 56871 56716 D -5/ DATA AAINT1(8)/ 0.23949 64062 52188 D -5/ DATA AAINT1(9)/ -0.75690 27020 5649 D -6/ DATA AAINT1(10)/ 0.90501 38584 518 D -7/ DATA AAINT1(11)/ 0.32052 94560 43 D -8/ DATA AAINT1(12)/-0.30382 55364 44 D -8/ DATA AAINT1(13)/ 0.48900 11859 6 D -9/ DATA AAINT1(14)/-0.18398 20572 D -10/ DATA AAINT1(15)/-0.71124 7519 D -11/ DATA AAINT1(16)/ 0.15177 4419 D -11/ DATA AAINT1(17)/-0.10801 922 D -12/ DATA AAINT1(18)/-0.96354 2 D -14/ DATA AAINT1(19)/ 0.31342 5 D -14/ DATA AAINT1(20)/-0.29446 D -15/ DATA AAINT1(21)/-0.477 D -17/ DATA AAINT1(22)/ 0.461 D -17/ DATA AAINT1(23)/-0.53 D -18/ DATA AAINT1(24)/ 0.1 D -19/ DATA AAINT1(25)/ 0.1 D -19/ DATA AAINT2(0)/ 1.92002 52408 19840 09769 D 0/ DATA AAINT2(1)/ -0.42200 49417 25628 7021 D -1/ DATA AAINT2(2)/ -0.23945 77229 65939 223 D -2/ DATA AAINT2(3)/ -0.19564 07048 33529 71 D -3/ DATA AAINT2(4)/ -0.15472 52891 05611 2 D -4/ DATA AAINT2(5)/ -0.14049 01861 37889 D -5/ DATA AAINT2(6)/ -0.12128 01427 1367 D -6/ DATA AAINT2(7)/ -0.11791 86050 192 D -7/ DATA AAINT2(8)/ -0.10431 55787 88 D -8/ DATA AAINT2(9)/ -0.10908 20929 3 D -9/ DATA AAINT2(10)/-0.92963 3045 D -11/ DATA AAINT2(11)/-0.11094 6520 D -11/ DATA AAINT2(12)/-0.78164 83 D -13/ DATA AAINT2(13)/-0.13196 61 D -13/ DATA AAINT2(14)/-0.36823 D -15/ DATA AAINT2(15)/-0.21505 D -15/ DATA AAINT2(16)/ 0.1238 D -16/ DATA AAINT2(17)/-0.557 D -17/ DATA AAINT2(18)/ 0.84 D -18/ DATA AAINT2(19)/-0.21 D -18/ DATA AAINT2(20)/ 0.4 D -19/ DATA AAINT2(21)/-0.1 D -19/ DATA AAINT3(0)/ 0.47985 89326 47910 52053 D 0/ DATA AAINT3(1)/ -0.19272 37512 61696 08863 D 0/ DATA AAINT3(2)/ 0.20511 54129 52542 8189 D -1/ DATA AAINT3(3)/ 0.63320 00070 73248 8786 D -1/ DATA AAINT3(4)/ -0.50933 22261 84575 4082 D -1/ DATA AAINT3(5)/ 0.12844 24078 66166 3016 D -1/ DATA AAINT3(6)/ 0.27601 37088 98947 9413 D -1/ DATA AAINT3(7)/ -0.15470 66673 86664 9507 D -1/ DATA AAINT3(8)/ -0.14968 64655 38931 6026 D -1/ DATA AAINT3(9)/ 0.33661 76141 73574 541 D -2/ DATA AAINT3(10)/ 0.53085 11635 18892 985 D -2/ DATA AAINT3(11)/ 0.41371 22645 85550 81 D -3/ DATA AAINT3(12)/-0.10249 05799 26726 266 D -2/ DATA AAINT3(13)/-0.32508 22167 20258 53 D -3/ DATA AAINT3(14)/ 0.86086 60957 16921 3 D -4/ DATA AAINT3(15)/ 0.66713 67298 12077 5 D -4/ DATA AAINT3(16)/ 0.44920 59993 18095 D -5/ DATA AAINT3(17)/-0.67042 72309 58249 D -5/ DATA AAINT3(18)/-0.19663 65700 85009 D -5/ DATA AAINT3(19)/ 0.22229 67740 7226 D -6/ DATA AAINT3(20)/ 0.22332 22294 9137 D -6/ DATA AAINT3(21)/ 0.28033 13766 457 D -7/ DATA AAINT3(22)/-0.11556 51663 619 D -7/ DATA AAINT3(23)/-0.43306 98217 36 D -8/ DATA AAINT3(24)/-0.62277 77938 D -10/ DATA AAINT3(25)/ 0.26432 66490 3 D -9/ DATA AAINT3(26)/ 0.53338 81114 D -10/ DATA AAINT3(27)/-0.52295 7269 D -11/ DATA AAINT3(28)/-0.38222 9283 D -11/ DATA AAINT3(29)/-0.40958 233 D -12/ DATA AAINT3(30)/ 0.11515 622 D -12/ DATA AAINT3(31)/ 0.38757 66 D -13/ DATA AAINT3(32)/ 0.14028 3 D -14/ DATA AAINT3(33)/-0.14152 6 D -14/ DATA AAINT3(34)/-0.28746 D -15/ DATA AAINT3(35)/ 0.923 D -17/ DATA AAINT3(36)/ 0.1224 D -16/ DATA AAINT3(37)/ 0.157 D -17/ DATA AAINT3(38)/-0.19 D -18/ DATA AAINT3(39)/-0.8 D -19/ DATA AAINT3(40)/-0.1 D -19/ DATA AAINT4/1.99653 30582 85227 30048 D 0, 1 -0.18754 11776 05417 759 D -2, 2 -0.15377 53628 03057 50 D -3, 3 -0.12831 12967 68234 9 D -4, 4 -0.10812 84819 64162 D -5, 5 -0.91821 31174 057 D -7, 6 -0.78416 05909 60 D -8, 7 -0.67292 45387 8 D -9, 8 -0.57963 25198 D -10, 9 -0.50104 0991 D -11, X -0.43420 222 D -12, 1 -0.37743 05 D -13, 2 -0.32847 3 D -14, 3 -0.28700 D -15, 4 -0.2502 D -16, 5 -0.220 D -17, 6 -0.19 D -18, 7 -0.2 D -19/ DATA AAINT5/1.13024 60203 44657 16133 D 0, 1 -0.46471 80646 39872 334 D -2, 2 -0.35137 41338 26932 03 D -3, 3 -0.27681 17872 54518 5 D -4, 4 -0.22205 74525 58107 D -5, 5 -0.18089 14236 5974 D -6, 6 -0.14876 13383 373 D -7, 7 -0.12351 53881 68 D -8, 8 -0.10310 10425 7 D -9, 9 -0.86749 3013 D -11, X -0.73080 054 D -12, 1 -0.62235 61 D -13, 2 -0.52512 8 D -14, 3 -0.45677 D -15, 4 -0.3748 D -16, 5 -0.356 D -17, 6 -0.23 D -18, 7 -0.4 D -19/ DATA ZERO,ONE,TWO/ 0.0 D 0 , 1.0 D 0 , 2.0 D 0 / DATA THREE,FOUR,EIGHT/ 3.0 D 0 , 4.0 D 0 , 8.0 D 0 / DATA NINE,FORTY1,ONEHUN/ 9.0 D 0 , 41.0 D 0 , 100.0 D 0/ DATA NINHUN,FR996/ 900.0 D 0 , 4996.0 D 0 / DATA PIBY4/0.78539 81633 97448 30962 D 0/ DATA PITIM6/18.84955 59215 38759 43078 D 0/ DATA RT2B3P/0.46065 88659 61780 63902 D 0/ DATA AIRZER/0.35502 80538 87817 23926 D 0/ C C Start computation C X = XVALUE C C Compute the machine-dependent constants. C Z = D1MACH(3) XLOW1 = TWO * Z ARG = D1MACH(4) XNEG1 = - ONE / ( ARG ** (TWO/THREE) ) C C Error test C IF ( X .LT. XNEG1 ) THEN CCCCCC CALL ERRPRN(FNNAME,ERRMSG) WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,101)X CALL DPWRST('XXX','BUG ') AIRINT = -TWO / THREE RETURN ENDIF 999 FORMAT(1X) 101 FORMAT('***** ERROR FROM AIRINT--FUNCTION TOO NEGATIVE FOR ', 1 'ACCURATE COMPUTATION, ARGUMENT = ',G15.7) C C continue with machine-dependent constants C T = ARG / ONEHUN IF ( X .GE. ZERO ) THEN DO 10 NTERM1 = 25 , 0 , -1 IF ( ABS(AAINT1(NTERM1)) .GT. T ) GOTO 19 10 CONTINUE 19 DO 20 NTERM2 = 21 , 0 , -1 IF ( ABS(AAINT2(NTERM2)) .GT. T ) GOTO 29 20 CONTINUE 29 XHIGH1 = ( -THREE*LOG(Z)/TWO ) ** (TWO/THREE) ELSE DO 30 NTERM3 = 40 , 0 , -1 IF ( ABS(AAINT3(NTERM3)) .GT. T ) GOTO 39 30 CONTINUE 39 DO 40 NTERM4 = 17 , 0 , -1 IF ( ABS(AAINT4(NTERM4)) .GT. T ) GOTO 49 40 CONTINUE 49 DO 50 NTERM5 = 17 , 0 , -1 IF ( ABS(AAINT5(NTERM5)) .GT. T ) GOTO 59 50 CONTINUE 59 ENDIF C C Code for x >= 0 C IF ( X .GE. ZERO ) THEN IF ( X .LE. FOUR ) THEN IF ( X .LT. XLOW1 ) THEN AIRINT = AIRZER * X ELSE T = X / TWO - ONE AIRINT = CHEVAL(NTERM1,AAINT1,T) * X ENDIF ELSE IF ( X .GT. XHIGH1 ) THEN TEMP = ZERO ELSE Z = ( X + X ) * SQRT(X) / THREE TEMP = THREE * Z T = ( FORTY1 - TEMP ) / ( NINE + TEMP ) TEMP = EXP(-Z) * CHEVAL(NTERM2,AAINT2,T) / SQRT(PITIM6*Z) ENDIF AIRINT = ONE / THREE - TEMP ENDIF ELSE C C Code for x < 0 C IF ( X .GE. -EIGHT ) THEN IF ( X .GT. -XLOW1 ) THEN AIRINT = AIRZER * X ELSE T = -X / FOUR - ONE AIRINT = X * CHEVAL(NTERM3,AAINT3,T) ENDIF ELSE Z = - ( X + X ) * SQRT(-X) / THREE ARG = Z + PIBY4 TEMP = NINE * Z * Z T = ( FR996 - TEMP ) / ( NINHUN + TEMP) GVAL = CHEVAL(NTERM4,AAINT4,T) HVAL = CHEVAL(NTERM5,AAINT5,T) TEMP = GVAL * COS(ARG) + HVAL * SIN(ARG) / Z AIRINT = RT2B3P * TEMP / SQRT(Z) - TWO / THREE ENDIF ENDIF RETURN END DOUBLE PRECISION FUNCTION AIRYGI(XVALUE) C C DESCRIPTION: C C This subroutine computes the modified Airy function Gi(x), C defined as C C AIRYGI(x) = [ Integral{0 to infinity} sin(x*t+t^3/3) dt ] / pi C C The approximation uses Chebyshev expansions with the coefficients C given to 20 decimal places. C C C ERROR RETURNS: C C If x < -XHIGH1*XHIGH1 (see below for definition of XHIGH1), then C the trig. functions needed for the asymptotic expansion of Bi(x) C cannot be computed to any accuracy. An error message is printed C and the code returns the value 0.0. C C C MACHINE-DEPENDENT CONSTANTS: C C NTERM1 - INTEGER - The no. of terms to be used from the array C ARGIP1. The recommended value is such that C ABS(ARGIP1(NTERM1)) < EPS/100 C subject to 1 <= NTERM1 <= 30. C C NTERM2 - INTEGER - The no. of terms to be used from the array C ARGIP2. The recommended value is such that C ABS(ARGIP2(NTERM2)) < EPS/100 C subject to 1 <= NTERM2 <= 29. C C NTERM3 - INTEGER - The no. of terms to be used from the array C ARGIN1. The recommended value is such that C ABS(ARGIN1(NTERM3)) < EPS/100 C subject to 1 <= NTERM3 <= 42. C C NTERM4 - INTEGER - The no. of terms to be used from the array C ARBIN1. The recommended value is such that C ABS(ARBIN1(NTERM4)) < EPS/100 C subject to 1 <= NTERM4 <= 10. C C NTERM5 - INTEGER - The no. of terms to be used from the array C ARBIN2. The recommended value is such that C ABS(ARBIN2(NTERM5)) < EPS/100 C subject to 1 <= NTERM5 <= 11. C C NTERM6 - INTEGER - The no. of terms to be used from the array C ARGH2. The recommended value is such that C ABS(ARHIN1(NTERM6)) < EPS/100 C subject to 1 <= NTERM6 <= 15. C C XLOW1 - DOUBLE PRECISION - The value such that, if -XLOW1 < x < XLOW1, C then AIRYGI = Gi(0) to machine precision. C The recommended value is EPS. C C XHIGH1 - DOUBLE PRECISION - The value such that, if x > XHIGH1, then C AIRYGI = 1/(Pi*x) to machine precision. C Also used for error test - see above. C The recommended value is C cube root( 2/EPS ). C C XHIGH2 - DOUBLE PRECISION - The value above which AIRYGI = 0.0. C The recommended value is C 1/(Pi*XMIN). C C XHIGH3 - DOUBLE PRECISION - The value such that, if x < XHIGH3, C then the Chebyshev expansions for the C asymptotic form of Bi(x) are not needed. C The recommended value is C -8 * cube root( 2/EPSNEG ). C C For values of EPS, EPSNEG, and XMIN refer to the file C MACHCON.TXT. C C The machine-dependent constants are computed internally by C using the D1MACH subroutine. C C C INTRINSIC FUNCTIONS USED: C COS , SIN , SQRT C C C OTHER MISCFUN SUBROUTINES USED: C C CHEVAL , ERRPRN, D1MACH C C C AUTHOR: C Dr. Allan J. Macleod, C Dept. of Mathematics and Statistics, C University of Paisley, C High St., C Paisley, C SCOTLAND. C C (e-mail: macl_ms0@paisley.ac.uk) C C C LATEST UPDATE: C 23 January, 1996 C INTEGER NTERM1,NTERM2,NTERM3,NTERM4,NTERM5,NTERM6 DOUBLE PRECISION ARGIP1(0:30),ARGIP2(0:29),ARGIN1(0:42), 1 ARBIN1(0:10),ARBIN2(0:11),ARHIN1(0:15), 2 ARG,BI,CHEB1,CHEB2,CHEVAL,COSZ,FIVE,FIVE14,FOUR, 3 GIZERO,MINATE,NINE,ONE,ONEBPI,ONEHUN,ONE76,ONE024,PIBY4, 4 RTPIIN,SEVEN,SEVEN2,SINZ,T,TEMP,THREE,TWELHU,TWENT8, 5 X,XCUBE,XHIGH1,XHIGH2,XHIGH3,XLOW1,XMINUS, 6 XVALUE,Z,ZERO,ZETA CCCCC CHARACTER FNNAME*6,ERRMSG*46 CCCCC DATA FNNAME/'AIRYGI'/ CCCCC DATA ERRMSG/'ARGUMENT TOO NEGATIVE FOR ACCURATE COMPUTATION'/ C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOMC.INC' CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C DATA ARGIP1(0)/ 0.26585 77079 50227 45082 D 0/ DATA ARGIP1(1)/ -0.10500 33309 75019 22907 D 0/ DATA ARGIP1(2)/ 0.84134 74753 28454 492 D -2/ DATA ARGIP1(3)/ 0.20210 67387 81343 9541 D -1/ DATA ARGIP1(4)/ -0.15595 76113 86355 2234 D -1/ DATA ARGIP1(5)/ 0.56434 29390 43256 481 D -2/ DATA ARGIP1(6)/ -0.59776 84482 66558 09 D -3/ DATA ARGIP1(7)/ -0.42833 85026 48677 28 D -3/ DATA ARGIP1(8)/ 0.22605 66238 09090 27 D -3/ DATA ARGIP1(9)/ -0.36083 32945 59226 0 D -4/ DATA ARGIP1(10)/-0.78551 89887 88901 D -5/ DATA ARGIP1(11)/ 0.47325 24807 46370 D -5/ DATA ARGIP1(12)/-0.59743 51397 7694 D -6/ DATA ARGIP1(13)/-0.15917 60916 5602 D -6/ DATA ARGIP1(14)/ 0.63361 29065 570 D -7/ DATA ARGIP1(15)/-0.27609 02326 48 D -8/ DATA ARGIP1(16)/-0.25606 41540 85 D -8/ DATA ARGIP1(17)/ 0.47798 67685 6 D -9/ DATA ARGIP1(18)/ 0.44881 31863 D -10/ DATA ARGIP1(19)/-0.23465 08882 D -10/ DATA ARGIP1(20)/ 0.76839 085 D -12/ DATA ARGIP1(21)/ 0.73227 985 D -12/ DATA ARGIP1(22)/-0.85136 87 D -13/ DATA ARGIP1(23)/-0.16302 01 D -13/ DATA ARGIP1(24)/ 0.35676 9 D -14/ DATA ARGIP1(25)/ 0.25001 D -15/ DATA ARGIP1(26)/-0.10859 D -15/ DATA ARGIP1(27)/-0.158 D -17/ DATA ARGIP1(28)/ 0.275 D -17/ DATA ARGIP1(29)/-0.5 D -19/ DATA ARGIP1(30)/-0.6 D -19/ DATA ARGIP2(0)/ 2.00473 71227 58014 86391 D 0/ DATA ARGIP2(1)/ 0.29418 41393 64406 724 D -2/ DATA ARGIP2(2)/ 0.71369 24900 63401 67 D -3/ DATA ARGIP2(3)/ 0.17526 56343 05022 67 D -3/ DATA ARGIP2(4)/ 0.43591 82094 02988 2 D -4/ DATA ARGIP2(5)/ 0.10926 26947 60430 7 D -4/ DATA ARGIP2(6)/ 0.27238 24183 99029 D -5/ DATA ARGIP2(7)/ 0.66230 90094 7687 D -6/ DATA ARGIP2(8)/ 0.15425 32337 0315 D -6/ DATA ARGIP2(9)/ 0.34184 65242 306 D -7/ DATA ARGIP2(10)/ 0.72815 77248 94 D -8/ DATA ARGIP2(11)/ 0.15158 85254 52 D -8/ DATA ARGIP2(12)/ 0.30940 04803 9 D -9/ DATA ARGIP2(13)/ 0.61496 72614 D -10/ DATA ARGIP2(14)/ 0.12028 77045 D -10/ DATA ARGIP2(15)/ 0.23369 0586 D -11/ DATA ARGIP2(16)/ 0.43778 068 D -12/ DATA ARGIP2(17)/ 0.79964 47 D -13/ DATA ARGIP2(18)/ 0.14940 75 D -13/ DATA ARGIP2(19)/ 0.24679 0 D -14/ DATA ARGIP2(20)/ 0.37672 D -15/ DATA ARGIP2(21)/ 0.7701 D -16/ DATA ARGIP2(22)/ 0.354 D -17/ DATA ARGIP2(23)/-0.49 D -18/ DATA ARGIP2(24)/ 0.62 D -18/ DATA ARGIP2(25)/-0.40 D -18/ DATA ARGIP2(26)/-0.1 D -19/ DATA ARGIP2(27)/ 0.2 D -19/ DATA ARGIP2(28)/-0.3 D -19/ DATA ARGIP2(29)/ 0.1 D -19/ DATA ARGIN1(0)/ -0.20118 96505 67320 89130 D 0/ DATA ARGIN1(1)/ -0.72441 75303 32453 0499 D -1/ DATA ARGIN1(2)/ 0.45050 18923 89478 0120 D -1/ DATA ARGIN1(3)/ -0.24221 37112 20787 91099 D 0/ DATA ARGIN1(4)/ 0.27178 84964 36167 8294 D -1/ DATA ARGIN1(5)/ -0.57293 21004 81817 9697 D -1/ DATA ARGIN1(6)/ -0.18382 10786 03377 63587 D 0/ DATA ARGIN1(7)/ 0.77515 46082 14947 5511 D -1/ DATA ARGIN1(8)/ 0.18386 56473 39275 60387 D 0/ DATA ARGIN1(9)/ 0.29215 04250 18556 7173 D -1/ DATA ARGIN1(10)/-0.61422 94846 78801 8811 D -1/ DATA ARGIN1(11)/-0.29993 12505 79461 6238 D -1/ DATA ARGIN1(12)/ 0.58593 71183 27706 636 D -2/ DATA ARGIN1(13)/ 0.82222 16584 97402 529 D -2/ DATA ARGIN1(14)/ 0.13257 98171 66846 893 D -2/ DATA ARGIN1(15)/-0.96248 31076 65651 26 D -3/ DATA ARGIN1(16)/-0.45065 51599 82118 07 D -3/ DATA ARGIN1(17)/ 0.77242 34743 25474 D -5/ DATA ARGIN1(18)/ 0.54818 74134 75805 2 D -4/ DATA ARGIN1(19)/ 0.12458 98039 74287 6 D -4/ DATA ARGIN1(20)/-0.24619 68910 92083 D -5/ DATA ARGIN1(21)/-0.16915 41835 45285 D -5/ DATA ARGIN1(22)/-0.16769 15316 9442 D -6/ DATA ARGIN1(23)/ 0.96365 09337 672 D -7/ DATA ARGIN1(24)/ 0.32533 14928 030 D -7/ DATA ARGIN1(25)/ 0.50918 04231 D -10/ DATA ARGIN1(26)/-0.20918 04535 53 D -8/ DATA ARGIN1(27)/-0.41237 38787 0 D -9/ DATA ARGIN1(28)/ 0.41633 38253 D -10/ DATA ARGIN1(29)/ 0.30325 32117 D -10/ DATA ARGIN1(30)/ 0.34058 0529 D -11/ DATA ARGIN1(31)/-0.88444 592 D -12/ DATA ARGIN1(32)/-0.31639 612 D -12/ DATA ARGIN1(33)/-0.15050 76 D -13/ DATA ARGIN1(34)/ 0.11041 48 D -13/ DATA ARGIN1(35)/ 0.24650 8 D -14/ DATA ARGIN1(36)/-0.3107 D -16/ DATA ARGIN1(37)/-0.9851 D -16/ DATA ARGIN1(38)/-0.1453 D -16/ DATA ARGIN1(39)/ 0.118 D -17/ DATA ARGIN1(40)/ 0.67 D -18/ DATA ARGIN1(41)/ 0.6 D -19/ DATA ARGIN1(42)/-0.1 D -19/ DATA ARBIN1/1.99983 76358 35861 55980 D 0, 1 -0.81046 60923 66941 8 D -4, 2 0.13475 66598 4689 D -6, 3 -0.70855 84714 3 D -9, 4 0.74818 4187 D -11, 5 -0.12902 774 D -12, 6 0.32250 4 D -14, 7 -0.10809 D -15, 8 0.460 D -17, 9 -0.24 D -18, X 0.1 D -19/ DATA ARBIN2/0.13872 35645 38791 20276 D 0, 1 -0.82392 86225 55822 8 D -4, 2 0.26720 91950 9866 D -6, 3 -0.20742 36853 68 D -8, 4 0.28733 92593 D -10, 5 -0.60873 521 D -12, 6 0.17924 89 D -13, 7 -0.68760 D -15, 8 0.3280 D -16, 9 -0.188 D -17, X 0.13 D -18, 1 -0.1 D -19/ DATA ARHIN1/1.99647 72039 97796 50525 D 0, 1 -0.18756 37794 07173 213 D -2, 2 -0.12186 47089 77873 39 D -3, 3 -0.81402 16096 59287 D -5, 4 -0.55050 92595 3537 D -6, 5 -0.37630 08043 303 D -7, 6 -0.25885 83623 65 D -8, 7 -0.17931 82926 5 D -9, 8 -0.12459 16873 D -10, 9 -0.87171 247 D -12, X -0.60849 43 D -13, 1 -0.43117 8 D -14, 2 -0.29787 D -15, 3 -0.2210 D -16, 4 -0.136 D -17, 5 -0.14 D -18/ DATA ZERO,ONE,THREE,FOUR/ 0.0 D 0 , 1.0 D 0 , 3.0 D 0 , 4.0 D 0 / DATA FIVE,SEVEN,MINATE/ 5.0 D 0 , 7.0 D 0 , -8.0 D 0 / DATA NINE,TWENT8,SEVEN2/ 9.0 D 0 , 28.0 D 0 , 72.0 D 0 / DATA ONEHUN,ONE76,FIVE14/ 100.0 D 0 , 176.0 D 0 , 514.0 D 0 / DATA ONE024,TWELHU/ 1024.0 D 0 , 1200.0 D 0 / DATA GIZERO/0.20497 55424 82000 24505 D 0/ DATA ONEBPI/0.31830 98861 83790 67154 D 0/ DATA PIBY4/0.78539 81633 97448 30962 D 0/ DATA RTPIIN/0.56418 95835 47756 28695 D 0/ C C Start computation C X = XVALUE C C Compute the machine-dependent constants. C Z = D1MACH(3) XLOW1 = Z ARG = D1MACH(4) XHIGH1 = ONE / ARG XHIGH1 = ( XHIGH1 + XHIGH1 ) ** (ONE/THREE) C C Error test C IF ( X .LT. -XHIGH1*XHIGH1 ) THEN CCCCC CALL ERRPRN(FNNAME,ERRMSG) WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,101)X CALL DPWRST('XXX','BUG ') AIRYGI = ZERO RETURN ENDIF 999 FORMAT(1X) 101 FORMAT('***** ERROR FROM AIRYGI--ARGUMENT TOO NEGATIVE ', 1 'FOR ACCURATE COMPUTATION, ARGUMENT = ',G15.7) C C continue with machine-dependent constants C T = ARG / ONEHUN IF ( X .GE. ZERO ) THEN DO 10 NTERM1 = 30 , 0 , -1 IF ( ABS(ARGIP1(NTERM1)) .GT. T ) GOTO 19 10 CONTINUE 19 DO 20 NTERM2 = 29 , 0 , -1 IF ( ABS(ARGIP2(NTERM2)) .GT. T ) GOTO 29 20 CONTINUE 29 TEMP = FOUR * PIBY4 XHIGH2 = ONE / ( TEMP * D1MACH(1) ) ELSE DO 30 NTERM3 = 42 , 0 , -1 IF ( ABS(ARGIN1(NTERM3)) .GT. T ) GOTO 39 30 CONTINUE 39 DO 40 NTERM4 = 10 , 0 , -1 IF ( ABS(ARBIN1(NTERM4)) .GT. T ) GOTO 49 40 CONTINUE 49 DO 50 NTERM5 = 11 , 0 , -1 IF ( ABS(ARBIN2(NTERM5)) .GT. T ) GOTO 59 50 CONTINUE 59 DO 60 NTERM6 = 15 , 0 , -1 IF ( ABS(ARHIN1(NTERM6)) .GT. T ) GOTO 69 60 CONTINUE 69 TEMP = ONE / Z XHIGH3 = MINATE * ( TEMP + TEMP ) ** (ONE/THREE) ENDIF C C Code for x >= 0.0 C IF ( X .GE. ZERO ) THEN IF ( X .LE. SEVEN ) THEN IF ( X .LT. XLOW1 ) THEN AIRYGI = GIZERO ELSE T = ( NINE * X - TWENT8 ) / ( X + TWENT8 ) AIRYGI = CHEVAL ( NTERM1 , ARGIP1 , T ) ENDIF ELSE IF ( X .GT. XHIGH1 ) THEN IF ( X .GT. XHIGH2 ) THEN AIRYGI = ZERO ELSE AIRYGI = ONEBPI/X ENDIF ELSE XCUBE = X * X * X T = ( TWELHU - XCUBE ) / ( FIVE14 + XCUBE ) AIRYGI = ONEBPI * CHEVAL(NTERM2,ARGIP2,T) / X ENDIF ENDIF ELSE C C Code for x < 0.0 C IF ( X .GE. MINATE ) THEN IF ( X .GT. -XLOW1 ) THEN AIRYGI = GIZERO ELSE T = -( X + FOUR ) / FOUR AIRYGI = CHEVAL(NTERM3,ARGIN1,T) ENDIF ELSE XMINUS = -X T = XMINUS * SQRT(XMINUS) ZETA = ( T + T ) / THREE TEMP = RTPIIN / SQRT(SQRT(XMINUS)) COSZ = COS ( ZETA + PIBY4 ) SINZ = SIN ( ZETA + PIBY4 ) / ZETA XCUBE = X * X * X IF ( X .GT. XHIGH3 ) THEN T = - ( ONE024 / ( XCUBE ) + ONE ) CHEB1 = CHEVAL(NTERM4,ARBIN1,T) CHEB2 = CHEVAL(NTERM5,ARBIN2,T) BI = ( COSZ * CHEB1 + SINZ * CHEB2 ) * TEMP ELSE BI = ( COSZ + SINZ * FIVE / SEVEN2 ) * TEMP ENDIF T = ( XCUBE + TWELHU ) / ( ONE76 - XCUBE ) AIRYGI = BI + CHEVAL(NTERM6,ARHIN1,T) * ONEBPI / X ENDIF ENDIF RETURN END DOUBLE PRECISION FUNCTION AIRYHI(XVALUE) C C DESCRIPTION: C C This subroutine computes the modified Airy function Hi(x), C defined as C C AIRYHI(x) = [ Integral{0 to infinity} exp(x*t-t^3/3) dt ] / pi C C The approximation uses Chebyshev expansions with the coefficients C given to 20 decimal places. C C C ERROR RETURNS: C C If x > XHIGH1 (see below for definition of XHIGH1), then C the asymptotic expansion of Hi(x) will cause an overflow. C An error message is printed and the code returns the largest C floating-pt number as the result. C C C MACHINE-DEPENDENT CONSTANTS: C C NTERM1 - INTEGER - The no. of terms to be used from the array C ARHIP. The recommended value is such that C ABS(ARHIP(NTERM1)) < EPS/100 C subject to 1 <= NTERM1 <= 31. C C NTERM2 - INTEGER - The no. of terms to be used from the array C ARBIP. The recommended value is such that C ABS(ARBIP(NTERM2)) < EPS/100 C subject to 1 <= NTERM2 <= 23. C C NTERM3 - INTEGER - The no. of terms to be used from the array C ARGIP. The recommended value is such that C ABS(ARGIP1(NTERM3)) < EPS/100 C subject to 1 <= NTERM3 <= 29. C C NTERM4 - INTEGER - The no. of terms to be used from the array C ARHIN1. The recommended value is such that C ABS(ARHIN1(NTERM4)) < EPS/100 C subject to 1 <= NTERM4 <= 21. C C NTERM5 - INTEGER - The no. of terms to be used from the array C ARHIN2. The recommended value is such that C ABS(ARHIN2(NTERM5)) < EPS/100 C subject to 1 <= NTERM5 <= 15. C C XLOW1 - DOUBLE PRECISION - The value such that, if -XLOW1 < x < XLOW1, C then AIRYGI = Hi(0) to machine precision. C The recommended value is EPS. C C XHIGH1 - DOUBLE PRECISION - The value such that, if x > XHIGH1, then C overflow might occur. The recommended value is C computed as follows: C compute Z = 1.5*LOG(XMAX) C XHIGH1 = ( Z + LOG(Z)/4 + LOG(PI)/2 )**(2/3) C C XNEG1 - DOUBLE PRECISION - The value below which AIRYHI = 0.0. C The recommended value is C -1/(Pi*XMIN). C C XNEG2 - DOUBLE PRECISION - The value such that, if x < XNEG2, then C AIRYHI = -1/(Pi*x) to machine precision. C The recommended value is C -cube root( 2/EPS ). C C XMAX - DOUBLE PRECISION - The largest possible floating-pt. number. C This is the value given to the function C if x > XHIGH1. C C For values of EPS, EPSNEG, XMIN and XMAX refer to the file C MACHCON.TXT. C C The machine-dependent constants are computed internally by C using the D1MACH subroutine. C C C INTRINSIC FUNCTIONS USED: C EXP , LOG , SQRT C C C OTHER MISCFUN SUBROUTINES USED: C C CHEVAL , ERRPRN, D1MACH C C C AUTHOR: C Dr. Allan J. Macleod, C Dept. of Mathematics and Statistics, C University of Paisley, C High St., C Paisley, C SCOTLAND. C C (e-mail: macl_ms0@paisley.ac.uk) C C C LATEST UPDATE: C 23 January, 1996 C INTEGER NTERM1,NTERM2,NTERM3,NTERM4,NTERM5 DOUBLE PRECISION ARHIP(0:31),ARBIP(0:23),ARGIP1(0:29), 1 ARHIN1(0:21),ARHIN2(0:15), 2 BI,CHEVAL,FIVE14,FOUR,GI,HIZERO,LNRTPI, 3 MINATE,ONE,ONEBPI,ONEHUN,ONE76,SEVEN,T,TEMP, 4 THREE,THRE43,TWELHU,TWELVE,TWO,X,XCUBE, 5 XHIGH1,XLOW1,XMAX,XNEG1,XNEG2,XVALUE, 6 Z,ZERO,ZETA CCCCC CHARACTER FNNAME*6,ERRMSG*30 CCCCC DATA FNNAME/'AIRYHI'/ CCCCC DATA ERRMSG/'ARGUMENT TO FUNCTION TOO LARGE'/ C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOMC.INC' CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C DATA ARHIP(0)/ 1.24013 56256 17628 31114 D 0/ DATA ARHIP(1)/ 0.64856 34197 39265 35804 D 0/ DATA ARHIP(2)/ 0.55236 25259 21149 03246 D 0/ DATA ARHIP(3)/ 0.20975 12207 38575 66794 D 0/ DATA ARHIP(4)/ 0.12025 66911 80523 73568 D 0/ DATA ARHIP(5)/ 0.37682 24931 09539 3785 D -1/ DATA ARHIP(6)/ 0.16510 88671 54807 1651 D -1/ DATA ARHIP(7)/ 0.45592 27552 11570 993 D -2/ DATA ARHIP(8)/ 0.16182 84804 77635 013 D -2/ DATA ARHIP(9)/ 0.40841 28250 81266 63 D -3/ DATA ARHIP(10)/0.12196 47972 13940 51 D -3/ DATA ARHIP(11)/0.28650 64098 65761 0 D -4/ DATA ARHIP(12)/0.74222 15564 24344 D -5/ DATA ARHIP(13)/0.16353 62319 32831 D -5/ DATA ARHIP(14)/0.37713 90818 8749 D -6/ DATA ARHIP(15)/0.78158 00336 008 D -7/ DATA ARHIP(16)/0.16384 47121 370 D -7/ DATA ARHIP(17)/0.31985 76659 92 D -8/ DATA ARHIP(18)/0.61933 90530 7 D -9/ DATA ARHIP(19)/0.11411 16119 1 D -9/ DATA ARHIP(20)/0.20649 23454 D -10/ DATA ARHIP(21)/0.36001 8664 D -11/ DATA ARHIP(22)/0.61401 849 D -12/ DATA ARHIP(23)/0.10162 125 D -12/ DATA ARHIP(24)/0.16437 01 D -13/ DATA ARHIP(25)/0.25908 4 D -14/ DATA ARHIP(26)/0.39931 D -15/ DATA ARHIP(27)/0.6014 D -16/ DATA ARHIP(28)/0.886 D -17/ DATA ARHIP(29)/0.128 D -17/ DATA ARHIP(30)/0.18 D -18/ DATA ARHIP(31)/0.3 D -19/ DATA ARBIP(0)/ 2.00582 13820 97590 64905 D 0/ DATA ARBIP(1)/ 0.29447 84491 70441 549 D -2/ DATA ARBIP(2)/ 0.34897 54514 77535 5 D -4/ DATA ARBIP(3)/ 0.83389 73337 4343 D -6/ DATA ARBIP(4)/ 0.31362 15471 813 D -7/ DATA ARBIP(5)/ 0.16786 53060 15 D -8/ DATA ARBIP(6)/ 0.12217 93405 9 D -9/ DATA ARBIP(7)/ 0.11915 84139 D -10/ DATA ARBIP(8)/ 0.15414 2553 D -11/ DATA ARBIP(9)/ 0.24844 455 D -12/ DATA ARBIP(10)/ 0.42130 12 D -13/ DATA ARBIP(11)/ 0.50529 3 D -14/ DATA ARBIP(12)/-0.60032 D -15/ DATA ARBIP(13)/-0.65474 D -15/ DATA ARBIP(14)/-0.22364 D -15/ DATA ARBIP(15)/-0.3015 D -16/ DATA ARBIP(16)/ 0.959 D -17/ DATA ARBIP(17)/ 0.616 D -17/ DATA ARBIP(18)/ 0.97 D -18/ DATA ARBIP(19)/-0.37 D -18/ DATA ARBIP(20)/-0.21 D -18/ DATA ARBIP(21)/-0.1 D -19/ DATA ARBIP(22)/ 0.2 D -19/ DATA ARBIP(23)/ 0.1 D -19/ DATA ARGIP1(0)/ 2.00473 71227 58014 86391 D 0/ DATA ARGIP1(1)/ 0.29418 41393 64406 724 D -2/ DATA ARGIP1(2)/ 0.71369 24900 63401 67 D -3/ DATA ARGIP1(3)/ 0.17526 56343 05022 67 D -3/ DATA ARGIP1(4)/ 0.43591 82094 02988 2 D -4/ DATA ARGIP1(5)/ 0.10926 26947 60430 7 D -4/ DATA ARGIP1(6)/ 0.27238 24183 99029 D -5/ DATA ARGIP1(7)/ 0.66230 90094 7687 D -6/ DATA ARGIP1(8)/ 0.15425 32337 0315 D -6/ DATA ARGIP1(9)/ 0.34184 65242 306 D -7/ DATA ARGIP1(10)/ 0.72815 77248 94 D -8/ DATA ARGIP1(11)/ 0.15158 85254 52 D -8/ DATA ARGIP1(12)/ 0.30940 04803 9 D -9/ DATA ARGIP1(13)/ 0.61496 72614 D -10/ DATA ARGIP1(14)/ 0.12028 77045 D -10/ DATA ARGIP1(15)/ 0.23369 0586 D -11/ DATA ARGIP1(16)/ 0.43778 068 D -12/ DATA ARGIP1(17)/ 0.79964 47 D -13/ DATA ARGIP1(18)/ 0.14940 75 D -13/ DATA ARGIP1(19)/ 0.24679 0 D -14/ DATA ARGIP1(20)/ 0.37672 D -15/ DATA ARGIP1(21)/ 0.7701 D -16/ DATA ARGIP1(22)/ 0.354 D -17/ DATA ARGIP1(23)/-0.49 D -18/ DATA ARGIP1(24)/ 0.62 D -18/ DATA ARGIP1(25)/-0.40 D -18/ DATA ARGIP1(26)/-0.1 D -19/ DATA ARGIP1(27)/ 0.2 D -19/ DATA ARGIP1(28)/-0.3 D -19/ DATA ARGIP1(29)/ 0.1 D -19/ DATA ARHIN1(0)/ 0.31481 01720 64234 04116 D 0/ DATA ARHIN1(1)/ -0.16414 49921 65889 64341 D 0/ DATA ARHIN1(2)/ 0.61766 51597 73091 3071 D -1/ DATA ARHIN1(3)/ -0.19718 81185 93593 3028 D -1/ DATA ARHIN1(4)/ 0.53690 28300 23331 343 D -2/ DATA ARHIN1(5)/ -0.12497 70684 39663 038 D -2/ DATA ARHIN1(6)/ 0.24835 51559 69949 33 D -3/ DATA ARHIN1(7)/ -0.41870 24096 74663 0 D -4/ DATA ARHIN1(8)/ 0.59094 54379 79124 D -5/ DATA ARHIN1(9)/ -0.68063 54118 4345 D -6/ DATA ARHIN1(10)/ 0.60728 97629 164 D -7/ DATA ARHIN1(11)/-0.36713 03492 42 D -8/ DATA ARHIN1(12)/ 0.70780 17552 D -10/ DATA ARHIN1(13)/ 0.11878 94334 D -10/ DATA ARHIN1(14)/-0.12089 8723 D -11/ DATA ARHIN1(15)/ 0.11896 56 D -13/ DATA ARHIN1(16)/ 0.59412 8 D -14/ DATA ARHIN1(17)/-0.32257 D -15/ DATA ARHIN1(18)/-0.2290 D -16/ DATA ARHIN1(19)/ 0.253 D -17/ DATA ARHIN1(20)/ 0.9 D -19/ DATA ARHIN1(21)/-0.2 D -19/ DATA ARHIN2/1.99647 72039 97796 50525 D 0, 1 -0.18756 37794 07173 213 D -2, 2 -0.12186 47089 77873 39 D -3, 3 -0.81402 16096 59287 D -5, 4 -0.55050 92595 3537 D -6, 5 -0.37630 08043 303 D -7, 6 -0.25885 83623 65 D -8, 7 -0.17931 82926 5 D -9, 8 -0.12459 16873 D -10, 9 -0.87171 247 D -12, X -0.60849 43 D -13, 1 -0.43117 8 D -14, 2 -0.29787 D -15, 3 -0.2210 D -16, 4 -0.136 D -17, 5 -0.14 D -18/ DATA ZERO,ONE,TWO/ 0.0 D 0 , 1.0 D 0 , 2.0 D 0/ DATA THREE,FOUR,SEVEN/ 3.0 D 0 , 4.0 D 0 , 7.0 D 0 / DATA MINATE,TWELVE,ONE76/ -8.0 D 0 , 12.0 D 0 , 176.0 D 0 / DATA THRE43,FIVE14,TWELHU/ 343.0 D 0 , 514.0 D 0 , 1200.0 D 0 / DATA ONEHUN/100.0 D 0/ DATA HIZERO/0.40995 10849 64000 49010 D 0/ DATA LNRTPI/0.57236 49429 24700 08707 D 0/ DATA ONEBPI/0.31830 98861 83790 67154 D 0/ C C Start computation C X = XVALUE C C Compute the machine-dependent constants. C XMAX = D1MACH(2) TEMP = THREE * LOG(XMAX) / TWO ZETA = ( TEMP + LOG(TEMP)/FOUR - LOG(ONEBPI)/TWO ) XHIGH1 = ZETA ** (TWO/THREE) C C Error test C IF ( X .GT. XHIGH1 ) THEN CCCCC CALL ERRPRN(FNNAME,ERRMSG) WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,101)X CALL DPWRST('XXX','BUG ') AIRYHI = XMAX RETURN ENDIF 999 FORMAT(1X) 101 FORMAT('***** ERROR FROM AIRYHI--ARGUMENT TO FUNCTION ', 1 'TOO LARGE, ARGUMENT = ',G15.7) C C continue with machine-dependent constants C Z = D1MACH(3) XLOW1 = Z T = Z / ONEHUN IF ( X .GE. ZERO ) THEN DO 10 NTERM1 = 31 , 0 , -1 IF ( ABS(ARHIP(NTERM1)) .GT. T ) GOTO 19 10 CONTINUE 19 DO 20 NTERM2 = 23 , 0 , -1 IF ( ABS(ARBIP(NTERM2)) .GT. T ) GOTO 29 20 CONTINUE 29 DO 30 NTERM3 = 29 , 0 , -1 IF ( ABS(ARGIP1(NTERM3)) .GT. T ) GOTO 39 30 CONTINUE 39 CONTINUE ELSE DO 40 NTERM4 = 21 , 0 , -1 IF ( ABS(ARHIN1(NTERM4)) .GT. T ) GOTO 49 40 CONTINUE 49 DO 50 NTERM5 = 15 , 0 , -1 IF ( ABS(ARHIN2(NTERM5)) .GT. T ) GOTO 59 50 CONTINUE 59 TEMP = ONE / ONEBPI XNEG1 = - ONE / ( TEMP * D1MACH(1) ) XNEG2 = - ( ( TWO / Z ) ** (ONE/THREE) ) ENDIF C C Code for x >= 0.0 C IF ( X .GE. ZERO ) THEN IF ( X .LE. SEVEN ) THEN IF ( X .LT. XLOW1 ) THEN AIRYHI = HIZERO ELSE T = ( X + X ) / SEVEN - ONE TEMP = ( X + X + X ) / TWO AIRYHI = EXP(TEMP) * CHEVAL(NTERM1,ARHIP,T) ENDIF ELSE XCUBE = X * X * X TEMP = SQRT(XCUBE) ZETA = ( TEMP + TEMP ) / THREE T = TWO * ( SQRT(THRE43/XCUBE) ) - ONE TEMP = CHEVAL(NTERM2,ARBIP,T) TEMP = ZETA + LOG(TEMP) - LOG(X) / FOUR - LNRTPI BI = EXP(TEMP) T = ( TWELHU - XCUBE ) / ( XCUBE + FIVE14 ) GI = CHEVAL(NTERM3,ARGIP1,T) * ONEBPI / X AIRYHI = BI - GI ENDIF ELSE C C Code for x < 0.0 C IF ( X .GE. MINATE ) THEN IF ( X .GT. -XLOW1 ) THEN AIRYHI = HIZERO ELSE T = ( FOUR * X + TWELVE ) / ( X - TWELVE ) AIRYHI = CHEVAL(NTERM4,ARHIN1,T) ENDIF ELSE IF ( X .LT. XNEG1 ) THEN AIRYHI = ZERO ELSE IF ( X .LT. XNEG2 ) THEN TEMP = ONE ELSE XCUBE = X * X * X T = ( XCUBE + TWELHU ) / ( ONE76 - XCUBE ) TEMP = CHEVAL(NTERM5,ARHIN2,T) ENDIF AIRYHI = - TEMP * ONEBPI / X ENDIF ENDIF ENDIF RETURN END FUNCTION ALI (X) C***BEGIN PROLOGUE ALI C***PURPOSE Compute the logarithmic integral. C***LIBRARY SLATEC (FNLIB) C***CATEGORY C5 C***TYPE SINGLE PRECISION (ALI-S, DLI-D) C***KEYWORDS FNLIB, LOGARITHMIC INTEGRAL, SPECIAL FUNCTIONS C***AUTHOR Fullerton, W., (LANL) C***DESCRIPTION C C ALI(X) computes the logarithmic integral; i.e., the C integral from 0.0 to X of (1.0/ln(t))dt. C C***REFERENCES (NONE) C***ROUTINES CALLED EI, XERMSG C***REVISION HISTORY (YYMMDD) C 770601 DATE WRITTEN C 890531 Changed all specific intrinsics to generic. (WRB) C 890531 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) C 900326 Removed duplicate information from DESCRIPTION section. C (WRB) C***END PROLOGUE ALI C***FIRST EXECUTABLE STATEMENT ALI C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOMC.INC' CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C IF (X .LE. 0.0) THEN WRITE(ICOUT,1) CALL DPWRST('XXX','BUG ') 1 FORMAT('***** ERORR FROM ALI, THE LOG INTEGRAL IS UNDEFINED ', 1 'FOR NON-POSITIVE X. *****') RETURN ENDIF IF (X .EQ. 1.0) THEN WRITE(ICOUT,2) 2 FORMAT('***** ERORR FROM ALI, THE LOG INTEGRAL IS UNDEFINED ', 1 'FOR X = 1. *****') CALL DPWRST('XXX','BUG ') RETURN ENDIF C ALI = EI (LOG(X) ) C RETURN END FUNCTION ALNREL(X) C***BEGIN PROLOGUE ALNREL C***DATE WRITTEN 770401 (YYMMDD) C***REVISION DATE 820801 (YYMMDD) C***CATEGORY NO. C4B C***KEYWORDS ELEMENTARY FUNCTION,LOGARITHM,RELATIVE C***AUTHOR FULLERTON, W., (LANL) C***PURPOSE Evaluates ln(1+X) accurate in the sense of relative error. C***DESCRIPTION C C ALNREL(X) evaluates ln(1+X) accurately in the sense of relative C error when X is very small. This routine must be used to C maintain relative error accuracy whenever X is small and C accurately known. C C Series for ALNR on the interval -3.75000D-01 to 3.75000D-01 C with weighted error 1.93E-17 C log weighted error 16.72 C significant figures required 16.44 C decimal places required 17.40 C***REFERENCES (NONE) C***ROUTINES CALLED CSEVL,INITS,R1MACH,XERROR C***END PROLOGUE ALNREL DIMENSION ALNRCS(23) C INCLUDE 'DPCOMC.INC' CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C DATA ALNRCS( 1) / 1.0378693562 743770E0 / DATA ALNRCS( 2) / -.1336430150 4908918E0 / DATA ALNRCS( 3) / .0194082491 35520563E0 / DATA ALNRCS( 4) / -.0030107551 12753577E0 / DATA ALNRCS( 5) / .0004869461 47971548E0 / DATA ALNRCS( 6) / -.0000810548 81893175E0 / DATA ALNRCS( 7) / .0000137788 47799559E0 / DATA ALNRCS( 8) / -.0000023802 21089435E0 / DATA ALNRCS( 9) / .0000004164 04162138E0 / DATA ALNRCS(10) / -.0000000735 95828378E0 / DATA ALNRCS(11) / .0000000131 17611876E0 / DATA ALNRCS(12) / -.0000000023 54670931E0 / DATA ALNRCS(13) / .0000000004 25227732E0 / DATA ALNRCS(14) / -.0000000000 77190894E0 / DATA ALNRCS(15) / .0000000000 14075746E0 / DATA ALNRCS(16) / -.0000000000 02576907E0 / DATA ALNRCS(17) / .0000000000 00473424E0 / DATA ALNRCS(18) / -.0000000000 00087249E0 / DATA ALNRCS(19) / .0000000000 00016124E0 / DATA ALNRCS(20) / -.0000000000 00002987E0 / DATA ALNRCS(21) / .0000000000 00000554E0 / DATA ALNRCS(22) / -.0000000000 00000103E0 / DATA ALNRCS(23) / .0000000000 00000019E0 / DATA NLNREL, XMIN /0, 0./ C***FIRST EXECUTABLE STATEMENT ALNREL IF (NLNREL.NE.0) GO TO 10 NLNREL = INITS (ALNRCS, 23, 0.1*R1MACH(3)) XMIN = -1.0 + SQRT(R1MACH(4)) C 10 IF (X.LE.(-1.0)) THEN CCCCC CALL XERROR ( 'ALNREL X IS LE -1', 18, 2, 2) WRITE(ICOUT,101) CALL DPWRST('XXX','BUG ') RETURN ENDIF 101 FORMAT('***** INTERNAL ERROR FROM ALNREL: ARGUMENT LESS THAN ', 1'OR EQUAL TO -1') IF (X.LT.XMIN) THEN CCCCC CALL XERROR ( 'ALNREL ANSWER LT HALF PRECISION BEC CCCCC1AUSE X TOO NEAR -1', 54, 1, 1) WRITE(ICOUT,102) CALL DPWRST('XXX','BUG ') CCCCC RETURN ENDIF 102 FORMAT('***** INTERNAL WARNING FROM ALNREL: ANSWER IS LESS THAN' 1,' HALF PRECISION BECAUSE ARGUMENT TOO NEAR -1') C IF (ABS(X).LE.0.375) ALNREL = X*(1. - 1 X*CSEVL (X/.375, ALNRCS, NLNREL)) IF (ABS(X).GT.0.375) ALNREL = LOG (1.0+X) C RETURN END DOUBLE PRECISION FUNCTION ALNORM(X, UPPER) C C EVALUATES THE TAIL AREA OF THE STANDARDIZED NORMAL CURVE FROM C X TO INFINITY IF UPPER IS .TRUE. OR FROM MINUS INFINITY TO X C IF UPPER IS .FALSE. C C NOTE NOVEMBER 2001: MODIFY UTZERO. ALTHOUGH NOT NECESSARY C WHEN USING ALNORM FOR SIMPLY COMPUTING PERCENT POINTS, C EXTENDING RANGE IS HELPFUL FOR USE WITH FUNCTIONS THAT C USE ALNORM IN INTERMEDIATE COMPUTATIONS. C DOUBLE PRECISION LTONE,UTZERO,ZERO,HALF,ONE,CON, $ A1,A2,A3,A4,A5,A6,A7,B1,B2, $ B3,B4,B5,B6,B7,B8,B9,B10,B11,B12,X,Y,Z,ZEXP LOGICAL UPPER,UP C C LTONE AND UTZERO MUST BE SET TO SUIT THE PARTICULAR COMPUTER C CCCCC DATA LTONE, UTZERO /7.0D0, 18.66D0/ DATA LTONE, UTZERO /7.0D0, 38.00D0/ CCCCC DATA LTONE, UTZERO /7.0D0, 100.00D0/ DATA ZERO,HALF,ONE,CON /0.0D0,0.5D0,1.0D0,1.28D0/ DATA A1, A2, A3, $ A4, A5, A6, $ A7 $ /0.398942280444D0, 0.399903438504D0, 5.75885480458D0, $ 29.8213557808D0, 2.62433121679D0, 48.6959930692D0, $ 5.92885724438D0/ DATA B1, B2, B3, $ B4, B5, B6, $ B7, B8, B9, $ B10, B11, B12 $ /0.398942280385D0, 3.8052D-8, 1.00000615302D0, $ 3.98064794D-4, 1.98615381364D0, 0.151679116635D0, $ 5.29330324926D0, 4.8385912808D0, 15.1508972451D0, $ 0.742380924027D0, 30.789933034D0, 3.99019417011D0/ C ZEXP(Z) = DEXP(Z) C UP = UPPER Z = X IF (Z .GE. ZERO) GOTO 10 UP = .NOT. UP Z = -Z 10 IF (Z .LE. LTONE .OR. UP .AND. Z .LE. UTZERO) GOTO 20 ALNORM = ZERO GOTO 40 20 Y = HALF * Z * Z IF (Z .GT. CON) GOTO 30 C ALNORM = HALF - Z * (A1- A2 * Y / (Y + A3- A4 / (Y + A5 + A6 / $ (Y + A7)))) GOTO 40 C 30 ALNORM = B1* ZEXP(-Y)/(Z - B2 + B3/ (Z +B4 +B5/(Z -B6 +B7/ $ (Z +B8 -B9/ (Z +B10 +B11/ (Z + B12)))))) C 40 IF (.NOT. UP) ALNORM = ONE - ALNORM RETURN END double precision function alogam (x, ifault) c----------------------------------------------------------------------- c Name: ALOGAM c c Purpose: Value of the log-gamma function. c c Usage: ALOGAM (X, IFAULT) c c Arguments: c X - Value at which the log-gamma function is to be evaluated. c (Input) c IFAULT - Error indicator. (Output) c IFAULT DEFINITION c 0 No error c 1 X .LT. 0 c ALGAMA - The value of the log-gamma function at XX. (Output) c----------------------------------------------------------------------- c c Algorithm ACM 291, Comm. ACM. (1966) Vol. 9, P. 684 c c Evaluates natural logarithm of gamma(x) c for X greater than zero. c c SPECIFICATIONS FOR ARGUMENTS integer ifault double precision x c SPECIFICATIONS FOR LOCAL VARIABLES double precision f, y, z c SPECIFICATIONS FOR SAVE VARIABLES double precision a1, a2, a3, a4, a5, half, one, seven, zero save a1, a2, a3, a4, a5, half, one, seven, zero c SPECIFICATIONS FOR INTRINSICS intrinsic dlog double precision dlog double precision zlog c c The following constants are dlog(2PI)/2, c half, zero, one, seven c data a1, a2, a3, a4, a5/0.918938533204673d0, 0.000595238095238d0, & 0.000793650793651d0, 0.002777777777778d0, & 0.083333333333333d0/ data half, zero, one, seven/0.5d0, 0.0d0, 1.0d0, 7.0d0/ c zlog(f) = dlog(f) c alogam = zero ifault = 1 if (x .lt. zero) return ifault = 0 y = x f = zero if (y .ge. seven) go to 30 f = y 10 y = y + one if (y .ge. seven) go to 20 f = f*y go to 10 20 f = -zlog(f) 30 z = one/(y*y) alogam = f + (y-half)*zlog(y) - y + a1 + (((-a2*z+a3)*z-a4)*z+a5) & /y return end SUBROUTINE ALDCDF(X,ALPHA,BETA,CDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION C FUNCTION VALUE FOR THE C ASYMMETRIC LOG DOUBLE EXPONENTIAL (LAPLACE) C DISTRIBUTION. C THIS DISTRIBUTION IS DEFINED FOR ALL POSITIVE X AND C HAS THE CUMULATIVE DISTRIBUTION FUNCTION C F(X;ALPHA,BETA) C = (ALPHA/(ALPHA+BETA))*X**BETA 0 < X < 1 C = 1 - (BETA/(ALPHA+BETA))*X**(-ALPHA) X >= 1 C INPUT ARGUMENTS--X = THE DOUBLE PRECISION VALUE AT C WHICH THE CUMULATIVE DISTRIBUTION C FUNCTION IS TO BE EVALUATED. C --ALPHA = THE DOUBLE PRECISION FIRST C SHAPE PARAMETER C --BETA = THE DOUBLE PRECISION SECOND C SHAPE PARAMETER C OUTPUT ARGUMENTS--CDF = THE DOUBLE PRECISION CUMULATIVE C DISTRIBUTION FUNCTION VALUE. C OUTPUT--THE DOUBLE PRECISION CUMULATIVE DISTRIBUTION C FUNCTION VALUE CDF. C PRINTING--NONE. C RESTRICTIONS--NONE. C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--EXP, LOG. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN. C REFERENCES--KOZUBOWSKI AND PODGORSKI (2003), "LOG-LAPLACE C DISTRIBUTIONS", INTERNATIONAL MATHEMATICAL C JOURNAL, 3, 467-495. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING LABORATORY (205.03) C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C PHONE: 301-975-2899 C ORIGINAL VERSION--MARCH 2006. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C DOUBLE PRECISION X DOUBLE PRECISION ALPHA DOUBLE PRECISION BETA DOUBLE PRECISION CDF DOUBLE PRECISION DC DOUBLE PRECISION DTERM C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C--------------------------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS. C CDF=0.0D0 C IF(ALPHA.LE.0.0D0)THEN WRITE(ICOUT,25) 25 FORMAT('***** ERROR--THE FIRST SHAPE PARAMETER TO THE ', 1 'ALDCDF SUBROUTINE IS NON-POSITIVE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)ALPHA 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7) CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF C IF(BETA.LE.0.0D0)THEN WRITE(ICOUT,35) 35 FORMAT('***** ERROR--THE SECOND SHAPE PARAMETER TO THE ', 1 'ALDCDF SUBROUTINE IS NON-POSITIVE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)BETA CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF C C C-----START POINT----------------------------------------------------- C IF(X.LE.0.0D0)THEN CDF=0.0D0 ELSEIF(X.LT.1.0D0)THEN DC=DLOG(ALPHA) - DLOG(ALPHA+BETA) CDF=DC + BETA*DLOG(X) CDF=DEXP(CDF) ELSE DC=DLOG(BETA) - DLOG(ALPHA+BETA) CDF=(-ALPHA)*DLOG(X) CDF=1.0D0 - DEXP(DC+CDF) ENDIF C 9000 CONTINUE RETURN END SUBROUTINE ALDPDF(X,ALPHA,BETA,PDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY C FUNCTION VALUE FOR THE C ASYMMETRIC LOG DOUBLE EXPONENTIAL (LAPLACE) C DISTRIBUTION. C THIS DISTRIBUTION IS DEFINED FOR ALL POSITIVE X AND C HAS THE PROBABILITY DENSITY FUNCTION C f(X;ALPHA,BETA) C = C*X**(BETA-1) 0 < X < 1 C = C*X**(-ALPHA-1) X >= 1 C ALPHA, BETA > 0 C WITH C = ALPHA*BETA/(ALPHA + BETA) C INPUT ARGUMENTS--X = THE DOUBLE PRECISION VALUE AT C WHICH THE PROBABILITY DENSITY C FUNCTION IS TO BE EVALUATED. C --ALPHA = THE DOUBLE PRECISION FIRST C SHAPE PARAMETER C --BETA = THE DOUBLE PRECISION SECOND C SHAPE PARAMETER C OUTPUT ARGUMENTS--PDF = THE DOUBLE PRECISION PROBABILITY C DENSITY FUNCTION VALUE. C OUTPUT--THE DOUBLE PRECISION PROBABILITY DENSITY C FUNCTION VALUE PDF. C PRINTING--NONE. C RESTRICTIONS--NONE. C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--EXP, LOG. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN. C REFERENCES--KOZUBOWSKI AND PODGORSKI (2003), "LOG-LAPLACE C DISTRIBUTIONS", INTERNATIONAL MATHEMATICAL C JOURNAL, 3, 467-495. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING LABORATORY (205.03) C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C PHONE: 301-975-2899 C ORIGINAL VERSION--MARCH 2006. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C DOUBLE PRECISION X DOUBLE PRECISION ALPHA DOUBLE PRECISION BETA DOUBLE PRECISION PDF DOUBLE PRECISION DC DOUBLE PRECISION DTERM C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C--------------------------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS. C PDF=0.0D0 C IF(X.LE.0.0D0)THEN WRITE(ICOUT,15) 15 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO THE ', 1 'ALDPDF SUBROUTINE IS NON-POSITIVE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7) CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF C IF(ALPHA.LE.0.0D0)THEN WRITE(ICOUT,25) 25 FORMAT('***** ERROR--THE FIRST SHAPE PARAMETER TO THE ', 1 'ALDPDF SUBROUTINE IS NON-POSITIVE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)ALPHA CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF C IF(BETA.LE.0.0D0)THEN WRITE(ICOUT,35) 35 FORMAT('***** ERROR--THE SECOND SHAPE PARAMETER TO THE ', 1 'ALDPDF SUBROUTINE IS NON-POSITIVE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)BETA CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF C C-----START POINT----------------------------------------------------- C DC=DLOG(ALPHA) + DLOG(BETA) - DLOG(ALPHA+BETA) C IF(X.LT.1.0D0)THEN DTERM=(BETA-1.0D0)*DLOG(X) ELSE DTERM=(-ALPHA-1.0D0)*DLOG(X) ENDIF PDF=DEXP(DC + DTERM) C 9000 CONTINUE RETURN END SUBROUTINE ALDPPF(P,ALPHA,BETA,PPF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT C FUNCTION VALUE FOR THE C ASYMMETRIC LOG DOUBLE EXPONENTIAL C (LAPLACE) DISTRIBUTION. C THIS DISTRIBUTION IS DEFINED FOR ALL POSITIVE X AND C HAS THE PERCENT POINT FUNCTION C G(P;ALPHA,BETA) = [P**((ALPHA+BETA)/ALPHA)]**(1/BETA) C 0 <= P <= ALPHA/(ALPHA+BETA) C = [(1-P)**((ALPHA+BETA)/BETA)]**(-1/ALPHA) C ALPHA/(ALPHA+BETA) < P < 1 C NOTE THAT THE PERCENT POINT FUNCTION OF A DISTRIBUTION C IS IDENTICALLY THE SAME AS THE INVERSE CUMULATIVE C DISTRIBUTION FUNCTION OF THE DISTRIBUTION. C INPUT ARGUMENTS--P = THE DOUBLE PRECISION VALUE C (BETWEEN 0.0 AND 1.0) C AT WHICH THE PERCENT POINT C FUNCTION IS TO BE EVALUATED. C --ALPHA = THE DOUBLE PRECISION FIRST C SHAPE PARAMETER C --BETA = THE DOUBLE PRECISION SECOND C SHAPE PARAMETER C OUTPUT ARGUMENTS--PPF = THE DOUBLE PRECISION PERCENT C POINT FUNCTION VALUE. C OUTPUT--THE DOUBLE PRECISION PERCENT POINT C FUNCTION VALUE PPF. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--P SHOULD BE BETWEEN 0.0 AND 1.0, EXCLUSIVELY. C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--DLOG, DEXP. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--KOZUBOWSKI AND PODGORSKI (2003), "LOG-LAPLACE C DISTRIBUTIONS", INTERNATIONAL MATHEMATICAL C JOURNAL, 3, 467-495. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2006/3 C ORIGINAL VERSION--MARCH 2006. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C DOUBLE PRECISION P DOUBLE PRECISION ALPHA DOUBLE PRECISION BETA DOUBLE PRECISION PPF DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C PPF=0.0D0 C IF(P.LT.0.0D0 .OR. P.GE.1.0D0)THEN WRITE(ICOUT,15) 15 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO THE ', 1 'ALDPPF SUBROUTINE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,16) 16 FORMAT(' IS OUTSIDE THE ALLOWABLE (0,1] INTERVAL.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)P 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7) CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF C IF(ALPHA.LE.0.0D0)THEN WRITE(ICOUT,25) 25 FORMAT('***** ERROR--THE FIRST SHAPE PARAMETER TO THE ', 1 'ALDPPF SUBROUTINE IS NON-POSITIVE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)ALPHA CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF C IF(BETA.LE.0.0D0)THEN WRITE(ICOUT,35) 35 FORMAT('***** ERROR--THE SECOND SHAPE PARAMETER TO THE ', 1 'ALDPPF SUBROUTINE IS NON-POSITIVE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)BETA CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF C DCUT=ALPHA/(ALPHA+BETA) IF(P.EQ.0.0D0)THEN PPF=0.0D0 ELSEIF(P.LE.DCUT)THEN DTERM1=(ALPHA+BETA)/ALPHA DTERM2=(1.0D0/BETA)*DLOG(P*DTERM1) PPF=DEXP(DTERM2) ELSE DTERM1=(ALPHA+BETA)/BETA DTERM2=(-1.0D0/ALPHA)*DLOG((1.0D0-P)*DTERM1) PPF=DEXP(DTERM2) ENDIF C 9000 CONTINUE RETURN END SUBROUTINE ALDRAN(N,ALPHA,BETA,ISEED,X) C C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N C FROM THE ASYMMETRIC LOG DOUBLE EXPONENTIAL DISTRIBUTION C WITH TAIL LENGTH PARAMETERS ALPHA AND BETA. C INPUT ARGUMENTS--N = THE DESIRED INTEGER NUMBER C OF RANDOM NUMBERS TO BE C GENERATED. C --ALPHA = THE SINGLE PRECISION VALUE OF THE C FIRST (POSITIVE) SHAPE PARAMETER. C --BETA = THE SINGLE PRECISION VALUE OF THE C SECOND (POSITIVE) SHAPE PARAMETER. C OUTPUT ARGUMENTS--X = A SINGLE PRECISION VECTOR C (OF DIMENSION AT LEAST N) C INTO WHICH THE GENERATED C RANDOM SAMPLE WILL BE PLACED. C OUTPUT--A RANDOM SAMPLE OF SIZE N FROM THE C ASYMMETRIC LOG DOUBLE EXPONENTIAL DISTRIBUTION C WITH SHAPE PARAMETERS ALPHA AND BETA. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C --ALPHA AND BETA SHOULD BE POSITIVE. C OTHER DATAPAC SUBROUTINES NEEDED--UNIRAN. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--KOZUBOWSKI AND PODGORSKI, "LOG-LAPLACE C DISTRIBUTIONS", PAPER DOWNLOADED FROM THEIR C WEB SITE. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2006.3 C ORIGINAL VERSION--MARCH 2006. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DIMENSION X(*) DIMENSION Y(2) C DOUBLE PRECISION DALPHA DOUBLE PRECISION DBETA DOUBLE PRECISION DY1 DOUBLE PRECISION DY2 DOUBLE PRECISION DTEMP C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(N.LT.1)THEN WRITE(ICOUT, 5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT, 6) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)N CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF IF(ALPHA.LE.0.0)THEN WRITE(ICOUT,15) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,16) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)ALPHA CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF IF(BETA.LE.0.0)THEN WRITE(ICOUT,25) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,16) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)BETA CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF 5 FORMAT('***** ERROR--THE REQUESTED NUMBER OF ASYMMETRIC ', 1 'LOG DOUBLE EXPONENTIAL') 6 FORMAT(' RANDOM NUMBERS IS NON-POSITIVE.') 15 FORMAT('***** ERROR--THE FIRST SHAPE PARAMETER FOR THE') 25 FORMAT('***** ERROR--THE SECOND SHAPE PARAMETER FOR THE') 16 FORMAT(' ASYMMETRIC LOG DOUBLE EXPONENTIAL RANDOM ', 1 'NUMBERS IS NON-POSITIVE.') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****') C C NOTE 3/2006: ASYMMETRIC LOG DOUBLE EXPONENTIAL CAN BE C REPRESENTED AS C U1**(1/ALPHA)/U2**(1/BETA) C C EARLY TESTING INDICATES THAT RATIO OF UNIFORMS METHOD C SEEMS TO GENERATE SOME EXCESSIVELY LARGE RANDOM NUMBERS, C SO STICK WITH PPF METHOD FOR NOW. C DALPHA=DBLE(ALPHA) DBETA=DBLE(BETA) C IALG=0 IF(IALG.EQ.0)THEN CALL UNIRAN(N,ISEED,X) DO100I=1,N CALL ALDPPF(DBLE(X(I)),DALPHA,DBETA,DTEMP) X(I)=REAL(DTEMP) 100 CONTINUE ELSE NTEMP=2 DO200I=1,N CALL UNIRAN(NTEMP,ISEED,Y) DY1=DBLE(Y(1)) DY2=DBLE(Y(2)) X(I)=REAL(DY1**(1.0D0/DBETA)/DY2**(1.0D0/DALPHA)) 200 CONTINUE ENDIF C 9000 CONTINUE RETURN END SUBROUTINE ALPCDF(X,ALPHA,BETA,CDF) C C NOTE--ALPHA CDF IS: C ALPCDF(X,ALPHA) = NORCDF(ALPHA-BETA/X)/NORCDF(ALPHA) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--95/4 C ORIGINAL VERSION--APRIL 1995. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C CDF=0.0 C IF(ALPHA.LE.0.0 .OR. BETA.LE.0.0)THEN WRITE(ICOUT,101) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,103)ALPHA CALL DPWRST('XXX','BUG ') WRITE(ICOUT,104)BETA CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF IF(X.LT.0.0)THEN WRITE(ICOUT,201) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,202)X CALL DPWRST('XXX','BUG ') GOTO9999 ELSEIF(X.EQ.0.0)THEN CDF=0.0 GOTO9999 ENDIF 101 FORMAT('***** FATAL DIAGNOSTIC--EITHER THE ALPHA OR BETA IS ', 1 ' NON-POSITIVE.') 103 FORMAT(' THE VALUE OF ALPHA IS ',E15.7) 104 FORMAT(' THE VALUE OF BETA IS ',E15.7,' ******') 201 FORMAT('***** FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT IS ', 1 ' NEGATIVE.') 202 FORMAT(' IT HAS THE VALUE ',E15.7,' ******') C CALL NORCDF(ALPHA,TERM1) TERM2=ALPHA-(BETA/X) CALL NORCDF(TERM2,TERM3) CDF=TERM3/TERM1 GOTO9999 C 9999 CONTINUE RETURN END SUBROUTINE ALPCHA(X,ALPHA,BETA,HAZ) C C NOTE--ALPHA PDF IS: C ALPPDF(X,ALPHA,BETA) = NORPDF(ALPHA-BETA/X)* C BETA/[X**2*NORCDF(ALPHA)] C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--98/4 C ORIGINAL VERSION--APRIL 1998. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 DOUBLE PRECISION DTERM3 DOUBLE PRECISION DCDF DOUBLE PRECISION DHAZ C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C HAZ=0.0 C IF(ALPHA.LE.0.0 .OR. BETA.LE.0.0)THEN WRITE(ICOUT,101) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,103)ALPHA CALL DPWRST('XXX','BUG ') WRITE(ICOUT,104)BETA CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF IF(X.LT.0.0)THEN WRITE(ICOUT,201) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,202)X CALL DPWRST('XXX','BUG ') GOTO9999 ELSEIF(X.EQ.0)THEN HAZ=0.0 GOTO9999 ENDIF 101 FORMAT('***** FATAL DIAGNOSTIC--EITHER THE ALPHA OR BETA IS ', 1 ' NON-POSITIVE.') 103 FORMAT(' THE VALUE OF ALPHA IS ',E15.7) 104 FORMAT(' THE VALUE OF BETA IS ',E15.7,' ******') 201 FORMAT('***** FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT IS ', 1 ' NEGATIVE.') 202 FORMAT(' IT HAS THE VALUE ',E15.7,' ******') C CALL NODCDF(DBLE(ALPHA),DTERM1) DTERM2=DBLE(ALPHA-(BETA/X)) CALL NODCDF(DTERM2,DTERM3) DCDF=DTERM3/DTERM1 C DCDF=1.0D0-DCDF IF(DCDF.GT.0.0D0)THEN DHAZ=-DLOG(DCDF) HAZ=REAL(DHAZ) ELSE HAZ=0.0 WRITE(ICOUT,302)X CALL DPWRST('XXX','BUG ') ENDIF 302 FORMAT('**** CDF ESSENTIALLY 1, CUMULATIVE HAZARD SET TO 0.') C 9999 CONTINUE RETURN END SUBROUTINE ALPHAZ(X,ALPHA,BETA,HAZ) C C NOTE--ALPHA PDF IS: C ALPPDF(X,ALPHA,BETA) = NORPDF(ALPHA-BETA/X)* C BETA/[X**2*NORCDF(ALPHA)] C HAZARD FUNCTION IS: C H(X,A,B) = B*NORPDF(T)/(X**2*(NORCDF(A) - NORCDF(T))) C WHERE T = ALPHA - BETA/X C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--98/4 C ORIGINAL VERSION--APRIL 1998. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 DOUBLE PRECISION DTERM3 DOUBLE PRECISION DTERM4 DOUBLE PRECISION DTERM5 C DOUBLE PRECISION DT DOUBLE PRECISION DHAZ C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C HAZ=0.0 C IF(ALPHA.LE.0.0 .OR. BETA.LE.0.0)THEN WRITE(ICOUT,101) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,103)ALPHA CALL DPWRST('XXX','BUG ') WRITE(ICOUT,104)BETA CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF IF(X.LT.0.0)THEN HAZ=0.0 WRITE(ICOUT,201) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,202)X CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF 101 FORMAT('***** FATAL DIAGNOSTIC--EITHER THE ALPHA OR BETA IS ', 1 ' NON-POSITIVE.') 103 FORMAT(' THE VALUE OF ALPHA IS ',E15.7) 104 FORMAT(' THE VALUE OF BETA IS ',E15.7,' ******') 201 FORMAT('***** FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT IS ', 1 ' NEGATIVE.') 202 FORMAT(' IT HAS THE VALUE ',E15.7,' ******') 206 FORMAT('***** FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT IS ', 1 ' EQUAL TO THE SECOND INPUT ARGUMENT.') C C 3 CASES: C 1) T = ALPHA - X/BETA < ALPHA C 2) T = ALPHA - X/BETA = ALPHA C 2) T = ALPHA - X/BETA > ALPHA C THE HAZARD FUNCTION IS UNDEFINED FOR CASES 2 AND 3. C T=ALPHA - (BETA/X) IF(T.GE.ALPHA)THEN WRITE(ICOUT,902) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,903)X,ALPHA,BETA CALL DPWRST('XXX','BUG ') 902 FORMAT('**** ERROR: HAZARD FUNCTION IS UNDEFINED FOR ', 1 'ALPHA - BETA/X >= ALPHA, HAZARD SET TO 0.') 903 FORMAT(' X = ',E15.7, ' ALPHA = ',E15.7,' BETA = ',E15.7) ENDIF DT=DBLE(T) CALL NODCDF(DT,DTERM3) CALL NODCDF(DBLE(ALPHA),DTERM4) DTERM4=DTERM4-DTERM3 IF(DTERM4.EQ.0.0D0)THEN HAZ=0.0 GOTO9999 ENDIF C DTERM1=DLOG(DBLE(BETA)) CALL NORPDF(T,TERM2) DTERM2=DLOG(DBLE(TERM2)) DTERM3=2*DLOG(DBLE(X)) DTERM4=DLOG(DTERM4) DTERM5=DTERM1 + DTERM2 - DTERM3 - DTERM4 DHAZ=0.0D0 IF(DTERM5.LE.1.0D80)DHAZ=DEXP(DTERM5) HAZ=REAL(DHAZ) C 9999 CONTINUE RETURN END SUBROUTINE ALPPDF(X,ALPHA,BETA,PDF) C C NOTE--ALPHA PDF IS: C ALPPDF(X,ALPHA,BETA) = NORPDF(ALPHA-BETA/X)* C BETA/[X**2*NORCDF(ALPHA)] C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--95/4 C ORIGINAL VERSION--APRIL 1995. C UPDATED --JULY 1995. DEFINE DPDF AS DOUBLE PREC. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C DOUBLE PRECISION DTERM2 DOUBLE PRECISION DTERM3 DOUBLE PRECISION DTERM4 DOUBLE PRECISION DTERM5 DOUBLE PRECISION DTERM7 C CCCCC THE FOLLOWING LINE WAS ADDED JULY 1995 DOUBLE PRECISION DPDF C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C DATA EPS/0.1E-16/ C C-----START POINT----------------------------------------------------- C PDF=0.0 C IF(ALPHA.LE.0.0 .OR. BETA.LE.0.0)THEN WRITE(ICOUT,101) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,103)ALPHA CALL DPWRST('XXX','BUG ') WRITE(ICOUT,104)BETA CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF IF(X.LT.0.0)THEN WRITE(ICOUT,201) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,202)X CALL DPWRST('XXX','BUG ') GOTO9999 ELSEIF(X.EQ.0)THEN PDF=0.0 GOTO9999 ENDIF 101 FORMAT('***** FATAL DIAGNOSTIC--EITHER THE ALPHA OR BETA IS ', 1 ' NON-POSITIVE.') 103 FORMAT(' THE VALUE OF ALPHA IS ',E15.7) 104 FORMAT(' THE VALUE OF BETA IS ',E15.7,' ******') 201 FORMAT('***** FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT IS ', 1 ' NEGATIVE.') 202 FORMAT(' IT HAS THE VALUE ',E15.7,' ******') C TERM1=ALPHA - (BETA/X) CALL NORPDF(TERM1,TERM2) IF(TERM2.LT.EPS)TERM2=EPS DTERM2=DLOG(DBLE(TERM2)) DTERM3=DLOG(DBLE(BETA)) DTERM4=2.0D0*DLOG(DBLE(X)) CALL NORCDF(ALPHA,TERM5) DTERM5=DLOG(DBLE(TERM5)) DTERM7=DTERM2 + DTERM3 - DTERM4 - DTERM5 C DPDF=DEXP(DTERM7) PDF=REAL(DPDF) C 9999 CONTINUE RETURN END SUBROUTINE ALPPPF(P,ALPHA,BETA,PPF) C C NOTE--ALPHA PPF IS: C ALPPPF(P,ALPHA,BETA) = C BETA/[ALPHA - NORPPF(P*NORCDF(ALPHA))] C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--95/4 C ORIGINAL VERSION--APRIL 1995. C UPDATED --JULY 1995. DEFINE DPPF AS DOUBLE PREC. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C DOUBLE PRECISION DELTA C CCCCC THE FOLLOWING LINE WAS ADDED JULY 1995 DOUBLE PRECISION DPPF C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C PPF=0.0 C IF(P.LE.0.0 .OR. P.GE.1.0)THEN WRITE(ICOUT,1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)P CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9999 ENDIF IF(ALPHA.LE.0.0 .OR. BETA.LE.0.0)THEN WRITE(ICOUT,101) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,103)ALPHA CALL DPWRST('XXX','BUG ') WRITE(ICOUT,104)BETA CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF 1 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ', 1' ALPPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') 101 FORMAT('***** FATAL DIAGNOSTIC--EITHER THE ALPHA OR BETA IS ', 1 ' NON-POSITIVE.') 103 FORMAT(' THE VALUE OF ALPHA IS ',E15.7) 104 FORMAT(' THE VALUE OF BETA IS ',E15.7,' ******') C CALL NORCDF(ALPHA,TERM1) TERM2=P*TERM1 CALL NORPPF(TERM2,TERM3) DELTA=DBLE(ALPHA-TERM3) IF(DELTA.GE.0.D0)THEN DPPF=DBLE(BETA)/DELTA PPF=REAL(DPPF) ELSE WRITE(ICOUT,301)P CALL DPWRST('XXX','BUG ') PPF=0.0 ENDIF 301 FORMAT('***** FATAL DIAGNOSTIC--P VALUE OF ',F8.5,' RESULTS IN', 1 ' AN INFINITE PPF VALUE.') GOTO9999 C 9999 CONTINUE RETURN END SUBROUTINE ALPRAN(N,ALPHA,BETA,ISEED,X) C C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N C FROM THE ALPHA DISTRIBUTION C WITH SHAPE PARAMETER VALUES = ALPHA, BETA. C INPUT ARGUMENTS--N = THE DESIRED INTEGER NUMBER C OF RANDOM NUMBERS TO BE C GENERATED. C --ALPHA = THE SINGLE PRECISION VALUE OF THE C FIRST SHAPE PARAMETER. C ALPHA SHOULD BE POSITIVE. C --BETA = THE SINGLE PRECISION VALUE OF THE C SECOND SHAPE PARAMETER. C BETA SHOULD BE POSITIVE. C OUTPUT ARGUMENTS--X = A SINGLE PRECISION VECTOR C (OF DIMENSION AT LEAST N) C INTO WHICH THE GENERATED C RANDOM SAMPLE WILL BE PLACED. C OUTPUT--A RANDOM SAMPLE OF SIZE N C FROM THE ALPHA DISTRIBUTION C WITH SHAPE PARAMETER VALUES = ALPHA AND BETA. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C --ALPHA SHOULD BE POSITIVE. C OTHER DATAPAC SUBROUTINES NEEDED--UNIRAN. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2001.10 C ORIGINAL VERSION--OCTOBER 2001. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DIMENSION X(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(N.LT.1)THEN WRITE(ICOUT, 5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)N CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF 5 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ', 1'ALPRAN SUBROUTINE IS NON-POSITIVE *****') 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****') C C GENERATE N UNIFORM (0,1) RANDOM NUMBERS; C CALL UNIRAN(N,ISEED,X) C C GENERATE N ALPHA DISTRIBUTION RANDOM NUMBERS C USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD. C DO100I=1,N CALL ALPPPF(X(I),ALPHA,BETA,XTEMP) X(I)=XTEMP 100 CONTINUE C 9000 CONTINUE RETURN END SUBROUTINE ANDYK (NTOT, NBCH, XPS, XPSU, $ IPBCH, NTIE, ISIZE, WK3, IWK2, ADKSTA) IMPLICIT DOUBLE PRECISION (A-H, O-Z) DIMENSION XPS(*), XPSU(*), NTIE(*), $ ISIZE(*), WK3(*), IWK2(*), $ IPBCH(*) C C NTOT -- TOTAL NUMBER OF DATA VALUES (INPUT) C NBCH -- NUMBER OF BATCHES (INPUT) C XPS -- DATA, POOLED AND SORTED (INPUT) C XPSU -- UNIQUE VALUES OF XPS (OUTPUT) C IPBCH -- BATCH NUMBERS FOR XPS (INPUT) C NTIE -- NUMBER OF TIES AT EACH VALUE OF XPSU (OUTPUT) C ISIZE -- BATCH SIZES (INPUT) C WK3, IWK2 -- SCRATCH WORK ARRAYS C ADKSTA -- K-SAMPLE A-D STATISTIC (OUTPUT) C C K-SAMPLE ANDERSON-DARLING TEST -- C INCLUDING CORRECTION FOR TIES. C ADKSTA = 0.D0 DO 10 K=1, NBCH CALL ANDY2 (K, ADVAL, $ NTOT, NBCH, XPS, XPSU, IPBCH, NTIE, $ ISIZE, WK3, IWK2) ADKSTA = ADKSTA +ADVAL 10 CONTINUE C ADKSTA = ADKSTA *(NTOT -1.D0) /(NTOT *(NBCH -1.D0)) RETURN END SUBROUTINE ANDY2 (K, ADVAL, $ NTOT, NBCH, XPS, XPSU, IPBCH, $ NTIE, ISIZE, WK3, IWK2) IMPLICIT DOUBLE PRECISION (A-H, O-Z) DIMENSION XPS(NTOT), XPSU(NTOT), IPBCH(NTOT), $ NTIE(NTOT), ISIZE(NBCH), WK3(NTOT), $ IWK2(NTOT) C C -- DETERMINE THE UNIQUE VALUES, NUMBER OF TIES AND C NUMBER OF TIES IN KTH BATCH. DO 10 I=1, NTOT XPSU (I) = XPS (I) NTIE (I) = 1 IF (IPBCH (I) .EQ. K) THEN IWK2 (I) = 1 ELSE IWK2 (I) = 0 END IF 10 CONTINUE C I = 2 NDIS = NTOT C DO WHILE (I .LE. NDIS) 11 CONTINUE IF (I .GT. NDIS) GO TO 12 IF (XPSU (I) .EQ. XPSU (I-1)) THEN NTIE (I-1) = NTIE (I-1) + NTIE (I) IWK2 (I-1) = IWK2 (I-1) + IWK2 (I) NDIS = NDIS -1 DO 20 J=I, NDIS XPSU (J) = XPSU (J+1) NTIE (J) = NTIE (J+1) IWK2 (J) = IWK2 (J+1) 20 CONTINUE ELSE I = I +1 END IF GO TO 11 12 CONTINUE C END DO C C -- DETERMINE THE FIJ. XOLD = 0.0D0 IOLD = 0 DO 30 I=1, NDIS WK3 (I) = XOLD +.5D0 *(IWK2 (I) +IOLD) XOLD = WK3 (I) IOLD = IWK2 (I) 30 CONTINUE C C -- CALCULATE THE ANDERSON-DARLING STATISTIC ADVAL = 0.D0 NSUM = 0 DO 50 I=1, NDIS FIJ = WK3 (I) HJ = NSUM + .5D0 *NTIE (I) NSUM = NSUM + NTIE (I) ADVAL = ADVAL + NTIE (I) *(NTOT*FIJ -ISIZE(K)*HJ) **2 $ /(HJ *(NTOT-HJ) -.25D0 *NTOT*NTIE(I)) 50 CONTINUE ADVAL = ADVAL / (ISIZE (K) *NTOT) RETURN END SUBROUTINE ANGCDF(X,CDF) C C NOTE--ANGLIT CDF IS: C ANGCDF(X) = [SIN(X + PI/4)]**2 -PI/4 <= X <= PI/4 C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--95/9 C ORIGINAL VERSION--SEPTEMBER 1995. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C DATA PI/3.1415926535898E0/ C C-----START POINT----------------------------------------------------- C CDF=0.0 IF(X.LT.-PI/4.0)THEN CDF=0.0 ELSEIF(X.GT.PI/4.0)THEN CDF=1.0 ELSE CDF=SIN(X+PI/4.0)*SIN(X+PI/4) ENDIF C 9999 CONTINUE RETURN END SUBROUTINE ANGPDF(X,PDF) C C NOTE--ANGLIT PDF IS: C ANGPDF(X) = SIN(2X + PI/2) -PI/4 <= X <= PI/4 C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--95/9 C ORIGINAL VERSION--SEPTEMBER 1995. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C DATA PI/3.1415926535898E0/ C C-----START POINT----------------------------------------------------- C PDF=0.0 IF(X.LT.-PI/4.0 .OR. X.GT.PI/4.0)THEN WRITE(ICOUT,301) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,302)X CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF 301 FORMAT('***** FATAL DIAGNOSTIC--THE INPUT ARGUMENT IS NOT IN 1 THE INTERVAL (-PI/4,PI/4).') 302 FORMAT(' IT HAS THE VALUE ',E15.7) C PDF=SIN(2*X+PI/2.0) C 9999 CONTINUE RETURN END SUBROUTINE ANGPPF(P,PPF) C C NOTE--ALGORITHM ADDED SEPTEMBER 1995 C G(P) = ARCSIN(SQRT(P))-PI/4 C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--95/9 C ORIGINAL VERSION--SEPTEMBER 1995. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C DATA PI/3.1415926535898E0/ C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(P.LT.0.0.OR.P.GT.1.0)GOTO50 GOTO90 50 WRITE(ICOUT,1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)P CALL DPWRST('XXX','BUG ') PPF=0.0 RETURN 90 CONTINUE 1 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ', 1' ANGPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') C PPF=ASIN(SQRT(P))-PI/4.0 C 9999 CONTINUE RETURN END SUBROUTINE ANGRAN(N,ISEED,X) C C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N C FROM THE ANGLIT DISTRIBUTION C INPUT ARGUMENTS--N = THE DESIRED INTEGER NUMBER C OF RANDOM NUMBERS TO BE C GENERATED. C OUTPUT ARGUMENTS--X = A SINGLE PRECISION VECTOR C (OF DIMENSION AT LEAST N) C INTO WHICH THE GENERATED C RANDOM SAMPLE WILL BE PLACED. C OUTPUT--A RANDOM SAMPLE OF SIZE N C FROM THE ANGLIT DISTRIBUTION C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C OTHER DATAPAC SUBROUTINES NEEDED--UNIRAN. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--2001/10 C ORIGINAL VERSION--OCTOBER 2001. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DIMENSION X(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(N.LT.1)GOTO50 GOTO90 50 WRITE(ICOUT, 5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)N CALL DPWRST('XXX','BUG ') RETURN 90 CONTINUE 5 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ', 1'ANGRAN SUBROUTINE IS NON-POSITIVE *****') 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****') C C GENERATE N UNIFORM (0,1) RANDOM NUMBERS; C CALL UNIRAN(N,ISEED,X) C C GENERATE N ANGLIT RANDOM NUMBERS C USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD. C DO100I=1,N CALL ANGPPF(X(I),XTEMP) X(I)=XTEMP 100 CONTINUE C RETURN END SUBROUTINE ARL2(DELTA, K, H, S0, ARL, ARLFIR, IFAULT) C C ALGORITHM AS 258.1 APPL.STATIST. (1990), VOL.39, NO.3 C C Computes the average run length for a cumulative C sum control scheme C REAL DELTA, K, H, S0, ARL, ARLFIR INTEGER IFAULT REAL ARLH, ARLHF, ARLL, ARLLF, BIGARL, BIGDEL INTEGER JFAULT DATA BIGARL / 1.E30 / , BIGDEL / 5.0 / C IFAULT = 0 IF (DELTA .LT. 0.0) THEN IFAULT = 1 ELSE C C Compute ARL's for upper tail. C CALL ARL1(DELTA, K, H, S0, ARLH, ARLHF, IFAULT) IF (IFAULT .EQ. 0) THEN C C If DELTA=0, then ARL's for lower tail are the same as for C the upper. C IF (DELTA .EQ. 0.0) THEN ARLLF = ARLHF ARLL = ARLH C C If DELTA is too large, skip the low-side ARL calculation. C ELSE IF (DELTA .GT. BIGDEL) THEN ARLL = BIGARL ARLLF = BIGARL ELSE C C Otherwise compute ARL's for lower tail. C CALL ARL1(-DELTA, K, H, S0, ARLL, ARLLF, JFAULT) C C Set lower ARL's large if negative JFAULT .GT. 0 C IF (ARLL .LE. ARLH .OR. ARLLF .LE. ARLHF .OR. * ARLL .LT. ARLLF .OR. JFAULT .GT. 0) THEN ARLL = BIGARL ARLLF = BIGARL END IF END IF C C Compute two-sided ARL for S0=0.0 C ARL = ARLH / (1.0 + ARLH / ARLL) C C Compute two-sided ARL for specified value of S0. C ARLFIR = ARLHF / (1.0 + ARLH / ARLL) + * ARLH / (ARLH / ARLLF + ARLL / ARLLF) - ARL C C Set IFAULT=3 if two-sided ARL's are lower bounds. C IF (IFAULT .EQ. 0 .AND. S0 .GT. H / 2.0 + K) IFAULT = 3 END IF END IF RETURN END SUBROUTINE ARL1(DELTA, K, H, S0, ARL, ARLFIR, IFAULT) C C ALGORITHM AS 258.2 APPL.STATIST. (1990), VOL.39, NO.3 C REAL DELTA, K, H, S0, ARL, ARLFIR INTEGER IFAULT INTEGER N, N1, N2, I, J REAL XN DOUBLE PRECISION XCOND PARAMETER (N=12, N1=N + 1, N2=N + 2, XN=N, XCOND=100.D0) INTEGER IPVT(N1) CCCCC REAL P1, P2 DOUBLE PRECISION ALNORM DOUBLE PRECISION A(N1, N1), B(N1), R(N1), W(N2), * C, E1, E2, RCOND, S, T EXTERNAL ALNORM C C N is the degree of the polynomial approximation. C XCOND defines the criterion for singularity: C XCOND+RCOND .LE. XCOND, C where RCOND is the reciprocal of the condition number. C IFAULT = 0 IF (K .LT. 0.0 .OR. H .LT. 0.0 .OR. S0 .LT. 0.0 .OR. * S0 .GT. H) THEN IFAULT = 1 ELSE IF (H .EQ. 0.0) THEN AK=REAL(K) ARL = 1.0 / ALNORM(DBLE(DELTA - AK), .FALSE.) ARLFIR = ARL ELSE C C Set C. C C = MAX(0.0, K - DELTA) C C For each point S at which the polynomial approximation is to be C evaluated... C DO 40 I = 0, N C C Compute S C S = H * I / XN C C Calculate necessary exponentials in S. C E1 = EXP(C * S) E2 = EXP((S + DELTA - K) * C + C * C / 2.0) C C Apply left-hand-side of integral equation. C T = E1 DO 10 J = 1, N + 1 A(I + 1, J) = T T = T * S 10 CONTINUE C C Apply lower integration limit. C CALL MOMENT(-S - DELTA - C + K, -S - DELTA - C + K, N, R, W) DO 20 J = 1, N + 1 A(I + 1, J) = A(I + 1, J) - R(J) * E2 20 CONTINUE C C Apply upper integration limit. C CALL MOMENT(H - S - DELTA - C + K, -S - DELTA - C + K, N, R, * W) DO 30 J = 1, N + 1 A(I + 1, J) = A(I + 1, J) + R(J) * E2 30 CONTINUE C C Apply term '1 + L(0) F(-S-DELTA+K)'. C AK=REAL(K) A(I + 1, 1) = A(I + 1, 1) - ALNORM(-S - DELTA + AK, * .FALSE.) B(I + 1) = 1.0 40 CONTINUE C C Normalize the simultaneous equations C DO 70 I = 1, N + 1 S = 0.0 DO 50 J = 1, N + 1 S = MAX(S, ABS(A(I, J))) 50 CONTINUE B(I) = B(I) / S DO 60 J = 1, N + 1 A(I, J) = A(I, J) / S 60 CONTINUE 70 CONTINUE DO 100 J = 1, N + 1 W(J) = 0.0 DO 80 I = 1, N + 1 W(J) = MAX(W(J), ABS(A(I, J))) 80 CONTINUE DO 90 I = 1, N + 1 A(I, J) = A(I, J) / W(J) 90 CONTINUE 100 CONTINUE C C Factor matrix A. If equations are singular to working C precision, IFAULT=2. C C *************************************** C SUBROUTINE DGECO(A,LDA,N,IPVT,RCOND,Z) C on entry: C A: the matrix to be factored. C LDA: the leading dimension of array A. C N: the order of the matrix A. C on return: C A: the lu factorization of A. C IPVT: pivot indices. C RCOND: an estimate of the reciprocal condition of A. C Z: a working vector. C *************************************** C CALL DGECO(A, N + 1, N + 1, IPVT, RCOND, R) IF (XCOND + RCOND .EQ. XCOND) THEN IFAULT = 2 ELSE C C Solve for the polynomial coefficients C C *************************************** C SUBROUTINE DGESL(A,LDA,N,IPVT,B,JOB) C on entry: C A: the output from dgeco. C LDA: the leading dimension of array A. C N: the order of the matrix A. C IPVT: the pivot vector from dgeco. C B: the right hand side vector. C JOB: = 0 to solve A*X=B. C = nonzero to solve trans(A)*X=B. C on return: C B: the solution vector X. C *************************************** C CALL DGESL(A, N + 1, N + 1, IPVT, B, 0) C C Get ARL and ARLFIR. C ARL = B(1) / W(1) ARLFIR = 0.0 DO 110 I = 0, N ARLFIR = S0 * ARLFIR + B(N - I + 1) / W(N - I + 1) 110 CONTINUE ARLFIR = ARLFIR * EXP(C * S0) END IF END IF RETURN END SUBROUTINE ARSCDF(X,CDF) C C NOTE--ARCSIN CDF IS: C ARSCDF(X) = (2/PI)*ARCSIN(SQRT(X)) 0 < X < 1 C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--95/9 C ORIGINAL VERSION--SEPTEMBER 1995. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C DATA PI/3.1415926535898E0/ C C-----START POINT----------------------------------------------------- C CDF=0.0 IF(X.LE.0.0)THEN CDF=0.0 ELSEIF(X.GE.1.0)THEN CDF=1.0 ELSE CDF=(2.0/PI)*ASIN(SQRT(X)) ENDIF C 9999 CONTINUE RETURN END SUBROUTINE ARSPDF(X,PDF) C C NOTE--ARCSIN PDF IS: C ARSPDF(X) = (1/PI)*(1/SQRT(X*(1-x))) 0 < x < 1 C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--95/9 C ORIGINAL VERSION--SEPTEMBER 1995. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C DATA PI/3.1415926535898E0/ C C-----START POINT----------------------------------------------------- C PDF=0.0 IF(X.LE.0.0 .OR. X.GE.1.0)THEN WRITE(ICOUT,301) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,302)X CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF 301 FORMAT('***** FATAL DIAGNOSTIC--THE INPUT ARGUMENT IS NOT IN 1 THE INTERVAL (0,1).') 302 FORMAT(' IT HAS THE VALUE ',E15.7) C PDF=1.0/(PI*SQRT(X*(1.0-X))) C 9999 CONTINUE RETURN END SUBROUTINE ARSPPF(P,PPF) C C NOTE--ALGORITHM ADDED SEPTEMBER 1995 C ARSPPF(P) = (SIN(PI*P/2))**2 C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--95/9 C ORIGINAL VERSION--SEPTEMBER 1995. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C DATA PI/3.1415926535898E0/ C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(P.LT.0.0.OR.P.GT.1.0)GOTO50 GOTO90 50 WRITE(ICOUT,1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)P CALL DPWRST('XXX','BUG ') PPF=0.0 RETURN 90 CONTINUE 1 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ', 1' ARSPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') C PPF=SIN(PI*P/2.0)*SIN(PI*P/2.0) C 9999 CONTINUE RETURN END SUBROUTINE ARSRAN(N,ISEED,X) C C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N C FROM THE ARCSIN DISTRIBUTION C INPUT ARGUMENTS--N = THE DESIRED INTEGER NUMBER C OF RANDOM NUMBERS TO BE C GENERATED. C OUTPUT ARGUMENTS--X = A SINGLE PRECISION VECTOR C (OF DIMENSION AT LEAST N) C INTO WHICH THE GENERATED C RANDOM SAMPLE WILL BE PLACED. C OUTPUT--A RANDOM SAMPLE OF SIZE N C FROM THE ARCSIN DISTRIBUTION C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C OTHER DATAPAC SUBROUTINES NEEDED--UNIRAN. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--2001/10 C ORIGINAL VERSION--OCTOBER 2001. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DIMENSION X(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(N.LT.1)GOTO50 GOTO90 50 WRITE(ICOUT, 5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)N CALL DPWRST('XXX','BUG ') RETURN 90 CONTINUE 5 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ', 1'ARSRAN SUBROUTINE IS NON-POSITIVE *****') 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****') C C GENERATE N UNIFORM (0,1) RANDOM NUMBERS; C CALL UNIRAN(N,ISEED,X) C C GENERATE N ARCSIN RANDOM NUMBERS C USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD. C DO100I=1,N CALL ARSPPF(X(I),XTEMP) X(I)=XTEMP 100 CONTINUE C RETURN END SUBROUTINE ASYIK (X, FNU, KODE, FLGIK, RA, ARG, IN, Y) C***BEGIN PROLOGUE ASYIK C***SUBSIDIARY C***PURPOSE Subsidiary to BESI and BESK C***LIBRARY SLATEC C***TYPE SINGLE PRECISION (ASYIK-S, DASYIK-D) C***AUTHOR Amos, D. E., (SNLA) C***DESCRIPTION C C ASYIK computes Bessel functions I and K C for arguments X.GT.0.0 and orders FNU.GE.35 C on FLGIK = 1 and FLGIK = -1 respectively. C C INPUT C C X - argument, X.GT.0.0E0 C FNU - order of first Bessel function C KODE - a parameter to indicate the scaling option C KODE=1 returns Y(I)= I/SUB(FNU+I-1)/(X), I=1,IN C or Y(I)= K/SUB(FNU+I-1)/(X), I=1,IN C on FLGIK = 1.0E0 or FLGIK = -1.0E0 C KODE=2 returns Y(I)=EXP(-X)*I/SUB(FNU+I-1)/(X), I=1,IN C or Y(I)=EXP( X)*K/SUB(FNU+I-1)/(X), I=1,IN C on FLGIK = 1.0E0 or FLGIK = -1.0E0 C FLGIK - selection parameter for I or K function C FLGIK = 1.0E0 gives the I function C FLGIK = -1.0E0 gives the K function C RA - SQRT(1.+Z*Z), Z=X/FNU C ARG - argument of the leading exponential C IN - number of functions desired, IN=1 or 2 C C OUTPUT C C Y - a vector whose first in components contain the sequence C C Abstract C ASYIK implements the uniform asymptotic expansion of C the I and K Bessel functions for FNU.GE.35 and real C X.GT.0.0E0. The forms are identical except for a change C in sign of some of the terms. This change in sign is C accomplished by means of the flag FLGIK = 1 or -1. C C***SEE ALSO BESI, BESK C***ROUTINES CALLED R1MACH C***REVISION HISTORY (YYMMDD) C 750101 DATE WRITTEN C 890531 Changed all specific intrinsics to generic. (WRB) C 891214 Prologue converted to Version 4.0 format. (BAB) C 900328 Added TYPE section. (WRB) C 910408 Updated the AUTHOR section. (WRB) C***END PROLOGUE ASYIK C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOMC.INC' CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C INTEGER IN, J, JN, K, KK, KODE, L REAL AK,AP,ARG,C, COEF,CON,ETX,FLGIK,FN, FNU,GLN,RA,S1,S2, 1 T, TOL, T2, X, Y, Z DIMENSION Y(*), C(65), CON(2) SAVE CON, C DATA CON(1), CON(2) / 1 3.98942280401432678E-01, 1.25331413731550025E+00/ DATA C(1), C(2), C(3), C(4), C(5), C(6), C(7), C(8), C(9), C(10), 1 C(11), C(12), C(13), C(14), C(15), C(16), C(17), C(18), 2 C(19), C(20), C(21), C(22), C(23), C(24)/ 3 -2.08333333333333E-01, 1.25000000000000E-01, 4 3.34201388888889E-01, -4.01041666666667E-01, 5 7.03125000000000E-02, -1.02581259645062E+00, 6 1.84646267361111E+00, -8.91210937500000E-01, 7 7.32421875000000E-02, 4.66958442342625E+00, 8 -1.12070026162230E+01, 8.78912353515625E+00, 9 -2.36408691406250E+00, 1.12152099609375E-01, 1 -2.82120725582002E+01, 8.46362176746007E+01, 2 -9.18182415432400E+01, 4.25349987453885E+01, 3 -7.36879435947963E+00, 2.27108001708984E-01, 4 2.12570130039217E+02, -7.65252468141182E+02, 5 1.05999045252800E+03, -6.99579627376133E+02/ DATA C(25), C(26), C(27), C(28), C(29), C(30), C(31), C(32), 1 C(33), C(34), C(35), C(36), C(37), C(38), C(39), C(40), 2 C(41), C(42), C(43), C(44), C(45), C(46), C(47), C(48)/ 3 2.18190511744212E+02, -2.64914304869516E+01, 4 5.72501420974731E-01, -1.91945766231841E+03, 5 8.06172218173731E+03, -1.35865500064341E+04, 6 1.16553933368645E+04, -5.30564697861340E+03, 7 1.20090291321635E+03, -1.08090919788395E+02, 8 1.72772750258446E+00, 2.02042913309661E+04, 9 -9.69805983886375E+04, 1.92547001232532E+05, 1 -2.03400177280416E+05, 1.22200464983017E+05, 2 -4.11926549688976E+04, 7.10951430248936E+03, 3 -4.93915304773088E+02, 6.07404200127348E+00, 4 -2.42919187900551E+05, 1.31176361466298E+06, 5 -2.99801591853811E+06, 3.76327129765640E+06/ DATA C(49), C(50), C(51), C(52), C(53), C(54), C(55), C(56), 1 C(57), C(58), C(59), C(60), C(61), C(62), C(63), C(64), 2 C(65)/ 3 -2.81356322658653E+06, 1.26836527332162E+06, 4 -3.31645172484564E+05, 4.52187689813627E+04, 5 -2.49983048181121E+03, 2.43805296995561E+01, 6 3.28446985307204E+06, -1.97068191184322E+07, 7 5.09526024926646E+07, -7.41051482115327E+07, 8 6.63445122747290E+07, -3.75671766607634E+07, 9 1.32887671664218E+07, -2.78561812808645E+06, 1 3.08186404612662E+05, -1.38860897537170E+04, 2 1.10017140269247E+02/ C***FIRST EXECUTABLE STATEMENT ASYIK TOL = R1MACH(3) TOL = MAX(TOL,1.0E-15) FN = FNU Z = (3.0E0-FLGIK)/2.0E0 KK = INT(Z) DO 50 JN=1,IN IF (JN.EQ.1) GO TO 10 FN = FN - FLGIK Z = X/FN RA = SQRT(1.0E0+Z*Z) GLN = LOG((1.0E0+RA)/Z) ETX = KODE - 1 T = RA*(1.0E0-ETX) + ETX/(Z+RA) ARG = FN*(T-GLN)*FLGIK 10 COEF = EXP(ARG) T = 1.0E0/RA T2 = T*T T = T/FN T = SIGN(T,FLGIK) S2 = 1.0E0 AP = 1.0E0 L = 0 DO 30 K=2,11 L = L + 1 S1 = C(L) DO 20 J=2,K L = L + 1 S1 = S1*T2 + C(L) 20 CONTINUE AP = AP*T AK = AP*S1 S2 = S2 + AK IF (MAX(ABS(AK),ABS(AP)) .LT. TOL) GO TO 40 30 CONTINUE 40 CONTINUE T = ABS(T) Y(JN) = S2*COEF*SQRT(T)*CON(KK) 50 CONTINUE RETURN END SUBROUTINE ASYJY (FUNJY, X, FNU, FLGJY, IN, Y, WK, IFLW) C***BEGIN PROLOGUE ASYJY C***SUBSIDIARY C***PURPOSE Subsidiary to BESJ and BESY C***LIBRARY SLATEC C***TYPE SINGLE PRECISION (ASYJY-S, DASYJY-D) C***AUTHOR Amos, D. E., (SNLA) C***DESCRIPTION C C ASYJY computes Bessel functions J and Y C for arguments X.GT.0.0 and orders FNU.GE.35.0 C on FLGJY = 1 and FLGJY = -1 respectively C C INPUT C C FUNJY - external function JAIRY or YAIRY C X - argument, X.GT.0.0E0 C FNU - order of the first Bessel function C FLGJY - selection flag C FLGJY = 1.0E0 gives the J function C FLGJY = -1.0E0 gives the Y function C IN - number of functions desired, IN = 1 or 2 C C OUTPUT C C Y - a vector whose first in components contain the sequence C IFLW - a flag indicating underflow or overflow C return variables for BESJ only C WK(1) = 1 - (X/FNU)**2 = W**2 C WK(2) = SQRT(ABS(WK(1))) C WK(3) = ABS(WK(2) - ATAN(WK(2))) or C ABS(LN((1 + WK(2))/(X/FNU)) - WK(2)) C = ABS((2/3)*ZETA**(3/2)) C WK(4) = FNU*WK(3) C WK(5) = (1.5*WK(3)*FNU)**(1/3) = SQRT(ZETA)*FNU**(1/3) C WK(6) = SIGN(1.,W**2)*WK(5)**2 = SIGN(1.,W**2)*ZETA*FNU**(2/3) C WK(7) = FNU**(1/3) C C Abstract C ASYJY implements the uniform asymptotic expansion of C the J and Y Bessel functions for FNU.GE.35 and real C X.GT.0.0E0. The forms are identical except for a change C in sign of some of the terms. This change in sign is C accomplished by means of the flag FLGJY = 1 or -1. On C FLGJY = 1 the AIRY functions AI(X) and DAI(X) are C supplied by the external function JAIRY, and on C FLGJY = -1 the AIRY functions BI(X) and DBI(X) are C supplied by the external function YAIRY. C C***SEE ALSO BESJ, BESY C***ROUTINES CALLED I1MACH, R1MACH C***REVISION HISTORY (YYMMDD) C 750101 DATE WRITTEN C 890531 Changed all specific intrinsics to generic. (WRB) C 891009 Removed unreferenced variable. (WRB) C 891214 Prologue converted to Version 4.0 format. (BAB) C 900328 Added TYPE section. (WRB) C 910408 Updated the AUTHOR section. (WRB) C***END PROLOGUE ASYJY C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOMC.INC' CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C INTEGER I, IFLW, IN, J, JN,JR,JU,K, KB,KLAST,KMAX,KP1, KS, KSP1, * KSTEMP, L, LR, LRP1, ISETA, ISETB REAL ABW2, AKM, ALFA, ALFA1, ALFA2, AP, AR, ASUM, AZ, * BETA, BETA1, BETA2, BETA3, BR, BSUM, C, CON1, CON2, * CON548,CR,CRZ32, DFI,ELIM, DR,FI, FLGJY, FN, FNU, * FN2, GAMA, PHI, RCZ, RDEN, RELB, RFN2, RTZ, RZDEN, * SA, SB, SUMA, SUMB, S1, TA, TAU, TB, TFN, TOL, TOLS, T2, UPOL, * WK, X, XX, Y, Z, Z32 DIMENSION Y(*), WK(*), C(65) DIMENSION ALFA(26,4), BETA(26,5) DIMENSION ALFA1(26,2), ALFA2(26,2) DIMENSION BETA1(26,2), BETA2(26,2), BETA3(26,1) DIMENSION GAMA(26), KMAX(5), AR(8), BR(10), UPOL(10) DIMENSION CR(10), DR(10) EQUIVALENCE (ALFA(1,1),ALFA1(1,1)) EQUIVALENCE (ALFA(1,3),ALFA2(1,1)) EQUIVALENCE (BETA(1,1),BETA1(1,1)) EQUIVALENCE (BETA(1,3),BETA2(1,1)) EQUIVALENCE (BETA(1,5),BETA3(1,1)) SAVE TOLS, CON1, CON2, CON548, AR, BR, C, ALFA1, ALFA2, 1 BETA1, BETA2, BETA3, GAMA DATA TOLS /-6.90775527898214E+00/ DATA CON1,CON2,CON548/ 1 6.66666666666667E-01, 3.33333333333333E-01, 1.04166666666667E-01/ DATA AR(1), AR(2), AR(3), AR(4), AR(5), AR(6), AR(7), A AR(8) / 8.35503472222222E-02, 1.28226574556327E-01, 1 2.91849026464140E-01, 8.81627267443758E-01, 3.32140828186277E+00, 2 1.49957629868626E+01, 7.89230130115865E+01, 4.74451538868264E+02/ DATA BR(1), BR(2), BR(3), BR(4), BR(5), BR(6), BR(7), BR(8), A BR(9), BR(10) /-1.45833333333333E-01,-9.87413194444444E-02, 1-1.43312053915895E-01,-3.17227202678414E-01,-9.42429147957120E-01, 2-3.51120304082635E+00,-1.57272636203680E+01,-8.22814390971859E+01, 3-4.92355370523671E+02,-3.31621856854797E+03/ DATA C(1), C(2), C(3), C(4), C(5), C(6), C(7), C(8), C(9), C(10), 1 C(11), C(12), C(13), C(14), C(15), C(16), C(17), C(18), 2 C(19), C(20), C(21), C(22), C(23), C(24)/ 3 -2.08333333333333E-01, 1.25000000000000E-01, 4 3.34201388888889E-01, -4.01041666666667E-01, 5 7.03125000000000E-02, -1.02581259645062E+00, 6 1.84646267361111E+00, -8.91210937500000E-01, 7 7.32421875000000E-02, 4.66958442342625E+00, 8 -1.12070026162230E+01, 8.78912353515625E+00, 9 -2.36408691406250E+00, 1.12152099609375E-01, A -2.82120725582002E+01, 8.46362176746007E+01, B -9.18182415432400E+01, 4.25349987453885E+01, C -7.36879435947963E+00, 2.27108001708984E-01, D 2.12570130039217E+02, -7.65252468141182E+02, E 1.05999045252800E+03, -6.99579627376133E+02/ DATA C(25), C(26), C(27), C(28), C(29), C(30), C(31), C(32), 1 C(33), C(34), C(35), C(36), C(37), C(38), C(39), C(40), 2 C(41), C(42), C(43), C(44), C(45), C(46), C(47), C(48)/ 3 2.18190511744212E+02, -2.64914304869516E+01, 4 5.72501420974731E-01, -1.91945766231841E+03, 5 8.06172218173731E+03, -1.35865500064341E+04, 6 1.16553933368645E+04, -5.30564697861340E+03, 7 1.20090291321635E+03, -1.08090919788395E+02, 8 1.72772750258446E+00, 2.02042913309661E+04, 9 -9.69805983886375E+04, 1.92547001232532E+05, A -2.03400177280416E+05, 1.22200464983017E+05, B -4.11926549688976E+04, 7.10951430248936E+03, C -4.93915304773088E+02, 6.07404200127348E+00, D -2.42919187900551E+05, 1.31176361466298E+06, E -2.99801591853811E+06, 3.76327129765640E+06/ DATA C(49), C(50), C(51), C(52), C(53), C(54), C(55), C(56), 1 C(57), C(58), C(59), C(60), C(61), C(62), C(63), C(64), 2 C(65)/ 3 -2.81356322658653E+06, 1.26836527332162E+06, 4 -3.31645172484564E+05, 4.52187689813627E+04, 5 -2.49983048181121E+03, 2.43805296995561E+01, 6 3.28446985307204E+06, -1.97068191184322E+07, 7 5.09526024926646E+07, -7.41051482115327E+07, 8 6.63445122747290E+07, -3.75671766607634E+07, 9 1.32887671664218E+07, -2.78561812808645E+06, A 3.08186404612662E+05, -1.38860897537170E+04, B 1.10017140269247E+02/ DATA ALFA1(1,1), ALFA1(2,1), ALFA1(3,1), ALFA1(4,1), ALFA1(5,1), 1 ALFA1(6,1), ALFA1(7,1), ALFA1(8,1), ALFA1(9,1), ALFA1(10,1), 2 ALFA1(11,1),ALFA1(12,1),ALFA1(13,1),ALFA1(14,1),ALFA1(15,1), 3 ALFA1(16,1),ALFA1(17,1),ALFA1(18,1),ALFA1(19,1),ALFA1(20,1), 4 ALFA1(21,1),ALFA1(22,1),ALFA1(23,1),ALFA1(24,1),ALFA1(25,1), 5 ALFA1(26,1) /-4.44444444444444E-03,-9.22077922077922E-04, 6-8.84892884892885E-05, 1.65927687832450E-04, 2.46691372741793E-04, 7 2.65995589346255E-04, 2.61824297061501E-04, 2.48730437344656E-04, 8 2.32721040083232E-04, 2.16362485712365E-04, 2.00738858762752E-04, 9 1.86267636637545E-04, 1.73060775917876E-04, 1.61091705929016E-04, 1 1.50274774160908E-04, 1.40503497391270E-04, 1.31668816545923E-04, 2 1.23667445598253E-04, 1.16405271474738E-04, 1.09798298372713E-04, 3 1.03772410422993E-04, 9.82626078369363E-05, 9.32120517249503E-05, 4 8.85710852478712E-05, 8.42963105715700E-05, 8.03497548407791E-05/ DATA ALFA1(1,2), ALFA1(2,2), ALFA1(3,2), ALFA1(4,2), ALFA1(5,2), 1 ALFA1(6,2), ALFA1(7,2), ALFA1(8,2), ALFA1(9,2), ALFA1(10,2), 2 ALFA1(11,2),ALFA1(12,2),ALFA1(13,2),ALFA1(14,2),ALFA1(15,2), 3 ALFA1(16,2),ALFA1(17,2),ALFA1(18,2),ALFA1(19,2),ALFA1(20,2), 4 ALFA1(21,2),ALFA1(22,2),ALFA1(23,2),ALFA1(24,2),ALFA1(25,2), 5 ALFA1(26,2) / 6.93735541354589E-04, 2.32241745182922E-04, 6-1.41986273556691E-05,-1.16444931672049E-04,-1.50803558053049E-04, 7-1.55121924918096E-04,-1.46809756646466E-04,-1.33815503867491E-04, 8-1.19744975684254E-04,-1.06184319207974E-04,-9.37699549891194E-05, 9-8.26923045588193E-05,-7.29374348155221E-05,-6.44042357721016E-05, 1-5.69611566009369E-05,-5.04731044303562E-05,-4.48134868008883E-05, 2-3.98688727717599E-05,-3.55400532972042E-05,-3.17414256609022E-05, 3-2.83996793904175E-05,-2.54522720634871E-05,-2.28459297164725E-05, 4-2.05352753106481E-05,-1.84816217627666E-05,-1.66519330021394E-05/ DATA ALFA2(1,1), ALFA2(2,1), ALFA2(3,1), ALFA2(4,1), ALFA2(5,1), 1 ALFA2(6,1), ALFA2(7,1), ALFA2(8,1), ALFA2(9,1), ALFA2(10,1), 2 ALFA2(11,1),ALFA2(12,1),ALFA2(13,1),ALFA2(14,1),ALFA2(15,1), 3 ALFA2(16,1),ALFA2(17,1),ALFA2(18,1),ALFA2(19,1),ALFA2(20,1), 4 ALFA2(21,1),ALFA2(22,1),ALFA2(23,1),ALFA2(24,1),ALFA2(25,1), 5 ALFA2(26,1) /-3.54211971457744E-04,-1.56161263945159E-04, 6 3.04465503594936E-05, 1.30198655773243E-04, 1.67471106699712E-04, 7 1.70222587683593E-04, 1.56501427608595E-04, 1.36339170977445E-04, 8 1.14886692029825E-04, 9.45869093034688E-05, 7.64498419250898E-05, 9 6.07570334965197E-05, 4.74394299290509E-05, 3.62757512005344E-05, 1 2.69939714979225E-05, 1.93210938247939E-05, 1.30056674793963E-05, 2 7.82620866744497E-06, 3.59257485819352E-06, 1.44040049814252E-07, 3-2.65396769697939E-06,-4.91346867098486E-06,-6.72739296091248E-06, 4-8.17269379678658E-06,-9.31304715093561E-06,-1.02011418798016E-05/ DATA ALFA2(1,2), ALFA2(2,2), ALFA2(3,2), ALFA2(4,2), ALFA2(5,2), 1 ALFA2(6,2), ALFA2(7,2), ALFA2(8,2), ALFA2(9,2), ALFA2(10,2), 2 ALFA2(11,2),ALFA2(12,2),ALFA2(13,2),ALFA2(14,2),ALFA2(15,2), 3 ALFA2(16,2),ALFA2(17,2),ALFA2(18,2),ALFA2(19,2),ALFA2(20,2), 4 ALFA2(21,2),ALFA2(22,2),ALFA2(23,2),ALFA2(24,2),ALFA2(25,2), 5 ALFA2(26,2) / 3.78194199201773E-04, 2.02471952761816E-04, 6-6.37938506318862E-05,-2.38598230603006E-04,-3.10916256027362E-04, 7-3.13680115247576E-04,-2.78950273791323E-04,-2.28564082619141E-04, 8-1.75245280340847E-04,-1.25544063060690E-04,-8.22982872820208E-05, 9-4.62860730588116E-05,-1.72334302366962E-05, 5.60690482304602E-06, 1 2.31395443148287E-05, 3.62642745856794E-05, 4.58006124490189E-05, 2 5.24595294959114E-05, 5.68396208545815E-05, 5.94349820393104E-05, 3 6.06478527578422E-05, 6.08023907788436E-05, 6.01577894539460E-05, 4 5.89199657344698E-05, 5.72515823777593E-05, 5.52804375585853E-05/ DATA BETA1(1,1), BETA1(2,1), BETA1(3,1), BETA1(4,1), BETA1(5,1), 1 BETA1(6,1), BETA1(7,1), BETA1(8,1), BETA1(9,1), BETA1(10,1), 2 BETA1(11,1),BETA1(12,1),BETA1(13,1),BETA1(14,1),BETA1(15,1), 3 BETA1(16,1),BETA1(17,1),BETA1(18,1),BETA1(19,1),BETA1(20,1), 4 BETA1(21,1),BETA1(22,1),BETA1(23,1),BETA1(24,1),BETA1(25,1), 5 BETA1(26,1) / 1.79988721413553E-02, 5.59964911064388E-03, 6 2.88501402231133E-03, 1.80096606761054E-03, 1.24753110589199E-03, 7 9.22878876572938E-04, 7.14430421727287E-04, 5.71787281789705E-04, 8 4.69431007606482E-04, 3.93232835462917E-04, 3.34818889318298E-04, 9 2.88952148495752E-04, 2.52211615549573E-04, 2.22280580798883E-04, 1 1.97541838033063E-04, 1.76836855019718E-04, 1.59316899661821E-04, 2 1.44347930197334E-04, 1.31448068119965E-04, 1.20245444949303E-04, 3 1.10449144504599E-04, 1.01828770740567E-04, 9.41998224204238E-05, 4 8.74130545753834E-05, 8.13466262162801E-05, 7.59002269646219E-05/ DATA BETA1(1,2), BETA1(2,2), BETA1(3,2), BETA1(4,2), BETA1(5,2), 1 BETA1(6,2), BETA1(7,2), BETA1(8,2), BETA1(9,2), BETA1(10,2), 2 BETA1(11,2),BETA1(12,2),BETA1(13,2),BETA1(14,2),BETA1(15,2), 3 BETA1(16,2),BETA1(17,2),BETA1(18,2),BETA1(19,2),BETA1(20,2), 4 BETA1(21,2),BETA1(22,2),BETA1(23,2),BETA1(24,2),BETA1(25,2), 5 BETA1(26,2) /-1.49282953213429E-03,-8.78204709546389E-04, 6-5.02916549572035E-04,-2.94822138512746E-04,-1.75463996970783E-04, 7-1.04008550460816E-04,-5.96141953046458E-05,-3.12038929076098E-05, 8-1.26089735980230E-05,-2.42892608575730E-07, 8.05996165414274E-06, 9 1.36507009262147E-05, 1.73964125472926E-05, 1.98672978842134E-05, 1 2.14463263790823E-05, 2.23954659232457E-05, 2.28967783814713E-05, 2 2.30785389811178E-05, 2.30321976080909E-05, 2.28236073720349E-05, 3 2.25005881105292E-05, 2.20981015361991E-05, 2.16418427448104E-05, 4 2.11507649256221E-05, 2.06388749782171E-05, 2.01165241997082E-05/ DATA BETA2(1,1), BETA2(2,1), BETA2(3,1), BETA2(4,1), BETA2(5,1), 1 BETA2(6,1), BETA2(7,1), BETA2(8,1), BETA2(9,1), BETA2(10,1), 2 BETA2(11,1),BETA2(12,1),BETA2(13,1),BETA2(14,1),BETA2(15,1), 3 BETA2(16,1),BETA2(17,1),BETA2(18,1),BETA2(19,1),BETA2(20,1), 4 BETA2(21,1),BETA2(22,1),BETA2(23,1),BETA2(24,1),BETA2(25,1), 5 BETA2(26,1) / 5.52213076721293E-04, 4.47932581552385E-04, 6 2.79520653992021E-04, 1.52468156198447E-04, 6.93271105657044E-05, 7 1.76258683069991E-05,-1.35744996343269E-05,-3.17972413350427E-05, 8-4.18861861696693E-05,-4.69004889379141E-05,-4.87665447413787E-05, 9-4.87010031186735E-05,-4.74755620890087E-05,-4.55813058138628E-05, 1-4.33309644511266E-05,-4.09230193157750E-05,-3.84822638603221E-05, 2-3.60857167535411E-05,-3.37793306123367E-05,-3.15888560772110E-05, 3-2.95269561750807E-05,-2.75978914828336E-05,-2.58006174666884E-05, 4-2.41308356761280E-05,-2.25823509518346E-05,-2.11479656768913E-05/ DATA BETA2(1,2), BETA2(2,2), BETA2(3,2), BETA2(4,2), BETA2(5,2), 1 BETA2(6,2), BETA2(7,2), BETA2(8,2), BETA2(9,2), BETA2(10,2), 2 BETA2(11,2),BETA2(12,2),BETA2(13,2),BETA2(14,2),BETA2(15,2), 3 BETA2(16,2),BETA2(17,2),BETA2(18,2),BETA2(19,2),BETA2(20,2), 4 BETA2(21,2),BETA2(22,2),BETA2(23,2),BETA2(24,2),BETA2(25,2), 5 BETA2(26,2) /-4.74617796559960E-04,-4.77864567147321E-04, 6-3.20390228067038E-04,-1.61105016119962E-04,-4.25778101285435E-05, 7 3.44571294294968E-05, 7.97092684075675E-05, 1.03138236708272E-04, 8 1.12466775262204E-04, 1.13103642108481E-04, 1.08651634848774E-04, 9 1.01437951597662E-04, 9.29298396593364E-05, 8.40293133016090E-05, 1 7.52727991349134E-05, 6.69632521975731E-05, 5.92564547323195E-05, 2 5.22169308826976E-05, 4.58539485165361E-05, 4.01445513891487E-05, 3 3.50481730031328E-05, 3.05157995034347E-05, 2.64956119950516E-05, 4 2.29363633690998E-05, 1.97893056664022E-05, 1.70091984636413E-05/ DATA BETA3(1,1), BETA3(2,1), BETA3(3,1), BETA3(4,1), BETA3(5,1), 1 BETA3(6,1), BETA3(7,1), BETA3(8,1), BETA3(9,1), BETA3(10,1), 2 BETA3(11,1),BETA3(12,1),BETA3(13,1),BETA3(14,1),BETA3(15,1), 3 BETA3(16,1),BETA3(17,1),BETA3(18,1),BETA3(19,1),BETA3(20,1), 4 BETA3(21,1),BETA3(22,1),BETA3(23,1),BETA3(24,1),BETA3(25,1), 5 BETA3(26,1) / 7.36465810572578E-04, 8.72790805146194E-04, 6 6.22614862573135E-04, 2.85998154194304E-04, 3.84737672879366E-06, 7-1.87906003636972E-04,-2.97603646594555E-04,-3.45998126832656E-04, 8-3.53382470916038E-04,-3.35715635775049E-04,-3.04321124789040E-04, 9-2.66722723047613E-04,-2.27654214122820E-04,-1.89922611854562E-04, 1-1.55058918599094E-04,-1.23778240761874E-04,-9.62926147717644E-05, 2-7.25178327714425E-05,-5.22070028895634E-05,-3.50347750511901E-05, 3-2.06489761035552E-05,-8.70106096849767E-06, 1.13698686675100E-06, 4 9.16426474122779E-06, 1.56477785428873E-05, 2.08223629482467E-05/ DATA GAMA(1), GAMA(2), GAMA(3), GAMA(4), GAMA(5), 1 GAMA(6), GAMA(7), GAMA(8), GAMA(9), GAMA(10), 2 GAMA(11), GAMA(12), GAMA(13), GAMA(14), GAMA(15), 3 GAMA(16), GAMA(17), GAMA(18), GAMA(19), GAMA(20), 4 GAMA(21), GAMA(22), GAMA(23), GAMA(24), GAMA(25), 5 GAMA(26) / 6.29960524947437E-01, 2.51984209978975E-01, 6 1.54790300415656E-01, 1.10713062416159E-01, 8.57309395527395E-02, 7 6.97161316958684E-02, 5.86085671893714E-02, 5.04698873536311E-02, 8 4.42600580689155E-02, 3.93720661543510E-02, 3.54283195924455E-02, 9 3.21818857502098E-02, 2.94646240791158E-02, 2.71581677112934E-02, 1 2.51768272973862E-02, 2.34570755306079E-02, 2.19508390134907E-02, 2 2.06210828235646E-02, 1.94388240897881E-02, 1.83810633800683E-02, 3 1.74293213231963E-02, 1.65685837786612E-02, 1.57865285987918E-02, 4 1.50729501494096E-02, 1.44193250839955E-02, 1.38184805735342E-02/ C***FIRST EXECUTABLE STATEMENT ASYJY TA = R1MACH(3) TOL = MAX(TA,1.0E-15) TB = R1MACH(5) JU = I1MACH(12) IF(FLGJY.EQ.1.0E0) GO TO 6 JR = I1MACH(11) ELIM = -2.303E0*TB*(JU+JR) GO TO 7 6 CONTINUE ELIM = -2.303E0*(TB*JU+3.0E0) 7 CONTINUE FN = FNU IFLW = 0 DO 170 JN=1,IN XX = X/FN WK(1) = 1.0E0 - XX*XX ABW2 = ABS(WK(1)) WK(2) = SQRT(ABW2) WK(7) = FN**CON2 IF (ABW2.GT.0.27750E0) GO TO 80 C C ASYMPTOTIC EXPANSION C CASES NEAR X=FN, ABS(1.-(X/FN)**2).LE.0.2775 C COEFFICIENTS OF ASYMPTOTIC EXPANSION BY SERIES C C ZETA AND TRUNCATION FOR A(ZETA) AND B(ZETA) SERIES C C KMAX IS TRUNCATION INDEX FOR A(ZETA) AND B(ZETA) SERIES=MAX(2,SA) C SA = 0.0E0 IF (ABW2.EQ.0.0E0) GO TO 10 SA = TOLS/LOG(ABW2) 10 SB = SA DO 20 I=1,5 AKM = MAX(SA,2.0E0) KMAX(I) = INT(AKM) SA = SA + SB 20 CONTINUE KB = KMAX(5) KLAST = KB - 1 SA = GAMA(KB) DO 30 K=1,KLAST KB = KB - 1 SA = SA*WK(1) + GAMA(KB) 30 CONTINUE Z = WK(1)*SA AZ = ABS(Z) RTZ = SQRT(AZ) WK(3) = CON1*AZ*RTZ WK(4) = WK(3)*FN WK(5) = RTZ*WK(7) WK(6) = -WK(5)*WK(5) IF(Z.LE.0.0E0) GO TO 35 IF(WK(4).GT.ELIM) GO TO 75 WK(6) = -WK(6) 35 CONTINUE PHI = SQRT(SQRT(SA+SA+SA+SA)) C C B(ZETA) FOR S=0 C KB = KMAX(5) KLAST = KB - 1 SB = BETA(KB,1) DO 40 K=1,KLAST KB = KB - 1 SB = SB*WK(1) + BETA(KB,1) 40 CONTINUE KSP1 = 1 FN2 = FN*FN RFN2 = 1.0E0/FN2 RDEN = 1.0E0 ASUM = 1.0E0 RELB = TOL*ABS(SB) BSUM = SB DO 60 KS=1,4 KSP1 = KSP1 + 1 RDEN = RDEN*RFN2 C C A(ZETA) AND B(ZETA) FOR S=1,2,3,4 C KSTEMP = 5 - KS KB = KMAX(KSTEMP) KLAST = KB - 1 SA = ALFA(KB,KS) SB = BETA(KB,KSP1) DO 50 K=1,KLAST KB = KB - 1 SA = SA*WK(1) + ALFA(KB,KS) SB = SB*WK(1) + BETA(KB,KSP1) 50 CONTINUE TA = SA*RDEN TB = SB*RDEN ASUM = ASUM + TA BSUM = BSUM + TB IF (ABS(TA).LE.TOL .AND. ABS(TB).LE.RELB) GO TO 70 60 CONTINUE 70 CONTINUE BSUM = BSUM/(FN*WK(7)) GO TO 160 C 75 CONTINUE IFLW = 1 RETURN C 80 CONTINUE UPOL(1) = 1.0E0 TAU = 1.0E0/WK(2) T2 = 1.0E0/WK(1) IF (WK(1).GE.0.0E0) GO TO 90 C C CASES FOR (X/FN).GT.SQRT(1.2775) C WK(3) = ABS(WK(2)-ATAN(WK(2))) WK(4) = WK(3)*FN RCZ = -CON1/WK(4) Z32 = 1.5E0*WK(3) RTZ = Z32**CON2 WK(5) = RTZ*WK(7) WK(6) = -WK(5)*WK(5) GO TO 100 90 CONTINUE C C CASES FOR (X/FN).LT.SQRT(0.7225) C WK(3) = ABS(LOG((1.0E0+WK(2))/XX)-WK(2)) WK(4) = WK(3)*FN RCZ = CON1/WK(4) IF(WK(4).GT.ELIM) GO TO 75 Z32 = 1.5E0*WK(3) RTZ = Z32**CON2 WK(7) = FN**CON2 WK(5) = RTZ*WK(7) WK(6) = WK(5)*WK(5) 100 CONTINUE PHI = SQRT((RTZ+RTZ)*TAU) TB = 1.0E0 ASUM = 1.0E0 TFN = TAU/FN RDEN=1.0E0/FN RFN2=RDEN*RDEN RDEN=1.0E0 UPOL(2) = (C(1)*T2+C(2))*TFN CRZ32 = CON548*RCZ BSUM = UPOL(2) + CRZ32 RELB = TOL*ABS(BSUM) AP = TFN KS = 0 KP1 = 2 RZDEN = RCZ L = 2 ISETA=0 ISETB=0 DO 140 LR=2,8,2 C C COMPUTE TWO U POLYNOMIALS FOR NEXT A(ZETA) AND B(ZETA) C LRP1 = LR + 1 DO 120 K=LR,LRP1 KS = KS + 1 KP1 = KP1 + 1 L = L + 1 S1 = C(L) DO 110 J=2,KP1 L = L + 1 S1 = S1*T2 + C(L) 110 CONTINUE AP = AP*TFN UPOL(KP1) = AP*S1 CR(KS) = BR(KS)*RZDEN RZDEN = RZDEN*RCZ DR(KS) = AR(KS)*RZDEN 120 CONTINUE SUMA = UPOL(LRP1) SUMB = UPOL(LR+2) + UPOL(LRP1)*CRZ32 JU = LRP1 DO 130 JR=1,LR JU = JU - 1 SUMA = SUMA + CR(JR)*UPOL(JU) SUMB = SUMB + DR(JR)*UPOL(JU) 130 CONTINUE RDEN=RDEN*RFN2 TB = -TB IF (WK(1).GT.0.0E0) TB = ABS(TB) IF (RDEN.LT.TOL) GO TO 131 ASUM = ASUM + SUMA*TB BSUM = BSUM + SUMB*TB GO TO 140 131 IF(ISETA.EQ.1) GO TO 132 IF(ABS(SUMA).LT.TOL) ISETA=1 ASUM=ASUM+SUMA*TB 132 IF(ISETB.EQ.1) GO TO 133 IF(ABS(SUMB).LT.RELB) ISETB=1 BSUM=BSUM+SUMB*TB 133 IF(ISETA.EQ.1 .AND. ISETB.EQ.1) GO TO 150 140 CONTINUE 150 TB = WK(5) IF (WK(1).GT.0.0E0) TB = -TB BSUM = BSUM/TB C 160 CONTINUE CALL FUNJY(WK(6), WK(5), WK(4), FI, DFI) TA=1.0E0/TOL TB=R1MACH(1)*TA*1.0E+3 IF(ABS(FI).GT.TB) GO TO 165 FI=FI*TA DFI=DFI*TA PHI=PHI*TOL 165 CONTINUE Y(JN) = FLGJY*PHI*(FI*ASUM+DFI*BSUM)/WK(7) FN = FN - FLGJY 170 CONTINUE RETURN END DOUBLE PRECISION FUNCTION ATNINT(XVALUE) C C DESCRIPTION: C C The function ATNINT calculates the value of the C inverse-tangent integral defined by C C ATNINT(x) = integral 0 to x ( (arctan t)/t ) dt C C The approximation uses Chebyshev series with the coefficients C given to an accuracy of 20D. C C C ERROR RETURNS: C C There are no error returns from this program. C C C MACHINE-DEPENDENT CONSTANTS: C C NTERMS - INTEGER - The no. of terms of the array ATNINTT. C The recommended value is such that C ATNINA(NTERMS) < EPS/100 C C XLOW - DOUBLE PRECISION - A bound below which ATNINT(x) = x to machine C precision. The recommended value is C sqrt(EPSNEG/2). C C XUPPER - DOUBLE PRECISION - A bound on x, above which, to machine precision C ATNINT(x) = (pi/2)ln x C The recommended value is 1/EPS. C C For values of EPSNEG and EPS for various machine/compiler C combinations refer to the text file MACHCON.TXT C C The machine-dependent constants are computed internally by C using the D1MACH subroutine. C C C INTRINSIC FUNCTIONS USED: C C ABS , LOG C C C OTHER MISCFUN SUBROUTINES USED: C C CHEVAL , D1MACH C C C AUTHOR: Dr. Allan J. MacLeod, C Dept. of Mathematics and Statistics, C University of Paisley, C High St., C PAISLEY C SCOTLAND C C (e-mail macl_ms0@paisley.ac.uk ) C C C LATEST MODIFICATION: 23 January, 1996 C C C INTEGER IND,NTERMS DOUBLE PRECISION ATNINA(0:22),CHEVAL,HALF,ONE,ONEHUN,T,TWOBPI, & X,XLOW,XUPPER,XVALUE,ZERO C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOMC.INC' CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C DATA ZERO,HALF,ONE/0.0 D 0 , 0.5 D 0 , 1.0 D 0/ DATA ONEHUN/100.0 D 0/ DATA TWOBPI/0.63661 97723 67581 34308 D 0/ DATA ATNINA(0)/ 1.91040 36129 62359 37512 D 0/ DATA ATNINA(1)/ -0.41763 51437 65674 6940 D -1/ DATA ATNINA(2)/ 0.27539 25507 86367 434 D -2/ DATA ATNINA(3)/ -0.25051 80952 62488 81 D -3/ DATA ATNINA(4)/ 0.26669 81285 12117 1 D -4/ DATA ATNINA(5)/ -0.31189 05141 07001 D -5/ DATA ATNINA(6)/ 0.38833 85313 2249 D -6/ DATA ATNINA(7)/ -0.50572 74584 964 D -7/ DATA ATNINA(8)/ 0.68122 52829 49 D -8/ DATA ATNINA(9)/ -0.94212 56165 4 D -9/ DATA ATNINA(10)/ 0.13307 87881 6 D -9/ DATA ATNINA(11)/-0.19126 78075 D -10/ DATA ATNINA(12)/ 0.27891 2620 D -11/ DATA ATNINA(13)/-0.41174 820 D -12/ DATA ATNINA(14)/ 0.61429 87 D -13/ DATA ATNINA(15)/-0.92492 9 D -14/ DATA ATNINA(16)/ 0.14038 7 D -14/ DATA ATNINA(17)/-0.21460 D -15/ DATA ATNINA(18)/ 0.3301 D -16/ DATA ATNINA(19)/-0.511 D -17/ DATA ATNINA(20)/ 0.79 D -18/ DATA ATNINA(21)/-0.12 D -18/ DATA ATNINA(22)/ 0.2 D -19/ C C Compute the machine-dependent constants. C T = D1MACH(4) / ONEHUN DO 10 NTERMS = 22 , 0 , -1 IF ( ABS(ATNINA(NTERMS)) .GT. T ) GOTO 19 10 CONTINUE 19 T = D1MACH(3) XLOW = SQRT( T / ( ONE + ONE ) ) XUPPER = ONE / T C C Start calculation C IND = 1 X = XVALUE IF ( X .LT. ZERO ) THEN X = -X IND = -1 ENDIF C C Code for X < = 1.0 C IF ( X .LE. ONE ) THEN IF ( X .LT. XLOW ) THEN ATNINT = X ELSE T = X * X T = ( T - HALF ) + ( T - HALF ) ATNINT = X * CHEVAL( NTERMS , ATNINA , T ) ENDIF ELSE C C Code for X > 1.0 C IF ( X .GT. XUPPER ) THEN ATNINT = LOG( X ) / TWOBPI ELSE T = ONE / ( X * X ) T = ( T - HALF ) + ( T - HALF ) ATNINT = LOG( X ) / TWOBPI + CHEVAL( NTERMS,ATNINA,T ) / X ENDIF ENDIF IF ( IND .LT. 0 ) ATNINT = - ATNINT RETURN END SUBROUTINE AUTOCR(X,N,IWRITE,XAUTCR,IBUGA3,IERROR) C C PURPOSE--THIS SUBROUTINE COMPUTES THE C SAMPLE AUTOCORRELATION COEFFICIENT C OF THE DATA IN THE INPUT VECTOR X. C THE SAMPLE AUTOCORRELATION COEFFICIENT = THE CORRELATION C BETWEEN X(I) AND X(I+1) OVER THE ENTIRE SAMPLE. C INPUT ARGUMENTS--X = THE SINGLE PRECISION VECTOR OF C (UNSORTED) OBSERVATIONS. C --N = THE INTEGER NUMBER OF OBSERVATIONS C IN THE VECTOR X. C OUTPUT ARGUMENTS--XAUTCR = THE SINGLE PRECISION VALUE OF THE C COMPUTED SAMPLE AUTOCORRELATION C COEFFICIENT. C OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE C SAMPLE AUTOCORRELATION COEFFICIENT. C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--DSQRT. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--JENKINS AND WATTS, SPECTRAL ANALYSIS AND C ITS APPLICATIONS, 1968, PAGES 5, 182, C FORMULA 5.3.33 C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-921-3651 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--82/7 C ORIGINAL VERSION--JUNE 1972. C UPDATED --SEPTEMBER 1975. C UPDATED --NOVEMBER 1975. C UPDATED --JUNE 1979. C UPDATED --AUGUST 1981. C UPDATED --MAY 1982. C UPDATED --JULY 1993.CHANGE DEF. TO BJ, 182, 5.3.33 C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IWRITE CHARACTER*4 IBUGA3 CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C DOUBLE PRECISION DN DOUBLE PRECISION DX DOUBLE PRECISION DX1 DOUBLE PRECISION DX2 DOUBLE PRECISION DSUM DOUBLE PRECISION DMEAN DOUBLE PRECISION DDENOM DOUBLE PRECISION DSUM12 C DIMENSION X(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='AUTO' ISUBN2='CR ' C IERROR='NO' C DN=0.0D0 DMEAN=0.0D0 DSUM12=0.0D0 DDENOM=0.0D0 C IF(IBUGA3.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF AUTOCR--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA3 52 FORMAT('IBUGA3 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)N 53 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') DO55I=1,N WRITE(ICOUT,56)I,X(I) 56 FORMAT('I,X(I) = ',I8,E15.7) CALL DPWRST('XXX','BUG ') 55 CONTINUE 90 CONTINUE C C ******************************************* C ** COMPUTE AUTOCORRELATION COEFFICIENT ** C ******************************************* C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C AN=N C IF(N.GE.1)GOTO119 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,111) 111 FORMAT('***** ERROR IN AUTOCR--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,112) 112 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,113) 113 FORMAT(' IN THE VARIABLE FOR WHICH') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,114) 114 FORMAT(' THE AUTOCORRELATION COEFFICIENT IS TO BE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,115) 115 FORMAT(' COMPUTED, MUST BE 1 OR LARGER.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,116) 116 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,117)N 117 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8, 1'.') CALL DPWRST('XXX','BUG ') GOTO9000 119 CONTINUE C IF(N.EQ.1)GOTO120 GOTO129 120 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,121) 121 FORMAT('***** NON-FATAL DIAGNOSTIC IN AUTOCR--', 1'THE SECOND INPUT ARGUMENT (N) HAS THE VALUE 1') CALL DPWRST('XXX','BUG ') XAUTCR=1.0 GOTO9000 129 CONTINUE C HOLD=X(1) DO135I=2,N IF(X(I).NE.HOLD)GOTO139 135 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,136)HOLD 136 FORMAT('***** NON-FATAL DIAGNOSTIC IN AUTOCR--', 1'THE FIRST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7) CALL DPWRST('XXX','BUG ') XAUTCR=1.0 GOTO9000 139 CONTINUE C 190 CONTINUE C C ************************************************ C ** STEP 2-- ** C ** COMPUTE THE AUTOCORRELATION COEFFICIENT. ** C ************************************************ C CCCCC THE FOLLOWING SECTION WAS REWRITTEN JULY 1993 DN=N DSUM=0.0D0 DO200I=1,N DX=X(I) DSUM=DSUM+DX 200 CONTINUE DMEAN=DSUM/DN C CCCCC THE FOLLOWING SECTION WAS ADDED JULY 1993 DSUM=0.0D0 DO250I=1,N DX=X(I) DSUM=DSUM+(DX-DMEAN)**2 250 CONTINUE DDENOM=DSUM C CCCCC THE FOLLOWING SECTION WAS REWRITTEN JULY 1993 NM1=N-1 DSUM12=0.0D0 DO300I=1,NM1 IP1=I+1 DX1=X(I) DX2=X(IP1) DSUM12=DSUM12+(DX1-DMEAN)*(DX2-DMEAN) 300 CONTINUE XAUTCR=1.0 IF(DDENOM.GT.0.0D0)XAUTCR=DSUM12/DDENOM C C ******************************* C ** STEP 3-- ** C ** WRITE OUT A LINE ** C ** OF SUMMARY INFORMATION. ** C ******************************* C IF(IFEEDB.EQ.'OFF')GOTO890 IF(IWRITE.EQ.'OFF')GOTO890 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,811)N,XAUTCR 811 FORMAT('THE LAG-ONE AUTOCORRELATION COEFFICIENT OF THE ', 1I8,' OBSERVATIONS = ',E15.7) CALL DPWRST('XXX','BUG ') 890 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C 9000 CONTINUE IF(IBUGA3.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF AUTOCR--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGA3,IERROR 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)N 9013 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)DN,DMEAN,DDENOM,DSUM12 9014 FORMAT('DN,DMEAN,DDENOM,DSUM12 = ',4D15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)XAUTCR 9015 FORMAT('XAUTCR = ',E15.7) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE AUTOCV(X,N,IWRITE,XAUTCV,IBUGA3,IERROR) C C PURPOSE--THIS SUBROUTINE COMPUTES THE C SAMPLE AUTOCOVARIANCE COEFFICIENT C OF THE DATA IN THE INPUT VECTOR X. C THE SAMPLE AUTOCOVARIANCE COEFFICIENT = THE COVARIANCE C BETWEEN X(I) AND X(I+1) OVER THE ENTIRE SAMPLE. C INPUT ARGUMENTS--X = THE SINGLE PRECISION VECTOR OF C (UNSORTED) OBSERVATIONS. C --N = THE INTEGER NUMBER OF OBSERVATIONS C IN THE VECTOR X. C OUTPUT ARGUMENTS--XAUTCV = THE SINGLE PRECISION VALUE OF THE C COMPUTED SAMPLE AUTOCOVARIANCE C COEFFICIENT. C OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE C SAMPLE AUTOCOVARIANCE COEFFICIENT. C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--JENKINS AND WATTS, SPECTRAL ANALYSIS AND C ITS APPLICATIONS, 1968, PAGES 5, 180, C FORMULA 5.3.25. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-921-3651 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--82/7 C ORIGINAL VERSION--JUNE 1972. C UPDATED --SEPTEMBER 1975. C UPDATED --NOVEMBER 1975. C UPDATED --JUNE 1979. C UPDATED --AUGUST 1981. C UPDATED --MAY 1982. C UPDATED --JULY 1993.CHANGE DEF. TO BJ, 180, 5.3.25 C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IWRITE CHARACTER*4 IBUGA3 CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C DOUBLE PRECISION DN DOUBLE PRECISION DX DOUBLE PRECISION DX1 DOUBLE PRECISION DX2 DOUBLE PRECISION DSUM CCCCC DOUBLE PRECISION DSUM1 CCCCC DOUBLE PRECISION DSUM2 DOUBLE PRECISION DSUM12 DOUBLE PRECISION DMEAN C DIMENSION X(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='AUTO' ISUBN2='CV ' C IERROR='NO' C DN=0.0D0 DMEAN=0.0D0 DSUM12=0.0D0 C IF(IBUGA3.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF AUTOCV--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA3 52 FORMAT('IBUGA3 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)N 53 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') DO55I=1,N WRITE(ICOUT,56)I,X(I) 56 FORMAT('I,X(I) = ',I8,E15.7) CALL DPWRST('XXX','BUG ') 55 CONTINUE 90 CONTINUE C C ******************************************* C ** COMPUTE AUTOCOVARIANCE COEFFICIENT ** C ******************************************* C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C AN=N C IF(N.GE.1)GOTO119 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,111) 111 FORMAT('***** ERROR IN AUTOCV--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,112) 112 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,113) 113 FORMAT(' IN THE VARIABLE FOR WHICH') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,114) 114 FORMAT(' THE AUTOCOVARIANCE COEFFICIENT IS TO BE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,115) 115 FORMAT(' COMPUTED, MUST BE 1 OR LARGER.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,116) 116 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,117)N 117 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8, 1'.') CALL DPWRST('XXX','BUG ') GOTO9000 119 CONTINUE C IF(N.EQ.1)GOTO120 GOTO129 120 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,121) 121 FORMAT('***** NON-FATAL DIAGNOSTIC IN AUTOCV--', 1'THE SECOND INPUT ARGUMENT (N) HAS THE VALUE 1') CALL DPWRST('XXX','BUG ') XAUTCV=0.0 GOTO9000 129 CONTINUE C HOLD=X(1) DO135I=2,N IF(X(I).NE.HOLD)GOTO139 135 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,136)HOLD 136 FORMAT('***** NON-FATAL DIAGNOSTIC IN AUTOCV--', 1'THE FIRST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7) CALL DPWRST('XXX','BUG ') XAUTCV=0.0 GOTO9000 139 CONTINUE C 190 CONTINUE C C ************************************************ C ** STEP 2-- ** C ** COMPUTE THE AUTOCOVARIANCE COEFFICIENT. ** C ************************************************ C CCCCC THE FOLLOWING SECTION WAS CHANGED JULY 1993 DN=N DSUM=0.0D0 DO200I=1,N DX=X(I) DSUM=DSUM+DX 200 CONTINUE DMEAN=DSUM/DN C CCCCC THE FOLLOWING SECTION WAS CHANGED JULY 1993 NM1=N-1 DSUM12=0.0D0 DO300I=1,NM1 IP1=I+1 DX1=X(I) DX2=X(IP1) DSUM12=DSUM12+(DX1-DMEAN)*(DX2-DMEAN) 300 CONTINUE XAUTCV=DSUM12/DN C C ******************************* C ** STEP 3-- ** C ** WRITE OUT A LINE ** C ** OF SUMMARY INFORMATION. ** C ******************************* C IF(IFEEDB.EQ.'OFF')GOTO890 IF(IWRITE.EQ.'OFF')GOTO890 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,811)N,XAUTCV 811 FORMAT('THE LAG-ONE AUTOCOVARIANCE COEFFICIENT OF THE ', 1I8,' OBSERVATIONS = ',E15.7) CALL DPWRST('XXX','BUG ') 890 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C 9000 CONTINUE IF(IBUGA3.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF AUTOCV--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGA3,IERROR 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)N 9013 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)DN,DMEAN,DSUM12 9014 FORMAT('DN,DMEAN,DSUM12 = ',3D15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)XAUTCV 9015 FORMAT('XAUTCV = ',E15.7) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END REAL FUNCTION AJV(SNV, ITYPE, GAMMA, DELTA, XLAM, XI, IFAULT) CSTART OF AS 100 C C ALGORITHM AS 100.1 APPL. STATIST. (1976) VOL.25, P.190 C C CONVERTS A STANDARD NORMAL VARIATE (SNV) TO A C JOHNSON VARIATE (AJV) C REAL SNV, GAMMA, DELTA, XLAM, XI, V, W, ZERO, HALF, ONE, $ ZABS, ZEXP, ZSIGN C DATA ZERO, HALF, ONE /0.0, 0.5, 1.0/ C ZABS(W) = ABS(W) ZEXP(W) = EXP(W) ZSIGN(W, V) = SIGN(W, V) C AJV = ZERO IFAULT = 1 IF (ITYPE .LT. 1 .OR. ITYPE .GT. 4) RETURN IFAULT = 0 GOTO (10, 20, 30, 40), ITYPE C C SL DISTRIBUTION C 10 AJV = XLAM * ZEXP((XLAM * SNV - GAMMA) / DELTA) + XI RETURN C C SU DISTRIBUTION C 20 W = ZEXP((SNV - GAMMA) / DELTA) W = HALF * (W - ONE / W) AJV = XLAM * W + XI RETURN C C SB DISTRIBUTION C 30 W = (SNV - GAMMA) / DELTA V = ZEXP(-ZABS(W)) V = (ONE - V) / (ONE + V) AJV = HALF * XLAM * (ZSIGN(V, W) + ONE) + XI RETURN C C NORMAL DISTRIBUTION C 40 AJV = (SNV - GAMMA) / DELTA RETURN END SUBROUTINE B2INK(X,NX,Y,NY,FCN,LDF,KX,KY,TX,TY,BCOEF,WORK,IFLAG) C***BEGIN PROLOGUE B2INK C***DATE WRITTEN 25 MAY 1982 C***REVISION DATE 25 MAY 1982 C***CATEGORY NO. E1A C***KEYWORDS INTERPOLATION, TWO-DIMENSIONS, GRIDDED DATA, SPLINES, C PIECEWISE POLYNOMIALS C***AUTHOR BOISVERT, RONALD, NBS C SCIENTIFIC COMPUTING DIVISION C NATIONAL BUREAU OF STANDARDS C WASHINGTON, DC 20234 C***PURPOSE B2INK DETERMINES A PIECEWISE POLYNOMIAL FUNCTION THAT C INTERPOLATES TWO-DIMENSIONAL GRIDDED DATA. USERS SPECIFY C THE POLYNOMIAL ORDER (DEGREE+1) OF THE INTERPOLANT AND C (OPTIONALLY) THE KNOT SEQUENCE. C***DESCRIPTION C C B2INK determines the parameters of a function that interpolates the C two-dimensional gridded data (X(i),Y(j),FCN(i,j)) for i=1,..,NX and C j=1,..,NY. The interpolating function and its derivatives may C subsequently be evaluated by the function B2VAL. C C The interpolating function is a piecewise polynomial function C represented as a tensor product of one-dimensional B-splines. The C form of this function is C C NX NY C S(x,y) = SUM SUM a U (x) V (y) C i=1 j=1 ij i j C C where the functions U(i) and V(j) are one-dimensional B-spline C basis functions. The coefficients a(i,j) are chosen so that C C S(X(i),Y(j)) = FCN(i,j) for i=1,..,NX and j=1,..,NY C C Note that for each fixed value of y S(x,y) is a piecewise C polynomial function of x alone, and for each fixed value of x S(x, C y) is a piecewise polynomial function of y alone. In one dimension C a piecewise polynomial may be created by partitioning a given C interval into subintervals and defining a distinct polynomial piece C on each one. The points where adjacent subintervals meet are called C knots. Each of the functions U(i) and V(j) above is a piecewise C polynomial. C C Users of B2INK choose the order (degree+1) of the polynomial pieces C used to define the piecewise polynomial in each of the x and y C directions (KX and KY). Users also may define their own knot C sequence in x and y separately (TX and TY). If IFLAG=0, however, C B2INK will choose sequences of knots that result in a piecewise C polynomial interpolant with KX-2 continuous partial derivatives in C x and KY-2 continuous partial derivatives in y. (KX knots are taken C near each endpoint, not-a-knot end conditions are used, and the C remaining knots are placed at data points if KX is even or at C midpoints between data points if KX is odd. The y direction is C treated similarly.) C C After a call to B2INK, all information necessary to define the C interpolating function are contained in the parameters NX, NY, KX, C KY, TX, TY, and BCOEF. These quantities should not be altered until C after the last call of the evaluation routine B2VAL. C C C I N P U T C --------- C C X Real 1D array (size NX) C Array of x abcissae. Must be strictly increasing. C C NX Integer scalar (.GE. 3) C Number of x abcissae. C C Y Real 1D array (size NY) C Array of y abcissae. Must be strictly increasing. C C NY Integer scalar (.GE. 3) C Number of y abcissae. C C FCN Real 2D array (size LDF by NY) C Array of function values to interpolate. FCN(I,J) should C contain the function value at the point (X(I),Y(J)) C C LDF Integer scalar (.GE. NX) C The actual leading dimension of FCN used in the calling C calling program. C C KX Integer scalar (.GE. 2, .LT. NX) C The order of spline pieces in x. C (Order = polynomial degree + 1) C C KY Integer scalar (.GE. 2, .LT. NY) C The order of spline pieces in y. C (Order = polynomial degree + 1) C C C I N P U T O R O U T P U T C ----------------------------- C C TX Real 1D array (size NX+KX) C The knots in the x direction for the spline interpolant. C If IFLAG=0 these are chosen by B2INK. C If IFLAG=1 these are specified by the user. C (Must be non-decreasing.) C C TY Real 1D array (size NY+KY) C The knots in the y direction for the spline interpolant. C If IFLAG=0 these are chosen by B2INK. C If IFLAG=1 these are specified by the user. C (Must be non-decreasing.) C C C O U T P U T C ----------- C C BCOEF Real 2D array (size NX by NY) C Array of coefficients of the B-spline interpolant. C This may be the same array as FCN. C C C M I S C E L L A N E O U S C ------------------------- C C WORK Real 1D array (size NX*NY + max( 2*KX*(NX+1), C 2*KY*(NY+1) )) C Array of working storage. C C IFLAG Integer scalar. C On input: 0 == knot sequence chosen by B2INK C 1 == knot sequence chosen by user. C On output: 1 == successful execution C 2 == IFLAG out of range C 3 == NX out of range C 4 == KX out of range C 5 == X not strictly increasing C 6 == TX not non-decreasing C 7 == NY out of range C 8 == KY out of range C 9 == Y not strictly increasing C 10 == TY not non-decreasing C C***REFERENCES CARL DE BOOR, A PRACTICAL GUIDE TO SPLINES, C SPRINGER-VERLAG, NEW YORK, 1978. C CARL DE BOOR, EFFICIENT COMPUTER MANIPULATION OF TENSOR C PRODUCTS, ACM TRANSACTIONS ON MATHEMATICAL SOFTWARE, C VOL. 5 (1979), PP. 173-182. C***ROUTINES CALLED BTPCF,BKNOT C***END PROLOGUE B2INK C C ------------ C DECLARATIONS C ------------ C C PARAMETERS C INTEGER * NX, NY, LDF, KX, KY, IFLAG REAL * X(NX), Y(NY), FCN(LDF,NY), TX(*), TY(*), BCOEF(NX,NY), * WORK(*) C C LOCAL VARIABLES C INTEGER * I, IW, NPK C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C C ----------------------- C CHECK VALIDITY OF INPUT C ----------------------- C C***FIRST EXECUTABLE STATEMENT IF ((IFLAG .LT. 0) .OR. (IFLAG .GT. 1)) GO TO 920 IF (NX .LT. 3) GO TO 930 IF (NY .LT. 3) GO TO 970 IF ((KX .LT. 2) .OR. (KX .GE. NX)) GO TO 940 IF ((KY .LT. 2) .OR. (KY .GE. NY)) GO TO 980 DO 10 I=2,NX IF (X(I) .LE. X(I-1)) GO TO 950 10 CONTINUE DO 20 I=2,NY IF (Y(I) .LE. Y(I-1)) GO TO 990 20 CONTINUE IF (IFLAG .EQ. 0) GO TO 50 NPK = NX + KX DO 30 I=2,NPK IF (TX(I) .LT. TX(I-1)) GO TO 960 30 CONTINUE NPK = NY + KY DO 40 I=2,NPK IF (TY(I) .LT. TY(I-1)) GO TO 1000 40 CONTINUE 50 CONTINUE C C ------------ C CHOOSE KNOTS C ------------ C IF (IFLAG .NE. 0) GO TO 100 CALL BKNOT(X,NX,KX,TX) CALL BKNOT(Y,NY,KY,TY) 100 CONTINUE C C ------------------------------- C CONSTRUCT B-SPLINE COEFFICIENTS C ------------------------------- C IFLAG = 1 IW = NX*NY + 1 CALL BTPCF(X,NX,FCN,LDF,NY,TX,KX,WORK,WORK(IW)) CALL BTPCF(Y,NY,WORK,NY,NX,TY,KY,BCOEF,WORK(IW)) GO TO 9999 C C ----- C EXITS C ----- C 920 CONTINUE WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,921)IFLAG CALL DPWRST('XXX','BUG ') 921 FORMAT('***** FROM B2INK - IFLAG = ',I2,' IS OUT OF RANGE. **') CCCCC* 35,2,1,1,IFLAG,I2,0,R1,R2) IFLAG = 2 GO TO 9999 C 930 CONTINUE IFLAG = 3 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,931)NX CALL DPWRST('XXX','BUG ') 931 FORMAT('***** FROM B2INK - NX = ',I4,' IS OUT OF RANGE. *****') GO TO 9999 C 940 CONTINUE IFLAG = 4 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,941)KX CALL DPWRST('XXX','BUG ') 941 FORMAT('***** FROM B2INK - KX = ',I4,' IS OUT OF RANGE. *****') GO TO 9999 C 950 CONTINUE IFLAG = 5 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,951) CALL DPWRST('XXX','BUG ') 951 FORMAT('***** FROM B2INK - X ARRAY MUST BE STRICTLY INCREASING.') GO TO 9999 C 960 CONTINUE IFLAG = 6 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,961) CALL DPWRST('XXX','BUG ') 961 FORMAT('***** FROM B2INK - TX ARRAY MUST BE NON-DECREASING.') GO TO 9999 C 970 CONTINUE IFLAG = 7 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,971)NY CALL DPWRST('XXX','BUG ') 971 FORMAT('***** FROM B2INK - NY = ',I4,' IS OUT OF RANGE. ****') GO TO 9999 C 980 CONTINUE IFLAG = 8 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,981)KY CALL DPWRST('XXX','BUG ') 981 FORMAT('***** FROM B2INK - KY = ',I4,' IS OUT OF RANGE. *****') GO TO 9999 C 990 CONTINUE IFLAG = 9 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,991) CALL DPWRST('XXX','BUG ') 991 FORMAT('***** FROM B2INK - Y ARRAY MUST BE STRICTLY INCREASING.') GO TO 9999 C 1000 CONTINUE IFLAG = 10 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1001) CALL DPWRST('XXX','BUG ') 1001 FORMAT('***** FROM B2INK - TY ARRAY MUST BE NON-DECREASING. ***') GO TO 9999 C 9999 CONTINUE RETURN END REAL FUNCTION B2VAL(XVAL,YVAL,IDX,IDY,TX,TY,NX,NY, * KX,KY,BCOEF,WORK) C***BEGIN PROLOGUE B2VAL C***DATE WRITTEN 25 MAY 1982 C***REVISION DATE 25 MAY 1982 C***CATEGORY NO. E1A C***KEYWORDS INTERPOLATION, TWO-DIMENSIONS, GRIDDED DATA, SPLINES, C PIECEWISE POLYNOMIALS C***AUTHOR BOISVERT, RONALD, NBS C SCIENTIFIC COMPUTING DIVISION C NATIONAL BUREAU OF STANDARDS C WASHINGTON, DC 20234 C***PURPOSE B2VAL EVALUATES THE PIECEWISE POLYNOMIAL INTERPOLATING C FUNCTION CONSTRUCTED BY THE ROUTINE B2INK OR ONE OF ITS C PARTIAL DERIVATIVES. C***DESCRIPTION C C B2VAL evaluates the tensor product piecewise polynomial interpolant C constructed by the routine B2INK or one of its derivatives at the C point (XVAL,YVAL). To evaluate the interpolant itself, set IDX=IDY= C 0, to evaluate the first partial with respect to x, set IDX=1,IDY= C 0, and so on. C C B2VAL returns 0.0E0 if (XVAL,YVAL) is out of range. That is, if C XVAL.LT.TX(1) .OR. XVAL.GT.TX(NX+KX) .OR. C YVAL.LT.TY(1) .OR. YVAL.GT.TY(NY+NY) C If the knots TX and TY were chosen by B2INK, then this is C equivalent to C XVAL.LT.X(1) .OR. XVAL.GT.X(NX)+EPSX .OR. C YVAL.LT.Y(1) .OR. YVAL.GT.Y(NY)+EPSY C where EPSX = 0.1*(X(NX)-X(NX-1)) and EPSY = 0.1*(Y(NY)-Y(NY-1)). C C The input quantities TX, TY, NX, NY, KX, KY, and BCOEF should be C unchanged since the last call of B2INK. C C C I N P U T C --------- C C XVAL Real scalar C X coordinate of evaluation point. C C YVAL Real scalar C Y coordinate of evaluation point. C C IDX Integer scalar C X derivative of piecewise polynomial to evaluate. C C IDY Integer scalar C Y derivative of piecewise polynomial to evaluate. C C TX Real 1D array (size NX+KX) C Sequence of knots defining the piecewise polynomial in C the x direction. (Same as in last call to B2INK.) C C TY Real 1D array (size NY+KY) C Sequence of knots defining the piecewise polynomial in C the y direction. (Same as in last call to B2INK.) C C NX Integer scalar C The number of interpolation points in x. C (Same as in last call to B2INK.) C C NY Integer scalar C The number of interpolation points in y. C (Same as in last call to B2INK.) C C KX Integer scalar C Order of polynomial pieces in x. C (Same as in last call to B2INK.) C C KY Integer scalar C Order of polynomial pieces in y. C (Same as in last call to B2INK.) C C BCOEF Real 2D array (size NX by NY) C The B-spline coefficients computed by B2INK. C C WORK Real 1D array (size 3*max(KX,KY) + KY) C A working storage array. C C***REFERENCES CARL DE BOOR, A PRACTICAL GUIDE TO SPLINES, C SPRINGER-VERLAG, NEW YORK, 1978. C***ROUTINES CALLED INTRV,BVALU C***END PROLOGUE B2VAL C C ------------ C DECLARATIONS C ------------ C C PARAMETERS C INTEGER * IDX, IDY, NX, NY, KX, KY REAL * XVAL, YVAL, TX(*), TY(*), BCOEF(NX,NY), WORK(*) C C LOCAL VARIABLES C INTEGER * ILOY, INBVX, INBV, K, LEFTY, MFLAG, KCOL, IW REAL * BVALU C DATA ILOY /1/, INBVX /1/ C SAVE ILOY , INBVX C C C***FIRST EXECUTABLE STATEMENT B2VAL = 0.0E0 CALL INTRV(TY,NY+KY,YVAL,ILOY,LEFTY,MFLAG) IF (MFLAG .NE. 0) GO TO 100 IW = KY + 1 KCOL = LEFTY - KY DO 50 K=1,KY KCOL = KCOL + 1 WORK(K) = BVALU(TX,BCOEF(1,KCOL),NX,KX,IDX,XVAL,INBVX, * WORK(IW)) 50 CONTINUE INBV = 1 KCOL = LEFTY - KY + 1 B2VAL = BVALU(TY(KCOL),WORK,KY,KY,IDY,YVAL,INBV,WORK(IW)) 100 CONTINUE RETURN END SUBROUTINE BACK25(X2,M,N,RIGHT2,B,IBUGA3) C C PURPOSE--BACK SOLVE A TRIANGULARIZED SYSTEM C WHICH (IT IS ASSUMED) HAS BEEN TRIANGULARIZED C AND RESIDES IN THE UPPER TRIANGLE OF X2(.,.) C AND THE RESPONSE VECTOR HAS BEEN CARRIED ALONG C AND THE MODIFIED RESPONSE VECTOR NOW RESIDES IN C THE (N+1)ST COLUMN OF X C NOTE--A CALL TO BACK25 IS TYPICALLY C PRECEEDED BY A CALL TO TRIA25 C WHICH WILL CARRY OUT THE C TRIANGULARIZATION OF THE MATRIX. C NOTE--THE DIMENSIONS OF X2 MUST BE THE SAME C IN THE CALLING ROUTINE AS IN THIS SUBROUTINE. C THEY HAVE BEEN SET HEREIN TO 25 BY 25, C AND HENCE THE 25 IN THE NAME OF THIS SUBROUTINE (BACK25). C NOTE--BACK25 IS IDENTICAL TO BACK50 AND BACKSO C EXCEPT FOR THE DIMENSIONS. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-921-3651 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION--FEBRUARY 1978. C UPDATED --JULY 1981. C UPDATED --AUGUST 1981. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IBUGA3 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C DIMENSION X2(25,25) DIMENSION RIGHT2(*) DIMENSION B(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='BACK' ISUBN2='25 ' C IF(IBUGA3.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF BACK25--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)M,N,IBUGA3 52 FORMAT('M,N,IBUGA3 = ',2I8,2X,A4) CALL DPWRST('XXX','BUG ') DO55I=1,M WRITE(ICOUT,56)I,(X2(I,J),J=1,N) 56 FORMAT('I,X2(I,.) = ',I8,10E10.3) CALL DPWRST('XXX','BUG ') 55 CONTINUE DO60I=1,M WRITE(ICOUT,61)I,RIGHT2(I) 61 FORMAT('I,RIGHT2(I)= ',I8,E10.3) CALL DPWRST('XXX','BUG ') 60 CONTINUE 90 CONTINUE C I=M 100 CONTINUE SUM=0.0 IP1=I+1 IF(IP1.GT.M)GOTO250 DO200J=IP1,M SUM=SUM+B(J)*X2(I,J) 200 CONTINUE 250 CONTINUE DEL=RIGHT2(I)-SUM B(I)=DEL/X2(I,I) I=I-1 IF(I.GE.1)GOTO100 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGA3.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF BACK25--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)M,N,IBUGA3 9012 FORMAT('M,N,IBUGA3 = ',2I8,2X,A4) CALL DPWRST('XXX','BUG ') DO9015I=1,M WRITE(ICOUT,9016)I,(X2(I,J),J=1,N) 9016 FORMAT('I,X2(I,.) = ',I8,10E10.3) CALL DPWRST('XXX','BUG ') 9015 CONTINUE DO9020I=1,M WRITE(ICOUT,9021)I,RIGHT2(I),B(I) 9021 FORMAT('I,RIGHT2(I),B(I) = ',I8,2E10.3) CALL DPWRST('XXX','BUG ') 9020 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE BACK50(X2,M,N,RIGHT2,B,IBUGA3) C C PURPOSE--BACK SOLVE A TRIANGULARIZED SYSTEM C WHICH (IT IS ASSUMED) HAS BEEN TRIANGULARIZED C AND RESIDES IN THE UPPER TRIANGLE OF X2(.,.) C AND THE RESPONSE VECTOR HAS BEEN CARRIED ALONG C AND THE MODIFIED RESPONSE VECTOR NOW RESIDES IN C THE (N+1)ST COLUMN OF X C NOTE--A CALL TO BACK50 IS TYPICALLY C PRECEEDED BY A CALL TO TRIA50 C WHICH WILL CARRY OUT THE C TRIANGULARIZATION OF THE MATRIX. C NOTE--THE DIMENSIONS OF X2 MUST BE THE SAME C IN THE CALLING ROUTINE AS IN THIS SUBROUTINE. C THEY HAVE BEEN SET HEREIN TO 50 BY 50, C AND HENCE THE 50 IN THE NAME OF THIS SUBROUTINE (BACK50). C NOTE--BACK50 IS IDENTICAL TO BACK25 AND BACKSO C EXCEPT FOR THE DIMENSIONS. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-921-3651 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION--FEBRUARY 1978. C UPDATED --JULY 1981. C UPDATED --AUGUST 1981. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IBUGA3 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C DIMENSION X2(50,50) DIMENSION RIGHT2(*) DIMENSION B(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='BACK' ISUBN2='50 ' C IF(IBUGA3.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF BACK25--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)M,N,IBUGA3 52 FORMAT('M,N,IBUGA3 = ',2I8,2X,A4) CALL DPWRST('XXX','BUG ') DO55I=1,M WRITE(ICOUT,56)I,(X2(I,J),J=1,N) 56 FORMAT('I,X2(I,.) = ',I8,10E10.3) CALL DPWRST('XXX','BUG ') 55 CONTINUE DO60I=1,M WRITE(ICOUT,61)I,RIGHT2(I) 61 FORMAT('I,RIGHT2(I)= ',I8,E10.3) CALL DPWRST('XXX','BUG ') 60 CONTINUE 90 CONTINUE C I=M 100 CONTINUE SUM=0.0 IP1=I+1 IF(IP1.GT.M)GOTO250 DO200J=IP1,M SUM=SUM+B(J)*X2(I,J) 200 CONTINUE 250 CONTINUE DEL=RIGHT2(I)-SUM B(I)=DEL/X2(I,I) I=I-1 IF(I.GE.1)GOTO100 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGA3.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF BACK25--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)M,N,IBUGA3 9012 FORMAT('M,N,IBUGA3 = ',2I8,2X,A4) CALL DPWRST('XXX','BUG ') DO9015I=1,M WRITE(ICOUT,9016)I,(X2(I,J),J=1,N) 9016 FORMAT('I,X2(I,.) = ',I8,10E10.3) CALL DPWRST('XXX','BUG ') 9015 CONTINUE DO9020I=1,M WRITE(ICOUT,9021)I,RIGHT2(I),B(I) 9021 FORMAT('I,RIGHT2(I),B(I) = ',I8,2E10.3) CALL DPWRST('XXX','BUG ') 9020 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE BACKLC(Z,AA,NN,B) C BACKLC RECEIVES FROM ROUTINE BESLCF Z,AA, AND NN SUCH THAT BESLCR C WANTS TO CALCULATE BESSEL FUNCTIONS J-SUB-(NN+AA)-OF-Z (AND LOWER C ORDERS). IT RETURNS NN AND B (=J-SUB-NN+A) WITH WHICH TO START THE C BACK-RECURSION. THE METHOD IS DESCRIBED IN REFERENCES (3) AND (4) C LISTED IN BESLCF. C C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOMC.INC' CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C COMPLEX B,P,PLAST,POLD,PSAVE,TEMPC,Z,ZINV,ZDUMMY C--------------------------------------------------------------------- C C MACHINE DEPENDENT CONSTANTS. C --------------------------- C C EXPLANATION OF MACHINE-DEPENDENT CONSTANTS C C DYOUK WORKING ACCURACY OF THE COMPUTER. C DYOUKI 1./DYOUK C SQRDKI SQRT(DYOUKI) C TOVER DYOUK/(SMALLEST POSITIVE MACHINE-REPRESENTABLE REAL NUMBER) C SAVE ISAVE,DYOUK,DYOUKI,SQRDKI,TOVER,LOU DATA ISAVE /1/ C C Definition of real and imaginary parts of complex number, C standard Fortran and will work on Convex with -r8 -i8. REALP(ZDUMMY) = REAL(ZDUMMY) AIMAGP(ZDUMMY) = REAL((0,-1)*ZDUMMY) C IF (ISAVE.GT.0) THEN ISAVE = 0 DYOUK = R1MACH (4) DYOUKI = 1.0 / DYOUK SQRDKI = SQRT (DYOUKI) TOVER = DYOUK / R1MACH (1) LOU = I1MACH(2) ENDIF C C----------------------------------------------------------------------- A=AA ZINV=2./Z ZMAG=ABS(Z) MAGZ=ZMAG-A NB=NN NB1=NB+1 N=MAGZ+1 NSTART=N+1 PLAST = (1.0, 0.0) P=ZINV*(REAL(N)+A) TEST=DYOUKI M=0 IF(NSTART.GT.NB) GO TO 6 C CALCULATE P*S UNTIL N=NB, AND CHECK FOR POSSIBLE OVERFLOW. C Set C here to avoid Univac FTN compiler warning that C arises because it does not know that NSTART cannot exceed NB. C = 0.0 DO 5 N=NSTART,NB POLD=PLAST PLAST=P P=(REAL(N)+A)*PLAST*ZINV-POLD C=MAX(ABS(REALP(P)),ABS(AIMAGP(P))) IF(C.GT.TOVER) GO TO 7 5 CONTINUE N=NB TEST=SQRDKI*C C=1./C TEST=TEST*SQRT(ABS((P*C)*(PLAST*C))) TEST=MAX(TEST,DYOUKI) C CALCULATE P*S UNTIL THE SIGNIFICANCE TEST ABOVE IS PASSED. 6 N=N+1 POLD=PLAST PLAST=P P=(REAL(N)+A)*PLAST*ZINV-POLD C=MAX(ABS(REALP(P)),ABS(AIMAGP(P))) IF(C.LT.TEST) GO TO 6 IF(M.EQ.1) GO TO 12 C CALCULATE STRICT VARIANT OF SIGNIFICANCE TEST, AND C CALCULATE P*S UNTIL THIS TEST IS PASSED. M=1 E=ABS(P)/ABS(PLAST) D=(REAL(N+1)+A)/ZMAG IF(E+1./E.GT.2.*D) E=D+SQRT(D*D-1.) E=E-1./E IF(E.GE.(TEST/C)**2) GO TO 12 TEST=TEST/SQRT(E) GO TO 6 7 NSTART=N+1 C TO AVOID OVERFLOW, NORMALIZE P*S BY DIVIDING BY TOVER. C CALCULATE P*S UNTIL UNNORMALIZED P WOULD OVERFLOW. P=CMPLX(REALP(P)/TOVER,AIMAGP(P)/TOVER) PLAST=CMPLX(REALP(PLAST)/TOVER,AIMAGP(PLAST)/TOVER) PSAVE=P TEMPC=PLAST 8 N=N+1 POLD=PLAST PLAST=P P=(REAL(N)+A)*PLAST*ZINV-POLD IF(ABS(REALP(P))+ABS(AIMAGP(P)).LE.DYOUKI) GO TO 8 C CALCULATE BACKWARD TEST, AND FIND NCALC, THE HIGHEST N C SUCH THAT THE TEST IS PASSED. C=(REAL(N)+A)/ZMAG D=ABS(PLAST/POLD) E=(REALP(PLAST)**2+AIMAGP(PLAST)**2)*(REALP(POLD)**2+ 1 AIMAGP(POLD)**2) IF(D+1./D.GT.2.*C) D=C+SQRT(C*C-1.) TEST=E*(DYOUK*(1.-D**(-2)))**2 P=PLAST*CMPLX(TOVER,0.) N=N-1 NEND=MIN(N,NB1) DO 9 NCALC=NSTART,NEND POLD=TEMPC TEMPC=PSAVE PSAVE=(REAL(N)+A)*TEMPC*ZINV-POLD POLD=PSAVE*TEMPC IF(REALP(POLD)**2+AIMAGP(POLD)**2.GE.TEST) GO TO 10 9 CONTINUE NCALC=NEND+1 10 IF (NCALC .LE. NB) THEN WRITE (ICOUT,11) Z CALL DPWRST('XXX','BUG') WRITE (ICOUT,13) A, NCALC CALL DPWRST('XXX','BUG') ENDIF 11 FORMAT('***** WARNING FROM BACKLC--- FOR Z = ', 2(1PE22.14)) 13 FORMAT(' AND A = ',F14.12,' BJ(N) FOR N GREATER THAN ',I5, 1 ' HAS LOW ACCURACY DUE TO UNDERFLOW') C=TOVER 12 P=1./CMPLX(REALP(P)/C,AIMAGP(P)/C) B= CMPLX(REALP(P)/C,AIMAGP(P)/C) NN=N RETURN END SUBROUTINE BAKSLV(NR,N,A,X,B) IMPLICIT DOUBLE PRECISION (A-H,O-Z) C C PURPOSE C ------- C SOLVE AX=B WHERE A IS UPPER TRIANGULAR MATRIX. C NOTE THAT A IS INPUT AS A LOWER TRIANGULAR MATRIX AND C THAT THIS ROUTINE TAKES ITS TRANSPOSE IMPLICITLY. C C PARAMETERS C ---------- C NR --> ROW DIMENSION OF MATRIX C N --> DIMENSION OF PROBLEM C A(N,N) --> LOWER TRIANGULAR MATRIX (PRESERVED) C X(N) <-- SOLUTION VECTOR C B(N) --> RIGHT-HAND SIDE VECTOR C C NOTE C ---- C IF B IS NO LONGER REQUIRED BY CALLING ROUTINE, C THEN VECTORS B AND X MAY SHARE THE SAME STORAGE. C DIMENSION A(NR,1),X(N),B(N) C C SOLVE (L-TRANSPOSE)X=B. (BACK SOLVE) C I=N X(I)=B(I)/A(I,I) IF(N.EQ.1) RETURN 30 IP1=I I=I-1 SUM=0. DO 40 J=IP1,N SUM=SUM+A(J,I)*X(J) 40 CONTINUE X(I)=(B(I)-SUM)/A(I,I) IF(I.GT.1) GO TO 30 RETURN END SUBROUTINE BALANC(NM,N,A,LOW,IGH,SCALE) C***BEGIN PROLOGUE BALANC C***DATE WRITTEN 760101 (YYMMDD) C***REVISION DATE 830518 (YYMMDD) C***CATEGORY NO. D4C1A C***KEYWORDS EIGENVALUES,EIGENVECTORS,EISPACK C***AUTHOR SMITH, B. T., ET AL. C***PURPOSE Balances a general real matrix and isolates eigenvalue C whenever possible. C***DESCRIPTION C C This subroutine is a translation of the ALGOL procedure BALANCE, C NUM. MATH. 13, 293-304(1969) by Parlett and Reinsch. C HANDBOOk FOR AUTO. COMP., Vol.II-LINEAR ALGEBRA, 315-326(1971). C C This subroutine balances a REAL matrix and isolates C eigenvalues whenever possible. C C On INPUT C C NM must be set to the row dimension of two-dimensional C array parameters as declared in the calling program C dimension statement. C C N is the order of the matrix. C C A contains the input matrix to be balanced. C C On OUTPUT C C A contains the balanced matrix. C C LOW and IGH are two integers such that A(I,J) C is equal to zero if C (1) I is greater than J and C (2) J=1,...,LOW-1 or I=IGH+1,...,N. C C SCALE contains information determining the C permutations and scaling factors used. C C Suppose that the principal submatrix in rows LOW through IGH C has been balanced, that P(J) denotes the index interchanged C with J during the permutation step, and that the elements C of the diagonal matrix used are denoted by D(I,J). Then C SCALE(J) = P(J), for J = 1,...,LOW-1 C = D(J,J), J = LOW,...,IGH C = P(J) J = IGH+1,...,N. C The order in which the interchanges are made is N to IGH+1, C then 1 TO LOW-1. C C Note that 1 is returned for IGH if IGH is zero formally. C C The ALGOL procedure EXC contained in BALANCE appears in C BALANC in line. (Note that the ALGOL roles of identifiers C K,L have been reversed.) C C Questions and comments should be directed to B. S. Garbow, C Applied Mathematics Division, ARGONNE NATIONAL LABORATORY C ------------------------------------------------------------------ C***REFERENCES B. T. SMITH, J. M. BOYLE, J. J. DONGARRA, B. S. GARBOW, C Y. IKEBE, V. C. KLEMA, C. B. MOLER, *MATRIX EIGEN- C SYSTEM ROUTINES - EISPACK GUIDE*, SPRINGER-VERLAG, C 1976. C***ROUTINES CALLED (NONE) C***END PROLOGUE BALANC C INTEGER I,J,K,L,M,N,JJ,NM,IGH,LOW,IEXC REAL A(NM,N),SCALE(N) REAL C,F,G,R,S,B2,RADIX LOGICAL NOCONV C C***FIRST EXECUTABLE STATEMENT BALANC RADIX = 16 C B2 = RADIX * RADIX K = 1 L = N GO TO 100 C .......... IN-LINE PROCEDURE FOR ROW AND C COLUMN EXCHANGE .......... 20 SCALE(M) = J IF (J .EQ. M) GO TO 50 C DO 30 I = 1, L F = A(I,J) A(I,J) = A(I,M) A(I,M) = F 30 CONTINUE C DO 40 I = K, N F = A(J,I) A(J,I) = A(M,I) A(M,I) = F 40 CONTINUE C 50 GO TO (80,130), IEXC C .......... SEARCH FOR ROWS ISOLATING AN EIGENVALUE C AND PUSH THEM DOWN .......... 80 IF (L .EQ. 1) GO TO 280 L = L - 1 C .......... FOR J=L STEP -1 UNTIL 1 DO -- .......... 100 DO 120 JJ = 1, L J = L + 1 - JJ C DO 110 I = 1, L IF (I .EQ. J) GO TO 110 IF (A(J,I) .NE. 0.0E0) GO TO 120 110 CONTINUE C M = L IEXC = 1 GO TO 20 120 CONTINUE C GO TO 140 C .......... SEARCH FOR COLUMNS ISOLATING AN EIGENVALUE C AND PUSH THEM LEFT .......... 130 K = K + 1 C 140 DO 170 J = K, L C DO 150 I = K, L IF (I .EQ. J) GO TO 150 IF (A(I,J) .NE. 0.0E0) GO TO 170 150 CONTINUE C M = K IEXC = 2 GO TO 20 170 CONTINUE C .......... NOW BALANCE THE SUBMATRIX IN ROWS K TO L .......... DO 180 I = K, L 180 SCALE(I) = 1.0E0 C .......... ITERATIVE LOOP FOR NORM REDUCTION .......... 190 NOCONV = .FALSE. C DO 270 I = K, L C = 0.0E0 R = 0.0E0 C DO 200 J = K, L IF (J .EQ. I) GO TO 200 C = C + ABS(A(J,I)) R = R + ABS(A(I,J)) 200 CONTINUE C .......... GUARD AGAINST ZERO C OR R DUE TO UNDERFLOW .......... IF (C .EQ. 0.0E0 .OR. R .EQ. 0.0E0) GO TO 270 G = R / RADIX F = 1.0E0 S = C + R 210 IF (C .GE. G) GO TO 220 F = F * RADIX C = C * B2 GO TO 210 220 G = R * RADIX 230 IF (C .LT. G) GO TO 240 F = F / RADIX C = C / B2 GO TO 230 C .......... NOW BALANCE .......... 240 IF ((C + R) / F .GE. 0.95E0 * S) GO TO 270 G = 1.0E0 / F SCALE(I) = SCALE(I) * F NOCONV = .TRUE. C DO 250 J = K, N 250 A(I,J) = A(I,J) * G C DO 260 J = 1, L 260 A(J,I) = A(J,I) * F C 270 CONTINUE C IF (NOCONV) GO TO 190 C 280 LOW = K IGH = L RETURN END SUBROUTINE BALBAK(NM,N,LOW,IGH,SCALE,M,Z) C***BEGIN PROLOGUE BALBAK C***DATE WRITTEN 760101 (YYMMDD) C***REVISION DATE 830518 (YYMMDD) C***CATEGORY NO. D4C4 C***KEYWORDS EIGENVALUES,EIGENVECTORS,EISPACK C***AUTHOR SMITH, B. T., ET AL. C***PURPOSE Forms eigenvectors of real general matrix from C eigenvectors of matrix output from BALANC. C***DESCRIPTION C C This subroutine is a translation of the ALGOL procedure BALBAK, C NUM. MATH. 13, 293-304(1969) by Parlett and Reinsch. C HANDBOOK FOR AUTO. COMP., Vol.II-LINEAR ALGEBRA, 315-326(1971). C C This subroutine forms the eigenvectors of a REAL GENERAL C matrix by back transforming those of the corresponding C balanced matrix determined by BALANC. C C On INPUT C C NM must be set to the row dimension of two-dimensional C array parameters as declared in the calling program C dimension statement. C C N is the order of the matrix. C C LOW and IGH are integers determined by BALANC. C C SCALE contains information determining the permutations C and scaling factors used by BALANC. C C M is the number of columns of Z to be back transformed. C C Z contains the real and imaginary parts of the eigen- C vectors to be back transformed in its first M columns. C C On OUTPUT C C Z contains the real and imaginary parts of the C transformed eigenvectors in its first M columns. C C Questions and comments should be directed to B. S. Garbow, C Applied Mathematics Division, ARGONNE NATIONAL LABORATORY C ------------------------------------------------------------------ C***REFERENCES B. T. SMITH, J. M. BOYLE, J. J. DONGARRA, B. S. GARBOW, C Y. IKEBE, V. C. KLEMA, C. B. MOLER, *MATRIX EIGEN- C SYSTEM ROUTINES - EISPACK GUIDE*, SPRINGER-VERLAG, C 1976. C***ROUTINES CALLED (NONE) C***END PROLOGUE BALBAK C INTEGER I,J,K,M,N,II,NM,IGH,LOW REAL SCALE(N),Z(NM,M) REAL S C C***FIRST EXECUTABLE STATEMENT BALBAK IF (M .EQ. 0) GO TO 200 IF (IGH .EQ. LOW) GO TO 120 C DO 110 I = LOW, IGH S = SCALE(I) C .......... LEFT HAND EIGENVECTORS ARE BACK TRANSFORMED C IF THE FOREGOING STATEMENT IS REPLACED BY C S=1.0E0/SCALE(I). .......... DO 100 J = 1, M 100 Z(I,J) = Z(I,J) * S C 110 CONTINUE C ......... FOR I=LOW-1 STEP -1 UNTIL 1, C IGH+1 STEP 1 UNTIL N DO -- .......... 120 DO 140 II = 1, N I = II IF (I .GE. LOW .AND. I .LE. IGH) GO TO 140 IF (I .LT. LOW) I = LOW - II K = SCALE(I) IF (K .EQ. I) GO TO 140 C DO 130 J = 1, M S = Z(I,J) Z(I,J) = Z(K,J) Z(K,J) = S 130 CONTINUE C 140 CONTINUE C 200 RETURN END SUBROUTINE BASRUL( NDIM, A, B, WIDTH, FUNCTN, W, LENRUL, G, & CENTER, Z, RGNERT, BASEST ) * * For application of basic integration rule * EXTERNAL FUNCTN INTEGER I, LENRUL, NDIM DOUBLE PRECISION & A(NDIM), B(NDIM), WIDTH(NDIM), FUNCTN, W(LENRUL,4), & G(NDIM,LENRUL), CENTER(NDIM), Z(NDIM), RGNERT, BASEST DOUBLE PRECISION & FULSUM, FSYMSM, RGNCMP, RGNVAL, RGNVOL, RGNCPT, RGNERR * * Compute Volume and Center of Subregion * RGNVOL = 1 DO 100 I = 1,NDIM RGNVOL = 2*RGNVOL*WIDTH(I) CENTER(I) = A(I) + WIDTH(I) 100 CONTINUE BASEST = 0 RGNERT = 0 * * Compute basic rule and error * 10 RGNVAL = 0 RGNERR = 0 RGNCMP = 0 RGNCPT = 0 DO 200 I = 1,LENRUL FSYMSM = FULSUM(NDIM, CENTER, WIDTH, Z, G(1,I), FUNCTN) * Basic Rule RGNVAL = RGNVAL + W(I,1)*FSYMSM * First comparison rule RGNERR = RGNERR + W(I,2)*FSYMSM * Second comparison rule RGNCMP = RGNCMP + W(I,3)*FSYMSM * Third Comparison rule RGNCPT = RGNCPT + W(I,4)*FSYMSM 200 CONTINUE * * Error estimation * RGNERR = SQRT(RGNCMP**2 + RGNERR**2) RGNCMP = SQRT(RGNCPT**2 + RGNCMP**2) IF ( 4*RGNERR .LT. RGNCMP ) RGNERR = RGNERR/2 IF ( 2*RGNERR .GT. RGNCMP ) RGNERR = MAX( RGNERR, RGNCMP ) RGNERT = RGNERT + RGNVOL*RGNERR BASEST = BASEST + RGNVOL*RGNVAL * * When subregion has more than one piece, determine next piece and * loop back to apply basic rule. * DO 300 I = 1,NDIM CENTER(I) = CENTER(I) + 2*WIDTH(I) IF ( CENTER(I) .LT. B(I) ) GO TO 10 CENTER(I) = A(I) + WIDTH(I) 300 CONTINUE C RETURN END SUBROUTINE BBNCDF(X,V,W,N,CDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY C FUNCTION VALUE AT THE SINGLE PRECISION VALUE X C FOR THE BETA-BINOMIAL DISTRIBUTION C WITH SINGLE PRECISION PARAMETERS V AND W C AND INTEGER 'NUMBER OF BERNOULLI TRIALS' C PARAMETER = N. C IF V AND W ARE INTEGERS, THIS BECOMES THE NEGATIVE C HYPERGEOMETRIC DISTRIBUTION. C THIS DISTRIBUTION IS DEFINED FOR ALL C DISCRETE INTEGER X BETWEEN 0 (INCLUSIVELY) C AND N (INCLUSIVELY). C THIS DISTRIBUTION HAS THE PROBABILITY FUNCTION C F(X) = B(N-X+V,X+B)/[(N+1)*B(N-X+1,X+1)*B(V,W) C WHERE B(A,B) IS THE BETA FUNCTION. C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE C AT WHICH THE CUMULATIVE DISTRIBUTION C FUNCTION IS TO BE EVALUATED. C X SHOULD BE INTEGRAL-VALUED, C AND BETWEEN 0.0 (INCLUSIVELY) C AND N (INCLUSIVELY). C --V = THE SINGLE PRECISION VALUE C OF THE FIRST SHAPE PARAMETER. C --W = THE SINGLE PRECISION VALUE C OF THE SECOND SHAPE PARAMETER. C --N = THE INTEGER VALUE C OF THE 'NUMBER OF BERNOULLI TRIALS' C PARAMETER. C N SHOULD BE A POSITIVE INTEGER. C OUTPUT ARGUMENTS--CDF = THE SINGLE PRECISION CUMULATIVE C DISTRIBUTION FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION C FUNCTION VALUE CDF C FOR THE BINOMIAL DISTRIBUTION C WITH 'BERNOULLI PROBABILITY' PARAMETER = P C AND 'NUMBER OF BERNOULLI TRIALS' PARAMETER = N. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--X SHOULD BE INTEGRAL-VALUED, C AND BETWEEN 0.0 (INCLUSIVELY) C AND N (INCLUSIVELY). C --P SHOULD BE BETWEEN 0.0 (EXCLUSIVELY) C AND 1.0 (EXCLUSIVELY). C --N SHOULD BE A POSITIVE INTEGER. C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--DSQRT, DATAN. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--HASTINGS AND PEACOCK, STATISTICAL C DISTRIBUTIONS--2ND ED., CHAPTER 5 C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--96/2 C ORIGINAL VERSION--FEBRUARY 1996. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DX, DV, DW, DN, DCDF DOUBLE PRECISION DTERM1, DTERM2, DTERM3, DTERM4 DOUBLE PRECISION DLBETA DOUBLE PRECISION DSUM1, DSUM2 C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C CDF=0.0 C C CHECK THE INPUT ARGUMENTS FOR ERRORS C AN=N IF(V.LE.0.0)THEN WRITE(ICOUT,11) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)V CALL DPWRST('XXX','BUG ') CDF=0.0 GOTO9999 ENDIF IF(W.LE.0.0)THEN WRITE(ICOUT,12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)V CALL DPWRST('XXX','BUG ') CDF=0.0 GOTO9999 ENDIF IF(N.LE.0)THEN WRITE(ICOUT,25) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)N CALL DPWRST('XXX','BUG ') CDF=0.0 GOTO9999 ENDIF INTX=X+0.0001 FINTX=INTX DEL=X-FINTX IF(DEL.LT.0.0)DEL=-DEL IF(DEL.GT.0.001)THEN WRITE(ICOUT,5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,6)INT(FINTX) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') ENDIF IF(FINTX.LT.0.0 .OR. FINTX.GT.AN)THEN WRITE(ICOUT,4)N CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF C 4 FORMAT('***** FATAL ERROR--THE FIRST INPUT ', 1'ARGUMENT TO THE BBNCDF SUBROUTINE IS OUTSIDE THE USUAL ', 1'(0,N) = (0,',I8,') INTERVAL') 5 FORMAT('***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ', 1'ARGUMENT TO THE BBNCDF SUBROUTINE IS NON-INTEGRAL *****') 6 FORMAT(' IT HAS BEEN SET TO ',I8) 11 FORMAT('***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE ', 1' BBNCDF SUBROUTINE IS NON-POSITIVE') 12 FORMAT('***** FATAL ERROR--THE THIRD INPUT ARGUMENT TO THE ', 1' BBNCDF SUBROUTINE IS NON-POSITIVE') 25 FORMAT('***** FATAL ERROR--THE FOURTH INPUT ARGUMENT TO THE ', 1' BBNCDF SUBROUTINE IS NON-POSITIVE *****') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****') C DV=DBLE(V) DW=DBLE(W) DN=DBLE(N) DSUM1=0.0D0 DSUM2=0.0D0 C DMEAN=DN*DV/(DV+DW) ICUT=INT(DMEAN)+1 C C SUM TERMS UP TO AND INCLUDING MEAN C DO1000I=0,MIN(ICUT,INTX),1 DX=DBLE(I) DTERM1=DLOG(DN+1.0D0) DTERM2=DLBETA(DN-DX+DV,DX+DW) DTERM3=DLBETA(DN-DX+1.0D0,DX+1.0D0) DTERM4=DLBETA(DV,DW) DCDF=DEXP(DTERM2-DTERM1-DTERM3-DTERM4) DSUM1=DSUM1+DCDF 1000 CONTINUE C C SUM TERMS FROM X DOWN TO MEAN MEAN C IF(INTX.GT.ICUT)THEN DO2000I=INTX,ICUT+1,-1 DX=DBLE(I) DTERM1=DLOG(DN+1.0D0) DTERM2=DLBETA(DN-DX+DV,DX+DW) DTERM3=DLBETA(DN-DX+1.0D0,DX+1.0D0) DTERM4=DLBETA(DV,DW) DCDF=DEXP(DTERM2-DTERM1-DTERM3-DTERM4) DSUM2=DSUM2+DCDF 2000 CONTINUE ENDIF DCDF=DSUM1+DSUM2 CDF=REAL(DCDF) C 9999 CONTINUE RETURN END SUBROUTINE BBNL(MEW, THETA, RL, MRL, LM, RNL) C C ALGORITHM AS 189.3 APPL. STATIST. (1983) VOL.32, NO.2 C C SUBROUTINE FOR CALCULATION OF THE BETA BINOMIAL LOG C LIKELIHOOD C DOUBLE PRECISION MEW, THETA, RNL, A INTEGER RL(MRL,3), LM(3) C RNL = 0.0D0 MLM = LM(3) DO 5 I = 1,MLM A = DBLE(I-1)*THETA IF(I.LE.LM(1))RNL = RNL + DBLE(RL(I,1))*DLOG(MEW+A) IF(I.LE.LM(2))RNL = RNL + DBLE(RL(I,2))*DLOG(1.0D0-MEW+A) RNL = RNL - DBLE(RL(I,3))*DLOG(1.0D0+A) 5 CONTINUE RETURN END SUBROUTINE BBNME(N, IX, IN, W, P, INF, MEW, THETA) C C ALGORITHM AS 189.1 APPL. STATIST. (1983) VOL.32, NO.2 C C SUBROUTINE TO ESTIMATE MEW AND THETA OF THE BETA BINOMIAL C DISTRIBUTION BY THE METHOD OF MOMENTS C DOUBLE PRECISION W(N), P(N), INF, MEW, THETA, D1, D2, R, S DOUBLE PRECISION TP, WT INTEGER IX(N), IN(N) LOGICAL J C J = .FALSE. DO 5 I = 1,N W(I) = DBLE(IN(I)) P(I) = DBLE(IX(I))/W(I) 5 CONTINUE 10 WT = 0.0D0 TP = 0.0D0 DO 15 I = 1,N WT = WT+W(I) TP = TP+W(I)*P(I) 15 CONTINUE TP = TP/WT S = 0.0D0 D1 = 0.0D0 D2 = 0.0D0 DO 20 I = 1,N R = P(I)-TP S = S+W(I)*R*R R = W(I)*(1.0D0-W(I)/WT) D1 = D1+R/DBLE(IN(I)) D2 = D2+R 20 CONTINUE S = DBLE(N-1)*S/DBLE(N) R = TP*(1.0D0-TP) IF(R.EQ.0.0D0) GOTO 30 R = (S-R*D1)/(R*(D2-D1)) IF(R.LT.0.0) R = 0.0D0 IF(J) GOTO 30 DO 25 I = 1,N 25 W(I) = W(I)/(1.0D0+R*(W(I)-1.0D0)) J = .TRUE. GOTO 10 30 MEW = TP IF(R.GE.1.0D0) GOTO 35 THETA = R/(1.0D0-R) IF(THETA.LE.INF) RETURN 35 THETA = INF RETURN END SUBROUTINE BBNML(N,IX,IN,W,P,RL,MRL,ITER,CCRIT,MEW,THETA, * SEM, SETH, RNL, IFAULT) C UKC NETLIB DISTRIBUTION COPYRIGHT 1990 RSS C C C ALGORITHM AS189 APPL. STATIST. (1983) VOL.32, NO.2 C C SUBROUTINE FOR CALCULATING THE MAXIMUM LIKELIHOOD ESTIMATES C OF THE PARAMETERS OF THE BETA BINOMIAL DISTRIBUTION C DOUBLE PRECISION W(N), P(N), CCRIT, MEW, THETA, SEM, SETH DOUBLE PRECISION RNL, INF, DUM DOUBLE PRECISION FD(2), SD(3), TD(4), UB(2), DEL, EPS DOUBLE PRECISION A, B, C, D, E, F INTEGER IX(N), IN(N), RL(MRL,3), LM(3), RD1(2,2), RD2(2,3), * RD3(2,4) LOGICAL MC PARAMETER (INF = 1.0D6) DATA * RD1(1,1), RD1(2,1), RD1(1,2), RD1(2,2)/1,-1,1,1/, * RD2(1,1), RD2(2,1), RD2(1,2), RD2(2,2), * RD2(1,3), RD2(2,3)/-1,-1,-1,1,-1,-1/, * RD3(1,1), RD3(2,1), RD3(1,2), RD3(2,2), RD3(1,3), * RD3(2,3), RD3(1,4), RD3(2,4)/2,-2,2,2,2,-2,2,2/ C I = ITER ITER = 0 MC = .TRUE. UB(1) = 0.01D0 UB(2) = 0.01D0 C C SET THE ARRAYS RL AND LM C CALL BBNSET(N, IX, IN, RL, MRL, LM, IFAULT) IF(IFAULT.NE.0) RETURN SEM = -1.0D0 SETH = -1.0D0 NND = 0 C C CALCULATION OF INITIAL ESTIMATES (BY MOMENTS) C CALL BBNME(N, IX, IN, W, P, INF, MEW, THETA) IF(THETA.EQ.INF) GOTO 50 C C NEWTON-RAPHSON ITERATION ON FIRST DERIVATIVES C 5 IF(ITER.LE.I) GOTO 10 IFAULT = 7 GOTO 60 C C CALCULATE FIRST DERIVATIVES OF LOG LIKELIHOOD C 10 CALL GDER(MEW, THETA, RL, MRL, LM, 2, RD1, FD) C C CALCULATE SECOND DERIVATIVES OF LOG_LIKELIHOOD C CALL GDER(MEW, THETA, RL, MRL, LM, 3, RD2, SD) C C CALCULATE THIRD DERIVATIVES OF LOG LIKELIHOOD C CALL GDER(MEW, THETA, RL, MRL, LM, 4, RD3, TD) C C CALCULATE INCREMENTS C DUM = SD(1)*SD(3) - SD(2)*SD(2) IF(SD(1).LT.0.0D0.AND.DUM.GT.0.0D0) GOTO 15 C C NON NEGATIVE DEFINITE MATRIX C NND = NND+1 C C SD(1) IS ALWAYS NEGATIVE SO A GRADIENT STEP IS MADE ON MEW C A = MEW - FD(1)/SD(1) B = THETA IF(FD(2).NE.0.0D0) B = B + SIGN(UB(2),FD(2)) IF(A.LE.0.0D0) A = 0.0001D0 IF(A.GE.1.0D0) A = 0.9999D0 IF(B.LT.0.0D0) B = 0.0D0 IF(B.GT.INF) B = INF CALL BBNL(MEW, THETA, RL, MRL, LM, C) CALL BBNL(A, B, RL, MRL, LM, D) IF(NND.GT.10.OR.C.GE.D) GOTO 40 ITER = ITER+1 MEW = A THETA = B GOTO 5 15 DEL = (FD(2)*SD(2) - FD(1)*SD(3))/DUM EPS = (FD(1)*SD(2) - FD(2)*SD(1))/DUM C C CHECK LIPSCHITZ CONDITION SATISFIED C A = SD(2)*TD(2) - TD(1)*SD(3) B = SD(2)*TD(3) - TD(2)*SD(3) C = TD(1)*SD(2) - TD(2)*SD(1) D = SD(2)*TD(2) - SD(1)*TD(3) E = SD(2)*TD(4) - TD(3)*SD(3) F = TD(3)*SD(2) - TD(4)*SD(1) A = DEL*A + EPS*B C = DEL*C + EPS*D E = DEL*B + EPS*E F = DEL*D + EPS*F DUM = (A*A + C*C + E*E + F*F)/(DUM*DUM) IF(DUM.GE.1.0D0) GOTO 20 IF(ABS(DEL).LE.CCRIT.AND.ABS(EPS).LE.CCRIT) MC = .FALSE. GOTO 45 C C FAILURE OF LIPSCHITZ CONDITION. A STEP IN THE DIRECTION OF THE C GRADIENT IS MADE. C 20 A = FD(1)*FD(1) B = FD(2)*FD(2) C = A*SD(1) + 2.0D0*SD(2)*FD(1)*FD(2) + B*SD(3) IF(C.NE.0.0D0) GOTO 25 DEL = 0.0D0 IF(FD(1).NE.0.0D0) DEL = SIGN(UB(1),FD(1)) EPS = 0.0D0 IF(FD(2).NE.0.0D0) EPS = SIGN(UB(2),FD(2)) GOTO 30 25 C = -(A+B)/C DEL = C*FD(1) EPS = C*FD(2) IF(ABS(DEL).GT.UB(1)) DEL = SIGN(UB(1),DEL) UB(1) = 2.0D0*DABS(DEL) IF(DABS(EPS).GT.UB(2)) EPS = SIGN(UB(2),EPS) UB(2) = 2.0D0*ABS(EPS) 30 CALL BBNL(MEW, THETA, RL, MRL, LM, C) 35 A = MEW + DEL B = THETA + EPS IF(A.LE.0.0D0) A = 0.0001D0 IF(A.GE.1.0D0) A = 0.9999D0 DEL = A - MEW IF(B.LT.0.0D0) B = 0.0D0 IF(B.GT.INF) B = INF EPS = B - THETA CALL BBNL(A, B, RL, MRL, LM, D) C C CHECK TO SEE IF GRADIENT STEP HAS INCREASED LOG LIKELIHOOD C IF(D.GT.C) GOTO 45 DEL = DEL/2.0D0 EPS = EPS/2.0D0 IF(DABS(DEL).GT.CCRIT.OR.DABS(EPS).GT.CCRIT) GOTO 35 40 IFAULT = 8 GOTO 60 45 ITER = ITER + 1 A = MEW + DEL B = THETA + EPS IF(A.GT.0.0D0.AND.A.LT.1.0D0.AND.B.GE.0.0D0.AND.B.LE.INF) GOTO 55 IF(A.LE.0.0D0) MEW = 0.0D0 IF(A.GE.1.0D0) MEW = 1.0D0 IF(B.LT.0.0D0) THETA = 0.0D0 IF(B.GT.INF) THETA = INF 50 IFAULT = 6 GOTO 60 55 MEW = A THETA = B IF(MC) GOTO 5 C C CALCULATE LOG LIKELIHOOD AND S.E.S C IF(SD(1).LT.0.0D0) SEM = DSQRT(-1.0D0/SD(1)) IF(SD(3).LT.0.0D0) SETH = DSQRT(-1.0D0/SD(3)) 60 CALL BBNL(MEW, THETA, RL, MRL, LM, RNL) RETURN END SUBROUTINE BBNPDF(X,V,W,N,PDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY C FUNCTION VALUE AT THE SINGLE PRECISION VALUE X C FOR THE BETA-BINOMIAL DISTRIBUTION C WITH SINGLE PRECISION PARAMETERS V AND W C AND INTEGER 'NUMBER OF BERNOULLI TRIALS' C PARAMETER = N. C IF V AND W ARE INTEGERS, THIS BECOMES THE NEGATIVE C HYPERGEOMETRIC DISTRIBUTION. C THIS DISTRIBUTION IS DEFINED FOR ALL C DISCRETE INTEGER X BETWEEN 0 (INCLUSIVELY) C AND N (INCLUSIVELY). C THIS DISTRIBUTION HAS THE PROBABILITY FUNCTION C F(X) = B(N-X+V,X+B)/[(N+1)*B(N-X+1,X+1)*B(V,W) C WHERE B(A,B) IS THE BETA FUNCTION. C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE C AT WHICH THE PROBABILITY DENSITY C FUNCTION IS TO BE EVALUATED. C X SHOULD BE INTEGRAL-VALUED, C AND BETWEEN 0.0 (INCLUSIVELY) C AND N (INCLUSIVELY). C --V = THE SINGLE PRECISION VALUE C OF THE FIRST SHAPE PARAMETER. C --W = THE SINGLE PRECISION VALUE C OF THE SECOND SHAPE PARAMETER. C --N = THE INTEGER VALUE C OF THE 'NUMBER OF BERNOULLI TRIALS' C PARAMETER. C N SHOULD BE A POSITIVE INTEGER. C OUTPUT ARGUMENTS--PDF = THE SINGLE PRECISION PROBABILITY C DENSITY FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY C FUNCTION VALUE PDF C FOR THE BETA-BINOMIAL DISTRIBUTION C WITH 'BERNOULLI PROBABILITY' PARAMETER = P C AND 'NUMBER OF BERNOULLI TRIALS' PARAMETER = N. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--X SHOULD BE INTEGRAL-VALUED, C AND BETWEEN 0.0 (INCLUSIVELY) C AND N (INCLUSIVELY). C --P SHOULD BE BETWEEN 0.0 (EXCLUSIVELY) C AND 1.0 (EXCLUSIVELY). C --N SHOULD BE A POSITIVE INTEGER. C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--DSQRT, DATAN. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--HASTINGS AND PEACOCK, STATISTICAL C DISTRIBUTIONS--2ND ED., CHAPTER 5 C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--96/2 C ORIGINAL VERSION--FEBRUARY 1996. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DX, DV, DW, DN, DPDF DOUBLE PRECISION DTERM1, DTERM2, DTERM3, DTERM4 DOUBLE PRECISION DLBETA, DBINOM C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C PDF=0.0 C C CHECK THE INPUT ARGUMENTS FOR ERRORS C AN=N IF(V.LE.0.0)THEN WRITE(ICOUT,11) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)V CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9999 ENDIF IF(W.LE.0.0)THEN WRITE(ICOUT,12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)V CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9999 ENDIF IF(N.LE.0)THEN WRITE(ICOUT,25) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)N CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9999 ENDIF INTX=X+0.0001 FINTX=INTX DEL=X-FINTX IF(DEL.LT.0.0)DEL=-DEL IF(DEL.GT.0.001)THEN WRITE(ICOUT,5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,6)INT(FINTX) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') ENDIF IF(FINTX.LT.0.0 .OR. FINTX.GT.AN)THEN WRITE(ICOUT,4)N CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF C 4 FORMAT('***** FATAL ERROR--THE FIRST INPUT ', 1'ARGUMENT TO THE BBNPDF SUBROUTINE IS OUTSIDE THE USUAL ', 1'(0,N) = (0,',I8,') INTERVAL') 5 FORMAT('***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ', 1'ARGUMENT TO THE BBNPDF SUBROUTINE IS NON-INTEGRAL *****') 6 FORMAT(' IT HAS BEEN SET TO ',I8) 11 FORMAT('***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE ', 1' BBNPDF SUBROUTINE IS NON-POSITIVE') 12 FORMAT('***** FATAL ERROR--THE THIRD INPUT ARGUMENT TO THE ', 1' BBNPDF SUBROUTINE IS NON-POSITIVE') 25 FORMAT('***** FATAL ERROR--THE FOURTH INPUT ARGUMENT TO THE ', 1' BBNPDF SUBROUTINE IS NON-POSITIVE *****') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****') C DX=DBLE(FINTX) DV=DBLE(V) DW=DBLE(W) DN=DBLE(N) C DTERM1=DLOG(DN+1.0D0) DTERM2=DLBETA(DN-DX+DV,DX+DW) DTERM3=DLBETA(DN-DX+1.0D0,DX+1.0D0) DTERM4=DLBETA(DV,DW) DPDF=DTERM2-DTERM1-DTERM3-DTERM4 IF(DPDF.LE.-80.D0)THEN PDF=0.0 ELSEIF(DPDF.GT.80.D0)THEN WRITE(ICOUT,101) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') PDF=0.0 ELSE DPDF=DEXP(DPDF) PDF=SNGL(DPDF) ENDIF 101 FORMAT('****** FATAL ERROR--OVERFLOW IN BBNPDF ROUTINE.') C 9999 CONTINUE RETURN END SUBROUTINE BBNPPF(P,V,W,N,PPF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT C FUNCTION VALUE AT THE SINGLE PRECISION VALUE P C FOR THE BETA-BINOMIAL DISTRIBUTION C WITH SINGLE PRECISION PARAMETERS V AND W C AND INTEGER 'NUMBER OF BERNOULLI TRIALS' C PARAMETER = N. C IF V AND W ARE INTEGERS, THIS BECOMES THE NEGATIVE C HYPERGEOMETRIC DISTRIBUTION. C THIS DISTRIBUTION IS DEFINED FOR ALL C DISCRETE INTEGER X BETWEEN 0 (INCLUSIVELY) C AND N (INCLUSIVELY). C THIS DISTRIBUTION HAS THE PROBABILITY FUNCTION C F(X) = B(N-X+V,X+B)/[(N+1)*B(N-X+1,X+1)*B(V,W) C WHERE B(A,B) IS THE BETA FUNCTION. C INPUT ARGUMENTS--P = THE SINGLE PRECISION VALUE C (BETWEEN 0.0 (INCLUSIVELY) C AND 1.0 (INCLUSIVELY)) C AT WHICH THE PERCENT POINT C FUNCTION IS TO BE EVALUATED. C --V = THE SINGLE PRECISION VALUE C OF THE FIRST SHAPE PARAMETER. C --W = THE SINGLE PRECISION VALUE C OF THE SECOND SHAPE PARAMETER. C --N = THE INTEGER VALUE C OF THE 'NUMBER OF BERNOULLI TRIALS' C PARAMETER. C N SHOULD BE A POSITIVE INTEGER. C OUTPUT ARGUMENTS--PPF = THE SINGLE PRECISION PERCENT C POINT FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION PERCENT POINT . C FUNCTION VALUE PPF C FOR THE BETA-BINOMIAL DISTRIBUTION C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--N SHOULD BE A POSITIVE INTEGER. C --P SHOULD BE BETWEEN 0.0 (INCLUSIVELY) C AND 1.0 (INCLUSIVELY). C OTHER DATAPAC SUBROUTINES NEEDED--BBNCDF C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION AND DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C COMMENT--NOTE THAT EVEN THOUGH THE OUTPUT C FROM THIS DISCRETE DISTRIBUTION C PERCENT POINT FUNCTION C SUBROUTINE MUST NECESSARILY BE A C DISCRETE INTEGER VALUE, C THE OUTPUT VARIABLE PPF IS SINGLE C PRECISION IN MODE. C PPF HAS BEEN SPECIFIED AS SINGLE C PRECISION SO AS TO CONFORM WITH THE DATAPAC C CONVENTION THAT ALL OUTPUT VARIABLES FROM ALL C DATAPAC SUBROUTINES ARE SINGLE PRECISION. C THIS CONVENTION IS BASED ON THE BELIEF THAT C 1) A MIXTURE OF MODES (FLOATING POINT C VERSUS INTEGER) IS INCONSISTENT AND C AN UNNECESSARY COMPLICATION C IN A DATA ANALYSIS; AND C 2) FLOATING POINT MACHINE ARITHMETIC C (AS OPPOSED TO INTEGER ARITHMETIC) C IS THE MORE NATURAL MODE FOR DOING C DATA ANALYSIS. C REFERENCES--HASTINGS AND PEACOCK, STATISTICAL C DISTRIBUTIONS--2ND. ED., 1994, CHAPTER 5 C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--96/2 C ORIGINAL VERSION--FEBRUARY 1996. C UPDATED --MAY 1996. TEST FOR LOWER BOUND C UPDATED --MARCH 2004. MODIFY THE ALGORITHM C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DX, DV, DW, DN, DCDF DOUBLE PRECISION DTERM1, DTERM2, DTERM3, DTERM4 DOUBLE PRECISION DLBETA DOUBLE PRECISION DSUM1 DOUBLE PRECISION DP C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(P.LT.0.0.OR.P.GT.1.0)THEN WRITE(ICOUT,1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)P CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9999 ENDIF IF(V.LE.0.0)THEN WRITE(ICOUT,11) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)V CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9999 ENDIF IF(W.LE.0.0)THEN WRITE(ICOUT,12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)V CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9999 ENDIF IF(N.LE.0)THEN WRITE(ICOUT,25) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)N CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9999 ENDIF 1 FORMAT('***** FATAL ERROR--THE FIRST INPUT ARGUMENT TO THE ', 1' BBNPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL') 11 FORMAT('***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE ', 1' BBNPPF SUBROUTINE IS NON-POSITIVE') 12 FORMAT('***** FATAL ERROR--THE THIRD INPUT ARGUMENT TO THE ', 1' BBNPPF SUBROUTINE IS NON-POSITIVE') 25 FORMAT('***** FATAL ERROR--THE FOURTH INPUT ARGUMENT TO THE ', 1' BBNPPF SUBROUTINE IS NON-POSITIVE *****') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****') C AN=N PPF=0.0 C C TREAT CERTAIN SPECIAL CASES IMMEDIATELY-- C 1) P = 0.0 C 2) P = 1.0 C IF(P.EQ.0.0)THEN PPF=0.0 GOTO9999 ENDIF C IF(P.EQ.1.0)THEN PPF=REAL(N) GOTO9999 ENDIF C C COMPUTE THE BBNCDF, TERMINATE WHEN CDF IS GREATER THAN OR C EQUAL TO P. COMPARISON PEFORMED ON LOG SCALE. C DP=DBLE(P) DN=DBLE(N) DV=DBLE(V) DW=DBLE(W) DSUM1=0.0D0 DO1000I=0,N DX=DBLE(I) DTERM1=DLOG(DN+1.0D0) DTERM2=DLBETA(DN-DX+DV,DX+DW) DTERM3=DLBETA(DN-DX+1.0D0,DX+1.0D0) DTERM4=DLBETA(DV,DW) DCDF=DEXP(DTERM2-DTERM1-DTERM3-DTERM4) DSUM1=DSUM1+DCDF IF(DSUM1.GE.DP)THEN PPF=REAL(I) GOTO9999 ENDIF 1000 CONTINUE PPF=REAL(N) C 9999 CONTINUE RETURN END SUBROUTINE BBNRAN(ALPHA,BETA,NPAR,N,ISEED,X) C C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N C FROM THE BETA-BINOMIAL DISTRIBUTION C WITH SINGLE PRECISION 'BERNOULLI PROBABILITY' C PARAMETER = P FOLLOWING A BETA DISTRIBUTION WITH C SHAPE PARAMETERS ALPHA AND BETA, C AND INTEGER 'NUMBER OF BERNOULLI TRIALS' C PARAMETER = NPAR. C THIS DISTRIBUTION IS DEFINED FOR ALL C DISCRETE INTEGER X BETWEEN 0 (INCLUSIVELY) C AND NPAR (INCLUSIVELY). C INPUT ARGUMENTS--N = THE DESIRED INTEGER NUMBER C OF RANDOM NUMBERS TO BE C GENERATED. C --ALPHA = THE SINGLE PRECISION VALUE C OF THE FIRST SHAPE PARAMETER OF THE C BETA DISTRIBUTION. C ALPHA > 0. C --BETA = THE SINGLE PRECISION VALUE C OF THE SECOND SHAPE PARAMETER OF THE C BETA DISTRIBUTION. C BETA > 0. C --NPAR = THE INTEGER VALUE C OF THE 'NUMBER OF BERNOULLI TRIALS' C PARAMETER. C NPAR SHOULD BE A POSITIVE INTEGER. C OUTPUT ARGUMENTS--X = A SINGLE PRECISION VECTOR C (OF DIMENSION AT LEAST N) C INTO WHICH THE GENERATED C RANDOM SAMPLE WILL BE PLACED. C OUTPUT--A RANDOM SAMPLE OF SIZE N C FROM THE BETA-BINOMIAL DISTRIBUTION. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C --ALPHA, BETA > 0 C --NPAR SHOULD BE A POSITIVE INTEGER. C OTHER DATAPAC SUBROUTINES NEEDED--UNIRAN, GEORAN. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C COMMENT--NOTE THAT EVEN THOUGH THE OUTPUT C FROM THIS DISCRETE RANDOM NUMBER C GENERATOR MUST NECESSARILY BE A C SEQUENCE OF ***INTEGER*** VALUES, C THE OUTPUT VECTOR X IS SINGLE C PRECISION IN MODE. C X HAS BEEN SPECIFIED AS SINGLE C PRECISION SO AS TO CONFORM WITH THE DATAPAC C CONVENTION THAT ALL OUTPUT VECTORS FROM ALL C DATAPAC SUBROUTINES ARE SINGLE PRECISION. C THIS CONVENTION IS BASED ON THE BELIEF THAT C 1) A MIXTURE OF MODES (FLOATING POINT C VERSUS INTEGER) IS INCONSISTENT AND C AN UNNECESSARY COMPLICATION C IN A DATA ANALYSIS; AND C 2) FLOATING POINT MACHINE ARITHMETIC C (AS OPPOSED TO INTEGER ARITHMETIC) C IS THE MORE NATURAL MODE FOR DOING C DATA ANALYSIS. C REFERENCES--JOHNSON AND KOTZ, DISCRETE C DISTRIBUTIONS, 1969, PAGES 50-86. C --HASTINGS AND PEACOCK, STATISTICAL C DISTRIBUTIONS--A HANDBOOK FOR C STUDENTS AND PRACTITIONERS, 1975, C PAGE 41. C --FELLER, AN INTRODUCTION TO PROBABILITY C THEORY AND ITS APPLICATIONS, VOLUME 1, C EDITION 2, 1957, PAGES 135-142. C --NATIONAL BUREAU OF STANDARDS APPLIED MATHEMATICS C SERIES 55, 1964, PAGE 929. C --KENDALL AND STUART, THE ADVANCED THEORY OF C STATISTICS, VOLUME 1, EDITION 2, 1963, PAGES 120-125. C --MOOD AND GRABLE, INTRODUCTION TO THE THEORY C OF STATISTICS, EDITION 2, 1963, PAGES 64-69. C --TOCHER, THE ART OF SIMULATION, C 1963, PAGES 39-40. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-921-3651 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--2001/12 C ORIGINAL VERSION--DECEMBER 2001. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DIMENSION X(*) C DIMENSION U(2) DIMENSION G(2) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(N.LT.1)THEN WRITE(ICOUT, 5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)N CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF IF(ALPHA.LE.0.0)THEN WRITE(ICOUT,11) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)ALPHA CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF IF(BETA.LE.0.0)THEN WRITE(ICOUT,12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)BETA CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF IF(NPAR.LT.1)THEN WRITE(ICOUT,25) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)NPAR CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF 5 FORMAT('***** FATAL ERROR--NUMBER OF BETA-BINOMIAL RANDOM ', 1'NUMBERS REQUESTED < 1') 11 FORMAT('***** FATAL ERROR--THE ALPHA SHAPE PARAMETER ARGUMENT', 1' TO THE BBNRAN SUBROUTINE IS <= 0') 12 FORMAT('***** FATAL ERROR--THE BETA SHAPE PARAMETER ARGUMENT', 1' TO THE BBNRAN SUBROUTINE IS <= 0') 25 FORMAT('***** FATAL ERROR--THE NUMBER OF TRIALS ARGUMENT TO THE', 1' BBNRAN SUBROUTINE IS NON-POSITIVE *****') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****') C C FIRST, GENERATE N BETA RANDOM NUMBERS. C CALL BETRAN(N,ALPHA,BETA,ISEED,X) C C CHECK ON THE MAGNITUDE OF P, C AND BRANCH TO THE FASTER C GENERATION METHOD ACCORDINGLY. C DO100I=1,N C P=X(I) C IF(P.LT.0.1)THEN C C IF P IS SMALL, GENERATE N BINOMIAL NUMBERS C USING THE FACT THAT THE WAITING TIME FOR 1 SUCCESS IN C BERNOULLI TRIALS HAS A GEOMETRIC DISTRIBUTION. C ISUM=0 J=1 550 CONTINUE CALL GEORAN(1,P,ISEED,G) IG=G(1)+0.5 ISUM=ISUM+IG+1 IF(ISUM.GT.NPAR)GOTO650 J=J+1 GOTO550 650 CONTINUE X(I)=J-1 ELSE C C IF P IS MODERATE OR LARGE, C GENERATE N BINOMIAL RANDOM NUMBERS C USING THE REJECTION METHOD. C ISUM=0 DO200J=1,NPAR CALL UNIRAN(1,ISEED,U) IF(U(1).LE.P)ISUM=ISUM+1 200 CONTINUE X(I)=ISUM ENDIF C 100 CONTINUE C 9000 CONTINUE RETURN C END SUBROUTINE BBNSET(N, IX, IN, RL, MRL, LM, IFAULT) C C ALGORITHM AS 189.2 APPL. STATIST. (1983) VOL.32, NO.2 C C SUBROUTINE FOR SETTING UP ARRAY FOR CALCULATION OF C THE BETA BINOMIAL LOG LIKELIHOOD AND ITS DERIVATIVES C INTEGER IX(N), IN(N), RL(MRL,3), LM(3) C C TEST ADMISSIBILITY OF DATA C IF(N.GT.1) GOTO 5 IFAULT = 1 RETURN 5 DO 10 I = 1,N IF(IX(I).GT.0) GOTO 15 10 CONTINUE IFAULT = 2 RETURN 15 DO 20 I = 1,N IF(IX(I).LT.IN(I)) GOTO 25 20 CONTINUE IFAULT = 3 RETURN C C FORM MATRIX OF COUNTS C 25 IFAULT = 4 DO 30 I = 1,3 LM(I) = 0 DO 30 J = 1,MRL RL(J,I) = 0 30 CONTINUE DO 65 I = 1,N JJ = IX(I) MAR = 1 GOTO 45 35 JJ = IN(I)-IX(I) MAR = 2 GOTO 45 40 JJ = IN(I) MAR = 3 45 IF(JJ) 50,60,55 50 IFAULT = 5 RETURN 55 IF(JJ.GT.MRL) RETURN IF(JJ.GT.LM(MAR)) LM(MAR) = JJ RL(JJ,MAR) = RL(JJ,MAR)+1 60 GOTO(35,40,65) MAR 65 CONTINUE IFAULT = 0 C C EVALUATE NUMBER OF CALLS TO DIFFERENT TERMS OF LIKELIHOOD C FUNCTION C DO 75 I = 1,3 JJ = LM(I)-1 IF(JJ.LE.0) GOTO 75 K = JJ DO 70 J = 1,JJ RL(K,I) = RL(K,I)+RL(K+1,I) K = K-1 70 CONTINUE 75 CONTINUE RETURN END SUBROUTINE BEICDF(X,S1SQ,S2SQ,NU,IBEIDF,DCDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION C FUNCTION VALUE FOR THE BESSEL I-FUNCTION C DISTRIBUTION WITH SHAPE PARAMETERS S1SQ, S2SQ, AND C NU. THE CUMULATIVE DISTRIBUTION IS COMPUTED BY C NUMERICALLY INTEGRATING THE PDF FUNCTION. C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE AT C WHICH THE CUMULATIVE DISTRIBUTION C FUNCTION IS TO BE EVALUATED. C --S1SQ = THE FIRST SHAPE PARAMETER C --S2SQ = THE SECOND SHAPE PARAMETER C --NU = THE THIRD SHAPE PARAMETER C OUTPUT ARGUMENTS--CDF = THE SINGLE PRECISION CUMULATIVE C DISTRIBUTION FUNCTION VALUE. C OUTPUT--THE DOUBLE PRECISION CUMULATIVE DISTRIBUTION C FUNCTION VALUE FOR THE BESSEL I-FUNCTION C DISTRIBUTION WITH SHAPE PARAMETERS S1SQ, C S2SQ, AND NU. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--NONE. C OTHER DATAPAC SUBROUTINES NEEDED--DQAGI. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, (1994), "CONTINUOUS C UNIVARIATE DISTRIBUTIONS--VOLUME 1", SECOND EDITION, C WILEY, PP. 50-52. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2004.8 C ORIGINAL VERSION--AUGUST 2004. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C CHARACTER*4 IBEIDF C INTEGER LIMIT INTEGER LENW PARAMETER(LIMIT=100) PARAMETER(LENW=4*LIMIT) INTEGER INF INTEGER NEVAL INTEGER IER INTEGER LAST INTEGER IWORK(LIMIT) DOUBLE PRECISION S1SQ DOUBLE PRECISION S2SQ DOUBLE PRECISION NU DOUBLE PRECISION EPSABS DOUBLE PRECISION EPSREL DOUBLE PRECISION RESULT DOUBLE PRECISION DCDF DOUBLE PRECISION DEPS DOUBLE PRECISION DLOW DOUBLE PRECISION DUPP DOUBLE PRECISION X DOUBLE PRECISION DX DOUBLE PRECISION DB DOUBLE PRECISION DC DOUBLE PRECISION DM DOUBLE PRECISION ABSERR DOUBLE PRECISION WORK(LENW) C DOUBLE PRECISION BEIFUN EXTERNAL BEIFUN C DOUBLE PRECISION DS1SQ DOUBLE PRECISION DS2SQ DOUBLE PRECISION DNU CHARACTER*4 IBEID2 COMMON/BEICOM/DS1SQ,DS2SQ,DNU,IBEID2 C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,AKMBPC,AKMCPW,AKMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----DATA STATEMENTS------------------------------------------------- C C-----START POINT----------------------------------------------------- C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C IF(IBEIDF.EQ.'1')THEN DB=4.0D0*S1SQ*S2SQ/(S1SQ - S2SQ) DC=(S1SQ + S2SQ)/(S1SQ - S2SQ) DM=2.0D0*NU + 1.0D0 ELSE DB=S1SQ DC=S2SQ DM=NU ENDIF C IF(DABS(DC).LE.1.0D0)THEN WRITE(ICOUT,9) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,10) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,11) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,12)S1SQ CALL DPWRST('XXX','WRIT') WRITE(ICOUT,13)S2SQ CALL DPWRST('XXX','WRIT') WRITE(ICOUT,14)DC CALL DPWRST('XXX','WRIT') CDF=0.0D0 GOTO9000 ENDIF 9 FORMAT('***** ERROR: ABSOLUTE VALUE OF 1 - C**2 <= 1 ', 1 'IN BEICDF ROUTINE.') 10 FORMAT(' C = (S1**2 + S2**2)/(S1**2 - S2**2) WHERE ', 1 'S1**2 AND S2**2') 11 FORMAT(' ARE THE FIRST AND SECOND SHAPE PARAMETERS, ', 1 'RESPECTIVELY.') 12 FORMAT(' VALUE OF S1**2 IS: ',G15.7) 13 FORMAT(' VALUE OF S2**2 IS: ',G15.7) 14 FORMAT(' VALUE OF C IS: ',G15.7) IF(DC.GT.0.0D0 .AND. X.LE.0.0D0)THEN WRITE(ICOUT,24) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,25) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,48)X CALL DPWRST('XXX','WRIT') CDF=0.0D0 GOTO9000 ENDIF 24 FORMAT('***** ERROR: VALUE OF THE INPUT ARGUMENT ', 1 'IN BEICDF ROUTINE IS NON-POSITIVE') 25 FORMAT(' FOR THE CASE WHERE S1**2 > S2**2 (THESE ARE THE ', 1 'FIRST AND SECOND SHAPE PARAMETERS).') IF(DC.LT.0.0D0 .AND. X.GE.0.0D0)THEN WRITE(ICOUT,34) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,35) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,48)X CALL DPWRST('XXX','WRIT') CDF=0.0D0 GOTO9000 ENDIF 34 FORMAT('***** ERROR: VALUE OF THE INPUT ARGUMENT ', 1 'IN BEICDF ROUTINE IS NON-NEGATIVE') 35 FORMAT(' FOR THE CASE WHERE S1**2 < S2**2 (THESE ARE THE ', 1 'FIRST AND SECOND SHAPE PARAMETERS).') IF(S1SQ.LE.0.0D0)THEN WRITE(ICOUT,5) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,48)S1SQ CALL DPWRST('XXX','WRIT') CDF=0.0D0 GOTO9000 ENDIF 5 FORMAT('***** ERROR: VALUE OF FIRST SHAPE PARAMETER (SIGMA1**2)', 1 ' IN BEICDF ROUTINE IS NON-POSITIVE.') IF(S2SQ.LE.0.0D0)THEN WRITE(ICOUT,6) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,48)S2SQ CALL DPWRST('XXX','WRIT') CDF=0.0D0 GOTO9000 ENDIF 6 FORMAT('***** ERROR: VALUE OF SECOND SHAPE PARAMETER ', 1 '(SIGMA2**2) IN BEICDF ROUTINE IS NON-POSITIVE.') IF(IBEIDF.EQ.'1')THEN IF(NU.LE.-0.25D0)THEN WRITE(ICOUT,7) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,48)NU CALL DPWRST('XXX','WRIT') CDF=0.0D0 GOTO9000 ENDIF ELSE IF(DM.LE.0.5D0)THEN WRITE(ICOUT,8) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,48)DM CALL DPWRST('XXX','WRIT') CDF=0.0D0 GOTO9000 ENDIF ENDIF 7 FORMAT('***** ERROR: VALUE OF THIRD SHAPE PARAMETER (NU) IN ', 1 'BEICDF ROUTINE IS < -0.25.') 8 FORMAT('***** ERROR: VALUE OF THIRD SHAPE PARAMETER (M) IN ', 1 'BEICDF ROUTINE IS <= 0.5.') C 48 FORMAT(' VALUE OF ARGUMENT IS: ',G15.7) C C C ************************************ C ** STEP 1-- ** C ** COMPUTE THE DENSITY FUNCTION ** C ************************************ C EPSABS=0.0D0 EPSREL=1.0D-7 IER=0 IKEY=3 DEPS=1.0D-12 C DS1SQ=S1SQ DS2SQ=S2SQ DNU=NU IBEID2=IBEIDF DCDF=0.0D0 C IF(DC.GT.0.0D0)THEN IF(X.LE.DEPS)THEN DCDF=0.0D0 GOTO9000 ENDIF DLOW=DEPS DUPP=X ELSE IF(DABS(X).LE.DEPS)THEN DCDF=1.0D0 GOTO9000 ENDIF DLOW=X DUPP=-DEPS ENDIF C CALL DQAG(BEIFUN,DLOW,DUPP,EPSABS,EPSREL,IKEY,DCDF,ABSERR,NEVAL, 1 IER,LIMIT,LENW,LAST,IWORK,WORK) C IF(DC.LT.0.0D0)THEN DCDF=1.0D0 - DCDF ENDIF C IF(IER.EQ.1)THEN WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,111) 111 FORMAT('***** ERROR FROM BEICDF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,113) 113 FORMAT(' MAXIMUM NUMBER OF SUBDIVISIONS EXCEEDED.') CALL DPWRST('XXX','BUG ') ELSEIF(IER.EQ.2)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,121) 121 FORMAT('***** ERROR FROM BEICDF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,123) 123 FORMAT(' ROUNDOFF ERROR PREVENTS REQUESTED TOLERANCE ', 1 'FROM BEING ACHIEVED.') CALL DPWRST('XXX','BUG ') ELSEIF(IER.EQ.3)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,131) 131 FORMAT('***** ERROR FROM BEICDF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,133) 133 FORMAT(' BAD INTEGRAND BEHAVIOUR DETECTED.') CALL DPWRST('XXX','BUG ') ELSEIF(IER.EQ.4)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,141) 141 FORMAT('***** ERROR FROM BEICDF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,143) 143 FORMAT(' INTEGRATION DID NOT CONVERGE.') CALL DPWRST('XXX','BUG ') ELSEIF(IER.EQ.5)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,151) 151 FORMAT('***** ERROR FROM BEICDF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,153) 153 FORMAT(' THE INTEGRATION IS PROBABLY DIVERGENT.') CALL DPWRST('XXX','BUG ') ELSEIF(IER.EQ.6)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,161) 161 FORMAT('***** ERROR FROM BEICDF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,163) 163 FORMAT(' INVALID INPUT TO THE INTEGRATION ROUTINE.') CALL DPWRST('XXX','BUG ') ENDIF C 9000 CONTINUE RETURN END DOUBLE PRECISION FUNCTION BEIFUN(DX) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY C FUNCTION VALUE FOR THE BESSEL I-FUNCTION C DISTRIBUTION WITH SHAPE PARAMETERS S1SQ, S2SQ, AND NU. C THIS DISTRIBUTION IS DEFINED FOR POSITIVE X C AND HAS THE PROBABILITY DENSITY FUNCTION C C BEIPDF(X,S1AQ,S2SQ,ANU) = C K*X**M*EXP(-C*X/B)*PI*I(X/B,M) X > 0 C WITH C B = 4*S1SQ**2*S2SQ**2/(S1SQ**2 - S2SQ**2) C C = (S1SQ**2 + S2SQ**2/(S1SQ**2 - S2SQ**2) C M = 2*NU + 1 C AND C K = |1 - C**2|**(M+0.5)/[SQRT(PI)*2**M*b**(M+1)* C GAMMA(M+0.5)] C I(Z,N) IS THE MODIFIED BESSEL FUNCTION OF THE C FIRST KIND C GAMMA IS THE GAMMA FUNCTION C C THE BEIPDF ROUTINE IS CALLED TO COMPUTE THE C PROBABILITY DENSITY. DEFINE AS FUNCTION TO BE USED FOR C INTEGRATION CODE CALLED BY BEICDF. THIS ROUTINE USES C DOUBLE PRECISION ARITHMETIC. C INPUT ARGUMENTS--DX = THE DOUBLE PRECISION VALUE AT C WHICH THE PROBABILITY DENSITY C FUNCTION IS TO BE EVALUATED. C OUTPUT ARGUMENTS--BEIFUN = THE DOUBLE PRECISION PROBABILITY C DENSITY FUNCTION VALUE. C OUTPUT--THE DOUBLE PRECISION PROBABILITY DENSITY C FUNCTION VALUE PDF FOR THE BESSEL I-FUNCTION C DISTRIBUTION WITH SHAPE PARAMETERS S1SQ, S2SQ, AND NU. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--NONE. C OTHER DATAPAC SUBROUTINES NEEDED--BEIPDF. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, (1994), "CONTINUOUS C UNIVARIATE DISTRIBUTIONS--VOLUME 1", SECOND EDITION, C WILEY, PP. 50-53. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2004.8 C ORIGINAL VERSION--AUGUST 2004. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DTERM C DOUBLE PRECISION DX DOUBLE PRECISION DS1SQ DOUBLE PRECISION DS2SQ DOUBLE PRECISION DNU CHARACTER*4 IBEID2 COMMON/BEICOM/DS1SQ,DS2SQ,DNU,IBEID2 C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----DATA STATEMENTS------------------------------------------------- C C-----START POINT----------------------------------------------------- C C ************************************ C ** STEP 1-- ** C ** COMPUTE THE DENSITY FUNCTION ** C ************************************ C CCCCC CALL BEIPD2(DX,DS1SQ,DS2SQ,DNU,DTERM) CALL BEIPDF(DX,DS1SQ,DS2SQ,DNU,IBEID2,DTERM) BEIFUN=DTERM C 9000 CONTINUE RETURN END DOUBLE PRECISION FUNCTION BEIFU2(DX) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY C FUNCTION VALUE FOR THE BESSEL I-FUNCTION C DISTRIBUTION WITH SHAPE PARAMETERS S1SQ, S2SQ, AND C NU. THIS DISTRIBUTION IS DEFINED FOR POSITIVE X C AND HAS THE PROBABILITY DENSITY FUNCTION C C BEIPDF(X,S1AQ,S2SQ,ANU) = C K*X**M*EXP(-C*X/B)*PI*I(X/B,M) X > 0 C WITH C B = 4*S1SQ**2*S2SQ**2/(S1SQ**2 - S2SQ**2) C C = (S1SQ**2 + S2SQ**2)/(S1SQ**2 - S2SQ**2) C M = 2*NU + 1 C AND C K = |1 - C**2|**(M+0.5)/[SQRT(PI)*2**M*b**(M+1)* C GAMMA(M+0.5)] C I(Z,N) IS THE MODIFIED BESSEL FUNCTION OF THE C FIRST KIND C GAMMA IS THE GAMMA FUNCTION C C THE BEICDF ROUTINE IS CALLED TO COMPUTE THE C CUMULATIVE DISTRIBUTION. C DEFINE AS FUNCTION TO BE USED FOR INTEGRATION C CODE CALLED BY BEICDF. THIS ROUTINE USES C DOUBLE PRECISION ARITHMETIC. C INPUT ARGUMENTS--DX = THE DOUBLE PRECISION VALUE AT C WHICH THE PROBABILITY DENSITY C FUNCTION IS TO BE EVALUATED. C OUTPUT ARGUMENTS--BEIFU2 = THE DOUBLE PRECISION PROBABILITY C DENSITY FUNCTION VALUE. C OUTPUT--THE DOUBLE PRECISION PROBABILITY DENSITY C FUNCTION VALUE PDF FOR THE GENERALIZED INVERSE C GAUSSIAN DISTRIBUTION WITH SHAPE PARAMETERS S1SQ, S2SQ, C AND NU. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--NONE. C OTHER DATAPAC SUBROUTINES NEEDED--BEICDF. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, (1994), "CONTINUOUS C UNIVARIATE DISTRIBUTIONS--VOLUME 1", SECOND EDITION, C WILEY, PP. 50-53. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2004.8 C ORIGINAL VERSION--AUGUST 2004. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DX DOUBLE PRECISION DCDF C DOUBLE PRECISION DP COMMON/BE2COM/DP C DOUBLE PRECISION DS1SQ DOUBLE PRECISION DS2SQ DOUBLE PRECISION DNU CHARACTER*4 IBEID2 COMMON/BEICOM/DS1SQ,DS2SQ,DNU,IBEID2 C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----DATA STATEMENTS------------------------------------------------- C C-----START POINT----------------------------------------------------- C C ************************************ C ** STEP 1-- ** C ** COMPUTE THE CDF FUNCTION ** C ************************************ C CALL BEICDF(DX,DS1SQ,DS2SQ,DNU,IBEID2,DCDF) BEIFU2=DP - DCDF C 9000 CONTINUE RETURN END SUBROUTINE BEIPDF(X,S1SQ,S2SQ,NU,IBEIDF,PDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY C FUNCTION VALUE FOR THE BESSEL I-FUNCTION C DISTRIBUTION. IT HAS SHAPE PARAMETERS C SIGMA1, SIGMA2, AND NU. THIS DISTRIBUTION IS DEFINED C FOR POSITIVE X AND HAS THE PROBABILITY DENSITY FUNCTION C C BEIPDF(X,S1AQ,S2SQ,NU) = C K*X**M*EXP(-C*X/B)*PI*I(X/B,M) X > 0 C WITH C B = 4*S1SQ**2*S2SQ**2/(S1SQ**2 - S2SQ**2) C C = (S1SQ**2 + S2SQ**2)/(S1SQ**2 - S2SQ**2) C M = 2*NU + 1 C AND C K = |1 - C**2|**(M+0.5)/[SQRT(PI)*2**M*b**(M+1)* C GAMMA(M+0.5)] C I(Z,N) IS THE MODIFIED BESSEL FUNCTION OF THE C FIRST KIND C GAMMA IS THE GAMMA FUNCTION C C NOTE--ARGUMENTS TO THIS ROUTINE ARE IN DOUBLE PRECISION. C INPUT ARGUMENTS--X = THE DOUBLE PRECISION VALUE AT C WHICH THE PROBABILITY DENSITY C FUNCTION IS TO BE EVALUATED. C X SHOULD BE POSITIVE C --S1SQ = THE FIRST SHAPE PARAMETER C --S2SQ = THE SECOND SHAPE PARAMETER C --NU = THE THIRD SHAPE PARAMETER C OUTPUT ARGUMENTS--PDF = THE DOUBLE PRECISION PROBABILITY C DENSITY FUNCTION VALUE. C OUTPUT--THE DOUBLE PRECISION PROBABILITY DENSITY FUNCTION C VALUE PDF FOR THE BESSEL-I DISTRIBUTION C WITH SHAPE PARAMETERS = S1SQ, S2SQ, AND NU. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--NONE. C OTHER DATAPAC SUBROUTINES NEEDED--DBESI. C FORTRAN LIBRARY SUBROUTINES NEEDED--DEXP, DLOG. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--JOHNSON, KOTZ, AND BALAKRISNAN, "CONTINUOUS C UNIVARIATE DISTRIBUTIONS--VOLUME I", SECOND EDITION, C WILEY, 1994, PP. 50-53. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2004.8 C ORIGINAL VERSION--AUGUST 2004. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C CHARACTER*4 IBEIDF C DOUBLE PRECISION X DOUBLE PRECISION NU DOUBLE PRECISION S1SQ DOUBLE PRECISION S2SQ DOUBLE PRECISION PDF DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 DOUBLE PRECISION DTERM3 DOUBLE PRECISION DTERM4 DOUBLE PRECISION DTERM5 DOUBLE PRECISION DC1 DOUBLE PRECISION DC2 DOUBLE PRECISION DC DOUBLE PRECISION DB DOUBLE PRECISION DM DOUBLE PRECISION DPI CCCCC DOUBLE PRECISION DGAMMA CCCCC EXTERNAL DGAMMA DOUBLE PRECISION DLNGAM EXTERNAL DLNGAM C DOUBLE PRECISION DTEMP1(10) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----DATA STATEMENTS------------------------------------------------- C DATA DPI / 3.14159265358979D+00/ C C-----START POINT----------------------------------------------------- C C ***************************************** C ** STEP 1-- ** C ** CHECK FOR VALID PARAMETERS ** C ***************************************** C IF(IBEIDF.EQ.'1')THEN DB=4.0D0*S1SQ*S2SQ/(S1SQ - S2SQ) DC=(S1SQ + S2SQ)/(S1SQ - S2SQ) DM=2.0D0*NU + 1.0D0 ELSE DB=S1SQ DC=S2SQ DM=NU ENDIF C IF(DABS(DC).LE.1.0D0)THEN WRITE(ICOUT,9) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,10) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,11) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,12)S1SQ CALL DPWRST('XXX','WRIT') WRITE(ICOUT,13)S2SQ CALL DPWRST('XXX','WRIT') WRITE(ICOUT,14)DC CALL DPWRST('XXX','WRIT') PDF=0.0D0 GOTO9000 ENDIF 9 FORMAT('***** ERROR: ABSOLUTE VALUE OF 1 - C**2 <= 1 ', 1 'IN BEIPDF ROUTINE.') 10 FORMAT(' C = (S1**2 + S2**2)/(S1**2 - S2**2) WHERE ', 1 'S1**2 AND S2**2') 11 FORMAT(' ARE THE FIRST AND SECOND SHAPE PARAMETERS, ', 1 'RESPECTIVELY.') 12 FORMAT(' VALUE OF S1**2 IS: ',G15.7) 13 FORMAT(' VALUE OF S2**2 IS: ',G15.7) 14 FORMAT(' VALUE OF C IS: ',G15.7) IF(DC.GT.0.0D0 .AND. X.LE.0.0D0)THEN WRITE(ICOUT,24) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,25) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,48)X CALL DPWRST('XXX','WRIT') PDF=0.0D0 GOTO9000 ENDIF 24 FORMAT('***** ERROR: VALUE OF THE INPUT ARGUMENT ', 1 'IN BEIPDF ROUTINE IS NON-POSITIVE') 25 FORMAT(' FOR THE CASE WHERE S1**2 > S2**2 (THESE ARE THE ', 1 'FIRST AND SECOND SHAPE PARAMETERS).') IF(DC.LT.0.0D0 .AND. X.GE.0.0D0)THEN WRITE(ICOUT,34) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,35) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,48)X CALL DPWRST('XXX','WRIT') PDF=0.0D0 GOTO9000 ENDIF 34 FORMAT('***** ERROR: VALUE OF THE INPUT ARGUMENT ', 1 'IN BEIPDF ROUTINE IS NON-NEGATIVE') 35 FORMAT(' FOR THE CASE WHERE S1**2 < S2**2 (THESE ARE THE ', 1 'FIRST AND SECOND SHAPE PARAMETERS).') IF(S1SQ.LE.0.0D0)THEN WRITE(ICOUT,5) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,48)S1SQ CALL DPWRST('XXX','WRIT') PDF=0.0D0 GOTO9000 ENDIF 5 FORMAT('***** ERROR: VALUE OF FIRST SHAPE PARAMETER (SIGMA1**2)', 1 ' IN BEIPDF ROUTINE IS NON-POSITIVE.') IF(S2SQ.LE.0.0D0)THEN WRITE(ICOUT,6) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,48)S2SQ CALL DPWRST('XXX','WRIT') PDF=0.0D0 GOTO9000 ENDIF 6 FORMAT('***** ERROR: VALUE OF SECOND SHAPE PARAMETER ', 1 '(SIGMA2**2) IN BEIPDF ROUTINE IS NON-POSITIVE.') IF(IBEIDF.EQ.'1')THEN IF(NU.LE.-0.25D0)THEN WRITE(ICOUT,7) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,48)NU CALL DPWRST('XXX','WRIT') CDF=0.0D0 GOTO9000 ENDIF ELSE IF(DM.LE.0.5D0)THEN WRITE(ICOUT,8) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,48)DM CALL DPWRST('XXX','WRIT') CDF=0.0D0 GOTO9000 ENDIF ENDIF 7 FORMAT('***** ERROR: VALUE OF THIRD SHAPE PARAMETER (NU) IN ', 1 'BEIPDF ROUTINE IS < -0.25.') 8 FORMAT('***** ERROR: VALUE OF THIRD SHAPE PARAMETER (M) IN ', 1 'BEIPDF ROUTINE IS <= 0.5.') C 48 FORMAT(' VALUE OF ARGUMENT IS: ',G15.7) C C ***************************************** C ** STEP 2-- ** C ** COMPUTE THE DENSITY FUNCTION. FOR ** C ** BETTER NUMERICAL STABILITY, DO THE ** C ** FOLLOWING: ** C ** 1) COMPUTE LOGARIGHMS. ** C ** 2) COMPUTE THE SCALED VERSION OF ** C ** THE BESSEL FUNCTION (ADDS A ** C ** EXP(-X) TERM, SO DIVIDE RESULT ** C ** BY EXP(-X) ** C ***************************************** C C C COMPUTE BESSEL FUNCTION FIRST. IF THIS IS 0, SET PDF TO C 0 AND RETURN. C IARG1=1 ISCALE=1 CALL DBESI(DABS(X/DB),DM,ISCALE,IARG1,DTEMP1,NZERO) DTERM3=DTEMP1(IARG1) IF(DTERM3.LE.0.0D0)THEN PDF=0.0D0 GOTO9000 ENDIF DTERM3=DLOG(DTERM3) C DC1=(DM+0.5D0)*DLOG(DABS(1.0D0-DC**2)) + 0.5D0*DLOG(DPI) DC2=DM*DLOG(2.0D0) + (DM+1.0D0)*DLOG(DB) + DLNGAM(DM+0.5D0) DTERM1=DC1 - DC2 CCCCC DC1=DABS(1.0D0-DC**2)**(DM+0.5D0) CCCCC DC2=DSQRT(DPI)*(2.0D0**DM)*(DB**(DM+1.0D0))*DGAMMA(DM+0.5D0) CCCCC DTERM1=DLOG(DC1/DC2) DTERM2=DM*DLOG(X) DTERM4=-DC*X/DB C DTERM5=DTERM1+DTERM2+DTERM4+DTERM3 PDF=DEXP(DTERM5) C 9000 CONTINUE RETURN END SUBROUTINE BEIPPF(P,S1SQ,S2SQ,NU,IBEIDF,PPF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT C FUNCTION VALUE FOR THE BESSEL I-FUNCTION C DISTRIBUTION. IT HAS SHAPE PARAMETERS S1SQ, S2SQ, C AND NU. THIS DISTRIBUTION IS DEFINED FOR POSITIVE C X AND HAS THE PROBABILITY DENSITY FUNCTION C C BEIPDF(X,S1AQ,S2SQ,NU) = C K*X**M*EXP(-C*X/B)*PI*I(X/B,M) X > 0 C WITH C B = 4*S1SQ**2*S2SQ**2/(S1SQ**2 - S2SQ**2) C C = (S1SQ**2 + S2SQ**2)/(S1SQ**2 - S2SQ**2) C M = 2*NU + 1 C AND C K = |1 - C**2|**(M+0.5)/[SQRT(PI)*2**M*b**(M+1)* C GAMMA(M+0.5)] C I(Z,N) IS THE MODIFIED BESSEL FUNCTION OF THE C FIRST KIND C GAMMA IS THE GAMMA FUNCTION C C THE PERCENT POINT FUNCTION IS COMPUTED BY NUMERICALLY C INVERTING THE BESSEL I-FUNCTION CUMULATIVE C DISTRIBUTION FUNCTION (WHICH IN TURN IS COMPUTED BY C NUMERICAL INTEGRATION OF THE PROBABILITYT DENSITY. C C INPUT ARGUMENTS--P = THE DOUBLE PRECISION VALUE AT C WHICH THE PERCENT POINT C FUNCTION IS TO BE EVALUATED. C 0 < P < 1 C --S1SQ = THE FIRST SHAPE PARAMETER C --S2SQ = THE THIRD SHAPE PARAMETER C --NU = THE THIRD SHAPE PARAMETER C OUTPUT ARGUMENTS--PPF = THE SINGLE PRECISION PERCENT POINT C FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION PERCENT POINT FUNCTION C VALUE PPF FOR THE BESSEL I-FUNCTION C DISTRIBUTION WITH SHAPE PARAMETERS = S1SQ, S2SQ, NU. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--NONE. C OTHER DATAPAC SUBROUTINES NEEDED--DFZERO. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, (1994), "CONTINUOUS C UNIVARIATE DISTRIBUTIONS--VOLUME 1", SECOND EDITION, C WILEY, PP. 50-53. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2004.8 C ORIGINAL VERSION--AUGUST 2004. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C CHARACTER*4 IBEIDF C DOUBLE PRECISION P DOUBLE PRECISION PTEMP DOUBLE PRECISION S1SQ DOUBLE PRECISION S2SQ DOUBLE PRECISION NU DOUBLE PRECISION PPF DOUBLE PRECISION DMEAN DOUBLE PRECISION DSD DOUBLE PRECISION DM DOUBLE PRECISION DB DOUBLE PRECISION DC DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 DOUBLE PRECISION DTERM3 C DOUBLE PRECISION DTEMP1(10) C DOUBLE PRECISION XUP DOUBLE PRECISION XUP2 DOUBLE PRECISION XLOW DOUBLE PRECISION RE DOUBLE PRECISION AE C DOUBLE PRECISION BEIFU2 EXTERNAL BEIFU2 C DOUBLE PRECISION DP COMMON/BE2COM/DP C DOUBLE PRECISION DS1SQ DOUBLE PRECISION DS2SQ DOUBLE PRECISION DANU CHARACTER*4 IBEID2 COMMON/BEICOM/DS1SQ,DS2SQ,DANU,IBEID2 C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C ***************************************** C ** STEP 1-- ** C ** CHECK FOR VALID PARAMETERS ** C ***************************************** C IF(P.LE.0.0D0 .OR. P.GE.1.0D0)THEN WRITE(ICOUT,3) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,4) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,48)P CALL DPWRST('XXX','WRIT') PPF=0.0D0 GOTO9000 ENDIF 3 FORMAT('***** ERROR: VALUE OF INPUT ARGUMENT (P) IN ', 1 'BEIPPF ROUTINE') 4 FORMAT(' IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL.') C IF(IBEIDF.EQ.'1')THEN DB=4.0D0*S1SQ*S2SQ/(S1SQ - S2SQ) DC=(S1SQ + S2SQ)/(S1SQ - S2SQ) DM=2.0D0*NU + 1.0D0 ELSE DB=S1SQ DC=S2SQ DM=NU ENDIF C IF(DABS(DC).LE.1.0D0)THEN WRITE(ICOUT,9) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,10) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,11) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,12)S1SQ CALL DPWRST('XXX','WRIT') WRITE(ICOUT,13)S2SQ CALL DPWRST('XXX','WRIT') WRITE(ICOUT,14)DC CALL DPWRST('XXX','WRIT') PPF=0.0D0 GOTO9000 ENDIF 9 FORMAT('***** ERROR: ABSOLUTE VALUE OF 1 - C**2 <= 1 ', 1 'IN BEIPPF ROUTINE.') 10 FORMAT(' C = (S1**2 + S2**2)/(S1**2 - S2**2) WHERE ', 1 'S1**2 AND S2**2') 11 FORMAT(' ARE THE FIRST AND SECOND SHAPE PARAMETERS, ', 1 'RESPECTIVELY.') 12 FORMAT(' VALUE OF S1**2 IS: ',G15.7) 13 FORMAT(' VALUE OF S2**2 IS: ',G15.7) 14 FORMAT(' VALUE OF C IS: ',G15.7) IF(S1SQ.LE.0.0D0)THEN WRITE(ICOUT,5) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,48)S1SQ CALL DPWRST('XXX','WRIT') PPF=0.0D0 GOTO9000 ENDIF 5 FORMAT('***** ERROR: VALUE OF FIRST SHAPE PARAMETER (SIGMA1**2)', 1 ' IN BEIPPF ROUTINE IS NON-POSITIVE.') IF(S2SQ.LE.0.0D0)THEN WRITE(ICOUT,6) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,48)S2SQ CALL DPWRST('XXX','WRIT') PPF=0.0D0 GOTO9000 ENDIF 6 FORMAT('***** ERROR: VALUE OF SECOND SHAPE PARAMETER ', 1 '(SIGMA2**2) IN BEIPPF ROUTINE IS NON-POSITIVE.') IF(IBEIDF.EQ.'1')THEN IF(NU.LE.-0.25D0)THEN WRITE(ICOUT,7) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,48)NU CALL DPWRST('XXX','WRIT') CDF=0.0D0 GOTO9000 ENDIF ELSE IF(DM.LE.0.5D0)THEN WRITE(ICOUT,8) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,48)DM CALL DPWRST('XXX','WRIT') CDF=0.0D0 GOTO9000 ENDIF ENDIF 7 FORMAT('***** ERROR: VALUE OF THIRD SHAPE PARAMETER (NU) IN ', 1 'BEICDF ROUTINE IS < -0.25.') 8 FORMAT('***** ERROR: VALUE OF THIRD SHAPE PARAMETER (M) IN ', 1 'BEICDF ROUTINE IS <= 0.5.') 48 FORMAT(' VALUE OF ARGUMENT IS: ',G15.7) C C ***************************************** C ** STEP 2-- ** C ** COMPUTE THE PERCENT POINT FUNCTION.** C ***************************************** C C STEP 1: FIND BRACKETING INTERVAL. LOWER BOUND IS ZERO. START C WITH UPPER BOUND = MEAN: C MEAN=(2*M+1)*B*C/(C**2-1) C INCREMENT IN INTERVALS OF 1 STANDARD DEVIATION: C VARIANCE=2*M+1)*B**2*(C**2+1)/(C2-1)**2 C K(ANU)(SQRT(S2SQ*S1SQ)) C XLOW=1.0D-12 CALL BEICDF(XLOW,S1SQ,S2SQ,NU,IBEIDF,PTEMP) IF(P.LE.PTEMP)THEN PPF=XLOW GOTO9000 ENDIF C DMEAN=(2.0D0*DM+1.0D0)*DB*DC/(DC**2-1.0D0) DSD=(2.0D0*DM+1.0D0)*DB*(DC**2+1.0D0)/(DC**2-1.0D0)**2 IF(DSD.GE.0.0D0)DSD=DSQRT(DSD) C MAXIT=1000 NIT=0 C XUP2=DMEAN 200 CONTINUE IF(NIT.GT.MAXIT)THEN PPF=0.0D0 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,131) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,133) CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF CALL BEICDF(XUP2,S1SQ,S2SQ,NU,IBEIDF,PTEMP) IF(PTEMP.GT.P)THEN XUP=XUP2 ELSE XLOW=XUP2 XUP2=XUP2 + DSD NIT=NIT+1 GOTO200 ENDIF C 300 CONTINUE AE=1.D-7 RE=1.D-7 DS1SQ=S1SQ DS2SQ=S2SQ DANU=NU DP=P CALL DFZERO(BEIFU2,XLOW,XUP,XUP,RE,AE,IFLAG) C PPF=XLOW C IF(IFLAG.EQ.2)THEN C C NOTE: SUPPRESS THIS MESSAGE FOR NOW. CCCCC WRITE(ICOUT,999) 999 FORMAT(1X) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,111) CC111 FORMAT('***** WARNING FROM BEIPPF--') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,113) CC113 FORMAT(' PPF VALUE MAY NOT BE COMPUTED TO DESIRED ', CCCCC1 'TOLERANCE.') CCCCC CALL DPWRST('XXX','BUG ') ELSEIF(IFLAG.EQ.3)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,121) 121 FORMAT('***** WARNING FROM BEIPPF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,123) 123 FORMAT(' PPF VALUE MAY BE NEAR A SINGULAR POINT.') CALL DPWRST('XXX','BUG ') ELSEIF(IFLAG.EQ.4)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,131) 131 FORMAT('***** ERROR FROM BEIPPF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,133) 133 FORMAT(' APPROPRIATE BRACKETING INTERVAL NOT FOUND.') CALL DPWRST('XXX','BUG ') ELSEIF(IFLAG.EQ.5)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,141) 141 FORMAT('***** WARNING FROM BEIPPF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,143) 143 FORMAT(' MAXIMUM ITERATIONS EXCEEDED.') CALL DPWRST('XXX','BUG ') ENDIF C C 9000 CONTINUE RETURN END SUBROUTINE BEIRAN(N,S1SQ,S2SQ,NU,IBEIDF,ISEED,X) C C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N C FROM THE BESSEL I-FUNCTION DISTRIBUTION WITH SHAPE C PARAMETERS S1SQ, S2SQ, AND NU. THIS DISTRIBUTION IS C DEFINED FOR POSITIVE X AND HAS THE PROBABILITY DENSITY C FUNCTION C C BEIPDF(X,S1AQ,S2SQ,NU) = C K*X**M*EXP(-C*X/B)*PI*I(X/B,M) X > 0 C WITH C B = 4*S1SQ**2*S2SQ**2/(S1SQ**2 - S2SQ**2) C C = (S1SQ**2 + S2SQ**2/(S1SQ**2 - S2SQ**2) C M = 2*NU + 1 C AND C K = |1 - C**2|**(M+0.5)/[SQRT(PI)*2**M*b**(M+1)* C GAMMA(M+0.5)] C I(Z,N) IS THE MODIFIED BESSEL FUNCTION OF THE C FIRST KIND C GAMMA IS THE GAMMA FUNCTION C C INPUT ARGUMENTS--N = THE DESIRED INTEGER NUMBER C OF RANDOM NUMBERS TO BE C GENERATED. C --S1SQ = THE FIRST SHAPE PARAMETER C --S2SQ = THE SECOND SHAPE PARAMETER C --NU = THE THIRD SHAPE PARAMETER C OUTPUT ARGUMENTS--X = A SINGLE PRECISION VECTOR C (OF DIMENSION AT LEAST N) C INTO WHICH THE GENERATED C RANDOM SAMPLE WILL BE PLACED. C OUTPUT--A RANDOM SAMPLE OF SIZE N FROM THE BESSEL I-FUNCTION C DISTRIBUTION WITH SHAPE PARAMETERS S1SQ, S2SQ, AND NU. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C OTHER DATAPAC SUBROUTINES NEEDED--CHIRAN. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--JOHNSON, KOTZ, AND BALAKRISNAN, "CONTINUOUS C UNIVARIATE DISTRIBUTIONS--VOLUME I", SECOND EDITION, C WILEY, 1994, PP. 50-53. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATION INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2004.8 C ORIGINAL VERSION--AUGUST 2004. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C CHARACTER*4 IBEIDF C DIMENSION X(*) CCCCC DIMENSION Y(2) DOUBLE PRECISION DPPF C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----DATA STATEMENTS------------------------------------------------- C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(N.LT.1)THEN WRITE(ICOUT,5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,6) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)N CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF C 5 FORMAT('***** ERROR--FOR THE BESSEL I-FUNCTION DISTRIBUTION, ', 1 'THE REQUESTED') 6 FORMAT(' NUMBER OF RANDOM NUMBERS WAS NON-POSITIVE.') 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,'.') C IF(IBEIDF.EQ.'1')THEN DB=4.0D0*S1SQ*S2SQ/(S1SQ - S2SQ) DC=(S1SQ + S2SQ)/(S1SQ - S2SQ) DM=2.0D0*NU + 1.0D0 ELSE DB=S1SQ DC=S2SQ DM=NU ENDIF C IF(ABS(DC).LE.1.0)THEN WRITE(ICOUT,9) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,10) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,11) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,12)S1SQ CALL DPWRST('XXX','WRIT') WRITE(ICOUT,13)S2SQ CALL DPWRST('XXX','WRIT') WRITE(ICOUT,14)DC CALL DPWRST('XXX','WRIT') GOTO9999 ENDIF 9 FORMAT('***** ERROR: ABSOLUTE VALUE OF 1 - C**2 <= 1 ', 1 'IN BEIRAN ROUTINE.') 10 FORMAT(' C = (S1**2 + S2**2)/(S1**2 - S2**2) WHERE ', 1 'S1**2 AND S2**2') 11 FORMAT(' ARE THE FIRST AND SECOND SHAPE PARAMETERS, ', 1 'RESPECTIVELY.') 12 FORMAT(' VALUE OF S1**2 IS: ',G15.7) 13 FORMAT(' VALUE OF S2**2 IS: ',G15.7) 14 FORMAT(' VALUE OF C IS: ',G15.7) IF(S1SQ.LE.0.0)THEN WRITE(ICOUT,15) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,48)S1SQ CALL DPWRST('XXX','WRIT') GOTO9999 ENDIF 15 FORMAT('***** ERROR: VALUE OF FIRST SHAPE PARAMETER (SIGMA1**2)', 1 ' IN BEIRAN ROUTINE IS NON-POSITIVE.') IF(S2SQ.LE.0.0)THEN WRITE(ICOUT,16) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,48)S2SQ CALL DPWRST('XXX','WRIT') GOTO9999 ENDIF 16 FORMAT('***** ERROR: VALUE OF SECOND SHAPE PARAMETER ', 1 '(SIGMA2**2) IN BEIRAN ROUTINE IS NON-POSITIVE.') IF(IBEIDF.EQ.'1')THEN IF(NU.LE.-0.25D0)THEN WRITE(ICOUT,17) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,48)NU CALL DPWRST('XXX','WRIT') CDF=0.0D0 GOTO9999 ENDIF ELSE IF(DM.LE.0.5D0)THEN WRITE(ICOUT,18) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,48)DM CALL DPWRST('XXX','WRIT') CDF=0.0D0 GOTO9999 ENDIF ENDIF 17 FORMAT('***** ERROR: VALUE OF THIRD SHAPE PARAMETER (NU) IN ', 1 'BEIANF ROUTINE IS < -0.25.') 18 FORMAT('***** ERROR: VALUE OF THIRD SHAPE PARAMETER (M) IN ', 1 'BEIRAN ROUTINE IS <= 0.5.') C 48 FORMAT(' VALUE OF ARGUMENT IS: ',G15.7) C C BESSEL I-FUNCTION IS DISTRIBUTION OF C S1SQ*X1 + S2SQ*X2 C WHERE X1 AND X2 ARE CHI-SQUARE RANDOM NUMBERS WITH DEGREES C OF FREEDOM PARAMETERS NU. C C NOTE: ABOVE ALGORITHM DOES NOT SEEM TO CORRESPOND TO C BESSEL I-FUNCTION PDF, SO FOR NOW USE PERCENT POINT C FUNCTION. C CALL UNIRAN(N,ISEED,X) CCCCC NTEMP=2 DO100I=1,N CCCCC CALL CHSRAN(NTEMP,NU,ISEED,Y) CCCCC X(I)=S1SQ*Y(1) + S2SQ*Y(2) PTEMP=X(I) CALL BEIPPF(DBLE(PTEMP),DBLE(S1SQ),DBLE(S2SQ),DBLE(NU), 1 IBEIDF,DPPF) X(I)=REAL(DPPF) 100 CONTINUE C 9999 CONTINUE RETURN END SUBROUTINE BERNOB(N,BN) C C ====================================== C Purpose: Compute Bernoulli number Bn C Input : n --- Serial number C Output: BN(n) --- Bn C ====================================== C IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION BN(0:N) C REAL CPUMIN, CPUMAX CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C TPI=6.283185307179586D0 BN(0)=1.0D0 BN(1)=-0.5D0 BN(2)=1.0D0/6.0D0 DO1I=3,N BN(I)=0.0D0 1 CONTINUE IF(N.LE.3)RETURN R1=(2.0D0/TPI)**2 IFLAG=0 DO 20 M=4,N,2 IF(IFLAG.EQ.1)THEN BN(M)=DBLE(CPUMAX) GOTO20 ENDIF R1=-R1*(M-1)*M/(TPI*TPI) R2=1.0D0 DO 10 K=2,10000 S=(1.0D0/K)**M R2=R2+S IF (S.LT.1.0D-15) GOTO 29 10 CONTINUE 29 CONTINUE BN(M)=R1*R2 IF(BN(M).GE.DBLE(CPUMAX))THEN WRITE(ICOUT,90)M CALL DPWRST('XXX','BUG') 90 FORMAT('***** ERROR: BN OVERFLOWS AT N = ',I8) IFLAG=1 ENDIF 20 CONTINUE RETURN END SUBROUTINE BERNPN(X,N,BN) C C ====================================== C Purpose: Compute Bernoulli polynomial of order n for X C Input : n --- Order of Bernoulli polynomial C x --- value at which to compute the polynomial C Output: BN--- computed value C ====================================== C IMPLICIT DOUBLE PRECISION (A-H,O-Z) C DIMENSION DTEMP(200) C REAL CPUMIN, CPUMAX CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C IF(N.EQ.0)THEN BN=0.D0 ELSEIF(N.EQ.1)THEN BN=-0.5D0+X ELSE TERM1=X TERM2=DBLE(N-1) IF(X.EQ.0.0D0 .AND. N-1.EQ.0)THEN TERM3=1.0D0 ELSE TERM3=X**(N-1) ENDIF SUM=TERM3*(X-REAL(N)/2.0D0) DO100I=1,N/2 CALL BERNOB(2*I,DTEMP) TERM4=DTEMP(2*I+1) TERM5=DBINOM(N,2*I) SUM=SUM + TERM4*TERM5*TERM6 IF(X.EQ.0.0D0 .AND. N-1.EQ.0)THEN TERM6=1.0D0 ELSE TERM6=X**(N-2*I) ENDIF 100 CONTINUE BN=SUM ENDIF C RETURN END SUBROUTINE BESI (X, ALPHA, KODE, N, Y, NZ) C***BEGIN PROLOGUE BESI C***PURPOSE Compute an N member sequence of I Bessel functions C I/SUB(ALPHA+K-1)/(X), K=1,...,N or scaled Bessel functions C EXP(-X)*I/SUB(ALPHA+K-1)/(X), K=1,...,N for non-negative C ALPHA and X. C***LIBRARY SLATEC C***CATEGORY C10B3 C***TYPE SINGLE PRECISION (BESI-S, DBESI-D) C***KEYWORDS I BESSEL FUNCTION, SPECIAL FUNCTIONS C***AUTHOR Amos, D. E., (SNLA) C Daniel, S. L., (SNLA) C***DESCRIPTION C C Abstract C BESI computes an N member sequence of I Bessel functions C I/sub(ALPHA+K-1)/(X), K=1,...,N or scaled Bessel functions C EXP(-X)*I/sub(ALPHA+K-1)/(X), K=1,...,N for non-negative ALPHA C and X. A combination of the power series, the asymptotic C expansion for X to infinity, and the uniform asymptotic C expansion for NU to infinity are applied over subdivisions of C the (NU,X) plane. For values not covered by one of these C formulae, the order is incremented by an integer so that one C of these formulae apply. Backward recursion is used to reduce C orders by integer values. The asymptotic expansion for X to C infinity is used only when the entire sequence (specifically C the last member) lies within the region covered by the C expansion. Leading terms of these expansions are used to test C for over or underflow where appropriate. If a sequence is C requested and the last member would underflow, the result is C set to zero and the next lower order tried, etc., until a C member comes on scale or all are set to zero. An overflow C cannot occur with scaling. C C Description of Arguments C C Input C X - X .GE. 0.0E0 C ALPHA - order of first member of the sequence, C ALPHA .GE. 0.0E0 C KODE - a parameter to indicate the scaling option C KODE=1 returns C Y(K)= I/sub(ALPHA+K-1)/(X), C K=1,...,N C KODE=2 returns C Y(K)=EXP(-X)*I/sub(ALPHA+K-1)/(X), C K=1,...,N C N - number of members in the sequence, N .GE. 1 C C Output C Y - a vector whose first N components contain C values for I/sub(ALPHA+K-1)/(X) or scaled C values for EXP(-X)*I/sub(ALPHA+K-1)/(X), C K=1,...,N depending on KODE C NZ - number of components of Y set to zero due to C underflow, C NZ=0 , normal return, computation completed C NZ .NE. 0, last NZ components of Y set to zero, C Y(K)=0.0E0, K=N-NZ+1,...,N. C C Error Conditions C Improper input arguments - a fatal error C Overflow with KODE=1 - a fatal error C Underflow - a non-fatal error (NZ .NE. 0) C C***REFERENCES D. E. Amos, S. L. Daniel and M. K. Weston, CDC 6600 C subroutines IBESS and JBESS for Bessel functions C I(NU,X) and J(NU,X), X .GE. 0, NU .GE. 0, ACM C Transactions on Mathematical Software 3, (1977), C pp. 76-92. C F. W. J. Olver, Tables of Bessel Functions of Moderate C or Large Orders, NPL Mathematical Tables 6, Her C Majesty's Stationery Office, London, 1962. C***ROUTINES CALLED ALNGAM, ASYIK, I1MACH, R1MACH, XERMSG C***REVISION HISTORY (YYMMDD) C 750101 DATE WRITTEN C 890531 Changed all specific intrinsics to generic. (WRB) C 890531 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) C 900326 Removed duplicate information from DESCRIPTION section. C (WRB) C 920501 Reformatted the REFERENCES section. (WRB) C***END PROLOGUE BESI C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOMC.INC' CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C INTEGER I, IALP, IN, INLIM, IS, I1, K, KK, KM, KODE, KT, 1 N, NN, NS, NZ REAL AIN, AK, AKM, ALPHA, ANS, AP, ARG, ATOL, TOLLN, DFN, 1 DTM, DX, EARG, ELIM, ETX, FLGIK,FN, FNF, FNI,FNP1,FNU,GLN,RA, 2 RTTPI, S, SX, SXO2, S1, S2, T, TA, TB, TEMP, TFN, TM, TOL, 3 TRX, T2, X, XO2, XO2L, Y, Z DOUBLE PRECISION DLNGAM DIMENSION Y(*), TEMP(3) SAVE RTTPI, INLIM DATA RTTPI / 3.98942280401433E-01/ DATA INLIM / 80 / C***FIRST EXECUTABLE STATEMENT BESI NZ = 0 KT = 1 C I1MACH(15) REPLACES I1MACH(12) IN A DOUBLE PRECISION CODE C I1MACH(14) REPLACES I1MACH(11) IN A DOUBLE PRECISION CODE RA = R1MACH(3) TOL = MAX(RA,1.0E-15) I1 = -I1MACH(12) GLN = R1MACH(5) ELIM = 2.303E0*(I1*GLN-3.0E0) C TOLLN = -LN(TOL) I1 = I1MACH(11)+1 TOLLN = 2.303E0*GLN*I1 TOLLN = MIN(TOLLN,34.5388E0) IF (N-1) 590, 10, 20 10 KT = 2 20 NN = N IF (KODE.LT.1 .OR. KODE.GT.2) GO TO 570 IF (X) 600, 30, 80 30 IF (ALPHA) 580, 40, 50 40 Y(1) = 1.0E0 IF (N.EQ.1) RETURN I1 = 2 GO TO 60 50 I1 = 1 60 DO 70 I=I1,N Y(I) = 0.0E0 70 CONTINUE RETURN 80 CONTINUE IF (ALPHA.LT.0.0E0) GO TO 580 C IALP = INT(ALPHA) FNI = IALP + N - 1 FNF = ALPHA - IALP DFN = FNI + FNF FNU = DFN IN = 0 XO2 = X*0.5E0 SXO2 = XO2*XO2 ETX = KODE - 1 SX = ETX*X C C DECISION TREE FOR REGION WHERE SERIES, ASYMPTOTIC EXPANSION FOR X C TO INFINITY AND ASYMPTOTIC EXPANSION FOR NU TO INFINITY ARE C APPLIED. C IF (SXO2.LE.(FNU+1.0E0)) GO TO 90 IF (X.LE.12.0E0) GO TO 110 FN = 0.55E0*FNU*FNU FN = MAX(17.0E0,FN) IF (X.GE.FN) GO TO 430 ANS = MAX(36.0E0-FNU,0.0E0) NS = INT(ANS) FNI = FNI + NS DFN = FNI + FNF FN = DFN IS = KT KM = N - 1 + NS IF (KM.GT.0) IS = 3 GO TO 120 90 FN = FNU FNP1 = FN + 1.0E0 XO2L = LOG(XO2) IS = KT IF (X.LE.0.5E0) GO TO 230 NS = 0 100 FNI = FNI + NS DFN = FNI + FNF FN = DFN FNP1 = FN + 1.0E0 IS = KT IF (N-1+NS.GT.0) IS = 3 GO TO 230 110 XO2L = LOG(XO2) NS = INT(SXO2-FNU) GO TO 100 120 CONTINUE C C OVERFLOW TEST ON UNIFORM ASYMPTOTIC EXPANSION C IF (KODE.EQ.2) GO TO 130 IF (ALPHA.LT.1.0E0) GO TO 150 Z = X/ALPHA RA = SQRT(1.0E0+Z*Z) GLN = LOG((1.0E0+RA)/Z) T = RA*(1.0E0-ETX) + ETX/(Z+RA) ARG = ALPHA*(T-GLN) IF (ARG.GT.ELIM) GO TO 610 IF (KM.EQ.0) GO TO 140 130 CONTINUE C C UNDERFLOW TEST ON UNIFORM ASYMPTOTIC EXPANSION C Z = X/FN RA = SQRT(1.0E0+Z*Z) GLN = LOG((1.0E0+RA)/Z) T = RA*(1.0E0-ETX) + ETX/(Z+RA) ARG = FN*(T-GLN) 140 IF (ARG.LT.(-ELIM)) GO TO 280 GO TO 190 150 IF (X.GT.ELIM) GO TO 610 GO TO 130 C C UNIFORM ASYMPTOTIC EXPANSION FOR NU TO INFINITY C 160 IF (KM.NE.0) GO TO 170 Y(1) = TEMP(3) RETURN 170 TEMP(1) = TEMP(3) IN = NS KT = 1 I1 = 0 180 CONTINUE IS = 2 FNI = FNI - 1.0E0 DFN = FNI + FNF FN = DFN IF(I1.EQ.2) GO TO 350 Z = X/FN RA = SQRT(1.0E0+Z*Z) GLN = LOG((1.0E0+RA)/Z) T = RA*(1.0E0-ETX) + ETX/(Z+RA) ARG = FN*(T-GLN) 190 CONTINUE I1 = ABS(3-IS) I1 = MAX(I1,1) FLGIK = 1.0E0 CALL ASYIK(X,FN,KODE,FLGIK,RA,ARG,I1,TEMP(IS)) GO TO (180, 350, 510), IS C C SERIES FOR (X/2)**2.LE.NU+1 C 230 CONTINUE GLN = REAL(DLNGAM(DBLE(FNP1))) ARG = FN*XO2L - GLN - SX IF (ARG.LT.(-ELIM)) GO TO 300 EARG = EXP(ARG) 240 CONTINUE S = 1.0E0 IF (X.LT.TOL) GO TO 260 AK = 3.0E0 T2 = 1.0E0 T = 1.0E0 S1 = FN DO 250 K=1,17 S2 = T2 + S1 T = T*SXO2/S2 S = S + T IF (ABS(T).LT.TOL) GO TO 260 T2 = T2 + AK AK = AK + 2.0E0 S1 = S1 + FN 250 CONTINUE 260 CONTINUE TEMP(IS) = S*EARG GO TO (270, 350, 500), IS 270 EARG = EARG*FN/XO2 FNI = FNI - 1.0E0 DFN = FNI + FNF FN = DFN IS = 2 GO TO 240 C C SET UNDERFLOW VALUE AND UPDATE PARAMETERS C 280 Y(NN) = 0.0E0 NN = NN - 1 FNI = FNI - 1.0E0 DFN = FNI + FNF FN = DFN IF (NN-1) 340, 290, 130 290 KT = 2 IS = 2 GO TO 130 300 Y(NN) = 0.0E0 NN = NN - 1 FNP1 = FN FNI = FNI - 1.0E0 DFN = FNI + FNF FN = DFN IF (NN-1) 340, 310, 320 310 KT = 2 IS = 2 320 IF (SXO2.LE.FNP1) GO TO 330 GO TO 130 330 ARG = ARG - XO2L + LOG(FNP1) IF (ARG.LT.(-ELIM)) GO TO 300 GO TO 230 340 NZ = N - NN RETURN C C BACKWARD RECURSION SECTION C 350 CONTINUE NZ = N - NN 360 CONTINUE IF(KT.EQ.2) GO TO 420 S1 = TEMP(1) S2 = TEMP(2) TRX = 2.0E0/X DTM = FNI TM = (DTM+FNF)*TRX IF (IN.EQ.0) GO TO 390 C BACKWARD RECUR TO INDEX ALPHA+NN-1 DO 380 I=1,IN S = S2 S2 = TM*S2 + S1 S1 = S DTM = DTM - 1.0E0 TM = (DTM+FNF)*TRX 380 CONTINUE Y(NN) = S1 IF (NN.EQ.1) RETURN Y(NN-1) = S2 IF (NN.EQ.2) RETURN GO TO 400 390 CONTINUE C BACKWARD RECUR FROM INDEX ALPHA+NN-1 TO ALPHA Y(NN) = S1 Y(NN-1) = S2 IF (NN.EQ.2) RETURN 400 K = NN + 1 DO 410 I=3,NN K = K - 1 Y(K-2) = TM*Y(K-1) + Y(K) DTM = DTM - 1.0E0 TM = (DTM+FNF)*TRX 410 CONTINUE RETURN 420 Y(1) = TEMP(2) RETURN C C ASYMPTOTIC EXPANSION FOR X TO INFINITY C 430 CONTINUE EARG = RTTPI/SQRT(X) IF (KODE.EQ.2) GO TO 440 IF (X.GT.ELIM) GO TO 610 EARG = EARG*EXP(X) 440 ETX = 8.0E0*X IS = KT IN = 0 FN = FNU 450 DX = FNI + FNI TM = 0.0E0 IF (FNI.EQ.0.0E0 .AND. ABS(FNF).LT.TOL) GO TO 460 TM = 4.0E0*FNF*(FNI+FNI+FNF) 460 CONTINUE DTM = DX*DX S1 = ETX TRX = DTM - 1.0E0 DX = -(TRX+TM)/ETX T = DX S = 1.0E0 + DX ATOL = TOL*ABS(S) S2 = 1.0E0 AK = 8.0E0 DO 470 K=1,25 S1 = S1 + ETX S2 = S2 + AK DX = DTM - S2 AP = DX + TM T = -T*AP/S1 S = S + T IF (ABS(T).LE.ATOL) GO TO 480 AK = AK + 8.0E0 470 CONTINUE 480 TEMP(IS) = S*EARG IF(IS.EQ.2) GO TO 360 IS = 2 FNI = FNI - 1.0E0 DFN = FNI + FNF FN = DFN GO TO 450 C C BACKWARD RECURSION WITH NORMALIZATION BY C ASYMPTOTIC EXPANSION FOR NU TO INFINITY OR POWER SERIES. C 500 CONTINUE C COMPUTATION OF LAST ORDER FOR SERIES NORMALIZATION AKM = MAX(3.0E0-FN,0.0E0) KM = INT(AKM) TFN = FN + KM TA = (GLN+TFN-0.9189385332E0-0.0833333333E0/TFN)/(TFN+0.5E0) TA = XO2L - TA TB = -(1.0E0-1.0E0/TFN)/TFN AIN = TOLLN/(-TA+SQRT(TA*TA-TOLLN*TB)) + 1.5E0 IN = INT(AIN) IN = IN + KM GO TO 520 510 CONTINUE C COMPUTATION OF LAST ORDER FOR ASYMPTOTIC EXPANSION NORMALIZATION T = 1.0E0/(FN*RA) AIN = TOLLN/(GLN+SQRT(GLN*GLN+T*TOLLN)) + 1.5E0 IN = INT(AIN) IF (IN.GT.INLIM) GO TO 160 520 CONTINUE TRX = 2.0E0/X DTM = FNI + IN TM = (DTM+FNF)*TRX TA = 0.0E0 TB = TOL KK = 1 530 CONTINUE C C BACKWARD RECUR UNINDEXED C DO 540 I=1,IN S = TB TB = TM*TB + TA TA = S DTM = DTM - 1.0E0 TM = (DTM+FNF)*TRX 540 CONTINUE C NORMALIZATION IF (KK.NE.1) GO TO 550 TA = (TA/TB)*TEMP(3) TB = TEMP(3) KK = 2 IN = NS IF (NS.NE.0) GO TO 530 550 Y(NN) = TB NZ = N - NN IF (NN.EQ.1) RETURN TB = TM*TB + TA K = NN - 1 Y(K) = TB IF (NN.EQ.2) RETURN DTM = DTM - 1.0E0 TM = (DTM+FNF)*TRX KM = K - 1 C C BACKWARD RECUR INDEXED C DO 560 I=1,KM Y(K-1) = TM*Y(K) + Y(K+1) DTM = DTM - 1.0E0 TM = (DTM+FNF)*TRX K = K - 1 560 CONTINUE RETURN C C C 570 CONTINUE WRITE(ICOUT,571) 571 FORMAT('***** ERORR FROM BESI, KODE IS NOT 1 OR 2. ***') CALL DPWRST('XXX','BUG ') RETURN 580 CONTINUE WRITE(ICOUT,581) 581 FORMAT('***** ERORR FROM BESI, THE ORDER ALPHA IS NEGATIVE. ***') CALL DPWRST('XXX','BUG ') RETURN 590 CONTINUE WRITE(ICOUT,591) 591 FORMAT('***** ERORR FROM BESI, N IS LESS THAN ONE.. ***') CALL DPWRST('XXX','BUG ') RETURN 600 CONTINUE WRITE(ICOUT,601) 601 FORMAT('***** ERORR FROM BESI, X IS LESS THAN ZERO.. ***') CALL DPWRST('XXX','BUG ') RETURN 610 CONTINUE WRITE(ICOUT,611) 611 FORMAT('**** ERORR FROM BESI, OVERFLOW BECAUSE X IS TOO BIG.. *') CALL DPWRST('XXX','BUG ') RETURN END FUNCTION BESI0 (X) C***BEGIN PROLOGUE BESI0 C***PURPOSE Compute the hyperbolic Bessel function of the first kind C of order zero. C***LIBRARY SLATEC (FNLIB) C***CATEGORY C10B1 C***TYPE SINGLE PRECISION (BESI0-S, DBESI0-D) C***KEYWORDS FIRST KIND, FNLIB, HYPERBOLIC BESSEL FUNCTION, C MODIFIED BESSEL FUNCTION, ORDER ZERO, SPECIAL FUNCTIONS C***AUTHOR Fullerton, W., (LANL) C***DESCRIPTION C C BESI0(X) computes the modified (hyperbolic) Bessel function C of the first kind of order zero and real argument X. C C Series for BI0 on the interval 0. to 9.00000D+00 C with weighted error 2.46E-18 C log weighted error 17.61 C significant figures required 17.90 C decimal places required 18.15 C C***REFERENCES (NONE) C***ROUTINES CALLED BESI0E, CSEVL, INITS, R1MACH, XERMSG C***REVISION HISTORY (YYMMDD) C 770401 DATE WRITTEN C 890531 Changed all specific intrinsics to generic. (WRB) C 890531 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) C 900326 Removed duplicate information from DESCRIPTION section. C (WRB) C***END PROLOGUE BESI0 C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOMC.INC' CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C DIMENSION BI0CS(12) LOGICAL FIRST SAVE BI0CS, NTI0, XSML, XMAX, FIRST DATA BI0CS( 1) / -.0766054725 2839144951E0 / DATA BI0CS( 2) / 1.9273379539 93808270E0 / DATA BI0CS( 3) / .2282644586 920301339E0 / DATA BI0CS( 4) / .0130489146 6707290428E0 / DATA BI0CS( 5) / .0004344270 9008164874E0 / DATA BI0CS( 6) / .0000094226 5768600193E0 / DATA BI0CS( 7) / .0000001434 0062895106E0 / DATA BI0CS( 8) / .0000000016 1384906966E0 / DATA BI0CS( 9) / .0000000000 1396650044E0 / DATA BI0CS(10) / .0000000000 0009579451E0 / DATA BI0CS(11) / .0000000000 0000053339E0 / DATA BI0CS(12) / .0000000000 0000000245E0 / DATA FIRST /.TRUE./ C***FIRST EXECUTABLE STATEMENT BESI0 IF (FIRST) THEN NTI0 = INITS (BI0CS, 12, 0.1*R1MACH(3)) XSML = SQRT (4.5*R1MACH(3)) XMAX = LOG (R1MACH(2)) ENDIF FIRST = .FALSE. C Y = ABS(X) IF (Y.GT.3.0) GO TO 20 C BESI0 = 1.0 IF (Y.GT.XSML) BESI0 = 2.75 + CSEVL (Y*Y/4.5-1.0, BI0CS, NTI0) RETURN C 20 CONTINUE IF (Y.GT.XMAX) THEN WRITE(ICOUT,1) CALL DPWRST('XXX','BUG ') BESI0 = 0.0 RETURN ENDIF 1 FORMAT('***** ERORR FROM BESI0, OVERFLOW BECAUSE THE ', 1 'ABSOLUTE VALUE OF X IS TOO BIG. ****') C BESI0 = EXP(Y) * BESI0E(X) C RETURN END FUNCTION BESI0E (X) C***BEGIN PROLOGUE BESI0E C***PURPOSE Compute the exponentially scaled modified (hyperbolic) C Bessel function of the first kind of order zero. C***LIBRARY SLATEC (FNLIB) C***CATEGORY C10B1 C***TYPE SINGLE PRECISION (BESI0E-S, DBSI0E-D) C***KEYWORDS EXPONENTIALLY SCALED, FIRST KIND, FNLIB, C HYPERBOLIC BESSEL FUNCTION, MODIFIED BESSEL FUNCTION, C ORDER ZERO, SPECIAL FUNCTIONS C***AUTHOR Fullerton, W., (LANL) C***DESCRIPTION C C BESI0E(X) calculates the exponentially scaled modified (hyperbolic) C Bessel function of the first kind of order zero for real argument X; C i.e., EXP(-ABS(X))*I0(X). C C C Series for BI0 on the interval 0. to 9.00000D+00 C with weighted error 2.46E-18 C log weighted error 17.61 C significant figures required 17.90 C decimal places required 18.15 C C C Series for AI0 on the interval 1.25000D-01 to 3.33333D-01 C with weighted error 7.87E-17 C log weighted error 16.10 C significant figures required 14.69 C decimal places required 16.76 C C C Series for AI02 on the interval 0. to 1.25000D-01 C with weighted error 3.79E-17 C log weighted error 16.42 C significant figures required 14.86 C decimal places required 17.09 C C***REFERENCES (NONE) C***ROUTINES CALLED CSEVL, INITS, R1MACH C***REVISION HISTORY (YYMMDD) C 770701 DATE WRITTEN C 890313 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C***END PROLOGUE BESI0E C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOMC.INC' CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C DIMENSION BI0CS(12), AI0CS(21), AI02CS(22) LOGICAL FIRST SAVE BI0CS, AI0CS, AI02CS, NTI0, NTAI0, NTAI02, XSML, FIRST DATA BI0CS( 1) / -.0766054725 2839144951E0 / DATA BI0CS( 2) / 1.9273379539 93808270E0 / DATA BI0CS( 3) / .2282644586 920301339E0 / DATA BI0CS( 4) / .0130489146 6707290428E0 / DATA BI0CS( 5) / .0004344270 9008164874E0 / DATA BI0CS( 6) / .0000094226 5768600193E0 / DATA BI0CS( 7) / .0000001434 0062895106E0 / DATA BI0CS( 8) / .0000000016 1384906966E0 / DATA BI0CS( 9) / .0000000000 1396650044E0 / DATA BI0CS(10) / .0000000000 0009579451E0 / DATA BI0CS(11) / .0000000000 0000053339E0 / DATA BI0CS(12) / .0000000000 0000000245E0 / DATA AI0CS( 1) / .0757599449 4023796E0 / DATA AI0CS( 2) / .0075913808 1082334E0 / DATA AI0CS( 3) / .0004153131 3389237E0 / DATA AI0CS( 4) / .0000107007 6463439E0 / DATA AI0CS( 5) / -.0000079011 7997921E0 / DATA AI0CS( 6) / -.0000007826 1435014E0 / DATA AI0CS( 7) / .0000002783 8499429E0 / DATA AI0CS( 8) / .0000000082 5247260E0 / DATA AI0CS( 9) / -.0000000120 4463945E0 / DATA AI0CS(10) / .0000000015 5964859E0 / DATA AI0CS(11) / .0000000002 2925563E0 / DATA AI0CS(12) / -.0000000001 1916228E0 / DATA AI0CS(13) / .0000000000 1757854E0 / DATA AI0CS(14) / .0000000000 0112822E0 / DATA AI0CS(15) / -.0000000000 0114684E0 / DATA AI0CS(16) / .0000000000 0027155E0 / DATA AI0CS(17) / -.0000000000 0002415E0 / DATA AI0CS(18) / -.0000000000 0000608E0 / DATA AI0CS(19) / .0000000000 0000314E0 / DATA AI0CS(20) / -.0000000000 0000071E0 / DATA AI0CS(21) / .0000000000 0000007E0 / DATA AI02CS( 1) / .0544904110 1410882E0 / DATA AI02CS( 2) / .0033691164 7825569E0 / DATA AI02CS( 3) / .0000688975 8346918E0 / DATA AI02CS( 4) / .0000028913 7052082E0 / DATA AI02CS( 5) / .0000002048 9185893E0 / DATA AI02CS( 6) / .0000000226 6668991E0 / DATA AI02CS( 7) / .0000000033 9623203E0 / DATA AI02CS( 8) / .0000000004 9406022E0 / DATA AI02CS( 9) / .0000000000 1188914E0 / DATA AI02CS(10) / -.0000000000 3149915E0 / DATA AI02CS(11) / -.0000000000 1321580E0 / DATA AI02CS(12) / -.0000000000 0179419E0 / DATA AI02CS(13) / .0000000000 0071801E0 / DATA AI02CS(14) / .0000000000 0038529E0 / DATA AI02CS(15) / .0000000000 0001539E0 / DATA AI02CS(16) / -.0000000000 0004151E0 / DATA AI02CS(17) / -.0000000000 0000954E0 / DATA AI02CS(18) / .0000000000 0000382E0 / DATA AI02CS(19) / .0000000000 0000176E0 / DATA AI02CS(20) / -.0000000000 0000034E0 / DATA AI02CS(21) / -.0000000000 0000027E0 / DATA AI02CS(22) / .0000000000 0000003E0 / DATA FIRST /.TRUE./ C***FIRST EXECUTABLE STATEMENT BESI0E IF (FIRST) THEN NTI0 = INITS (BI0CS, 12, 0.1*R1MACH(3)) NTAI0 = INITS (AI0CS, 21, 0.1*R1MACH(3)) NTAI02 = INITS (AI02CS, 22, 0.1*R1MACH(3)) XSML = SQRT (4.5*R1MACH(3)) ENDIF FIRST = .FALSE. C Y = ABS(X) IF (Y.GT.3.0) GO TO 20 C BESI0E = 1.0 - X IF (Y.GT.XSML) BESI0E = EXP(-Y) * ( 2.75 + 1 CSEVL (Y*Y/4.5-1.0, BI0CS, NTI0) ) RETURN C 20 IF (Y.LE.8.) BESI0E = (.375 + CSEVL ((48./Y-11.)/5., AI0CS, NTAI0) 1 ) / SQRT(Y) IF (Y.GT.8.) BESI0E = (.375 + CSEVL (16./Y-1., AI02CS, NTAI02)) 1 / SQRT(Y) C RETURN END FUNCTION BESI1 (X) C***BEGIN PROLOGUE BESI1 C***PURPOSE Compute the modified (hyperbolic) Bessel function of the C first kind of order one. C***LIBRARY SLATEC (FNLIB) C***CATEGORY C10B1 C***TYPE SINGLE PRECISION (BESI1-S, DBESI1-D) C***KEYWORDS FIRST KIND, FNLIB, HYPERBOLIC BESSEL FUNCTION, C MODIFIED BESSEL FUNCTION, ORDER ONE, SPECIAL FUNCTIONS C***AUTHOR Fullerton, W., (LANL) C***DESCRIPTION C C BESI1(X) calculates the modified (hyperbolic) Bessel function C of the first kind of order one for real argument X. C C Series for BI1 on the interval 0. to 9.00000D+00 C with weighted error 2.40E-17 C log weighted error 16.62 C significant figures required 16.23 C decimal places required 17.14 C C***REFERENCES (NONE) C***ROUTINES CALLED BESI1E, CSEVL, INITS, R1MACH, XERMSG C***REVISION HISTORY (YYMMDD) C 770401 DATE WRITTEN C 890531 Changed all specific intrinsics to generic. (WRB) C 890531 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) C 900326 Removed duplicate information from DESCRIPTION section. C (WRB) C***END PROLOGUE BESI1 C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOMC.INC' CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C DIMENSION BI1CS(11) LOGICAL FIRST SAVE BI1CS, NTI1, XMIN, XSML, XMAX, FIRST DATA BI1CS( 1) / -.0019717132 61099859E0 / DATA BI1CS( 2) / .4073488766 7546481E0 / DATA BI1CS( 3) / .0348389942 99959456E0 / DATA BI1CS( 4) / .0015453945 56300123E0 / DATA BI1CS( 5) / .0000418885 21098377E0 / DATA BI1CS( 6) / .0000007649 02676483E0 / DATA BI1CS( 7) / .0000000100 42493924E0 / DATA BI1CS( 8) / .0000000000 99322077E0 / DATA BI1CS( 9) / .0000000000 00766380E0 / DATA BI1CS(10) / .0000000000 00004741E0 / DATA BI1CS(11) / .0000000000 00000024E0 / DATA FIRST /.TRUE./ C***FIRST EXECUTABLE STATEMENT BESI1 IF (FIRST) THEN NTI1 = INITS (BI1CS, 11, 0.1*R1MACH(3)) XMIN = 2.0*R1MACH(1) XSML = SQRT (4.5*R1MACH(3)) XMAX = LOG (R1MACH(2)) ENDIF FIRST = .FALSE. C Y = ABS(X) IF (Y.GT.3.0) GO TO 20 C BESI1 = 0.0 IF (Y.EQ.0.0) RETURN C IF (Y .LE. XMIN) THEN WRITE(ICOUT,2) CALL DPWRST('XXX','BUG ') ENDIF 2 FORMAT('***** WARNING FROM BESI1, UNDERFLOW BECAUSE THE ', 1 'ABSOLUTE VALUE OF X IS SO SMALL. ****') IF (Y.GT.XMIN)BESI1 = 0.5*X IF (Y.GT.XSML)BESI1 = X * (.875 + CSEVL(Y*Y/4.5-1., BI1CS, NTI1)) RETURN C 20 CONTINUE IF (Y.GT.XMAX) THEN WRITE(ICOUT,1) CALL DPWRST('XXX','BUG ') BESI1 = 0.0 RETURN ENDIF 1 FORMAT('***** ERORR FROM BESI1, OVERFLOW BECAUSE THE ', 1 'ABSOLUTE VALUE OF X IS TOO BIG. ****') C BESI1 = EXP(Y) * BESI1E(X) C RETURN END FUNCTION BESI1E (X) C***BEGIN PROLOGUE BESI1E C***PURPOSE Compute the exponentially scaled modified (hyperbolic) C Bessel function of the first kind of order one. C***LIBRARY SLATEC (FNLIB) C***CATEGORY C10B1 C***TYPE SINGLE PRECISION (BESI1E-S, DBSI1E-D) C***KEYWORDS EXPONENTIALLY SCALED, FIRST KIND, FNLIB, C HYPERBOLIC BESSEL FUNCTION, MODIFIED BESSEL FUNCTION, C ORDER ONE, SPECIAL FUNCTIONS C***AUTHOR Fullerton, W., (LANL) C***DESCRIPTION C C BESI1E(X) calculates the exponentially scaled modified (hyperbolic) C Bessel function of the first kind of order one for real argument X; C i.e., EXP(-ABS(X))*I1(X). C C Series for BI1 on the interval 0. to 9.00000D+00 C with weighted error 2.40E-17 C log weighted error 16.62 C significant figures required 16.23 C decimal places required 17.14 C C Series for AI1 on the interval 1.25000D-01 to 3.33333D-01 C with weighted error 6.98E-17 C log weighted error 16.16 C significant figures required 14.53 C decimal places required 16.82 C C Series for AI12 on the interval 0. to 1.25000D-01 C with weighted error 3.55E-17 C log weighted error 16.45 C significant figures required 14.69 C decimal places required 17.12 C C***REFERENCES (NONE) C***ROUTINES CALLED CSEVL, INITS, R1MACH, XERMSG C***REVISION HISTORY (YYMMDD) C 770401 DATE WRITTEN C 890210 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) C 900326 Removed duplicate information from DESCRIPTION section. C (WRB) C 920618 Removed space from variable names. (RWC, WRB) C***END PROLOGUE BESI1E C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOMC.INC' CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C DIMENSION BI1CS(11), AI1CS(21), AI12CS(22) LOGICAL FIRST SAVE BI1CS, AI1CS, AI12CS, NTI1, NTAI1, NTAI12, XMIN, XSML, FIRST DATA BI1CS( 1) / -.0019717132 61099859E0 / DATA BI1CS( 2) / .4073488766 7546481E0 / DATA BI1CS( 3) / .0348389942 99959456E0 / DATA BI1CS( 4) / .0015453945 56300123E0 / DATA BI1CS( 5) / .0000418885 21098377E0 / DATA BI1CS( 6) / .0000007649 02676483E0 / DATA BI1CS( 7) / .0000000100 42493924E0 / DATA BI1CS( 8) / .0000000000 99322077E0 / DATA BI1CS( 9) / .0000000000 00766380E0 / DATA BI1CS(10) / .0000000000 00004741E0 / DATA BI1CS(11) / .0000000000 00000024E0 / DATA AI1CS( 1) / -.0284674418 1881479E0 / DATA AI1CS( 2) / -.0192295323 1443221E0 / DATA AI1CS( 3) / -.0006115185 8579437E0 / DATA AI1CS( 4) / -.0000206997 1253350E0 / DATA AI1CS( 5) / .0000085856 1914581E0 / DATA AI1CS( 6) / .0000010494 9824671E0 / DATA AI1CS( 7) / -.0000002918 3389184E0 / DATA AI1CS( 8) / -.0000000155 9378146E0 / DATA AI1CS( 9) / .0000000131 8012367E0 / DATA AI1CS(10) / -.0000000014 4842341E0 / DATA AI1CS(11) / -.0000000002 9085122E0 / DATA AI1CS(12) / .0000000001 2663889E0 / DATA AI1CS(13) / -.0000000000 1664947E0 / DATA AI1CS(14) / -.0000000000 0166665E0 / DATA AI1CS(15) / .0000000000 0124260E0 / DATA AI1CS(16) / -.0000000000 0027315E0 / DATA AI1CS(17) / .0000000000 0002023E0 / DATA AI1CS(18) / .0000000000 0000730E0 / DATA AI1CS(19) / -.0000000000 0000333E0 / DATA AI1CS(20) / .0000000000 0000071E0 / DATA AI1CS(21) / -.0000000000 0000006E0 / DATA AI12CS( 1) / .0285762350 1828014E0 / DATA AI12CS( 2) / -.0097610974 9136147E0 / DATA AI12CS( 3) / -.0001105889 3876263E0 / DATA AI12CS( 4) / -.0000038825 6480887E0 / DATA AI12CS( 5) / -.0000002512 2362377E0 / DATA AI12CS( 6) / -.0000000263 1468847E0 / DATA AI12CS( 7) / -.0000000038 3538039E0 / DATA AI12CS( 8) / -.0000000005 5897433E0 / DATA AI12CS( 9) / -.0000000000 1897495E0 / DATA AI12CS(10) / .0000000000 3252602E0 / DATA AI12CS(11) / .0000000000 1412580E0 / DATA AI12CS(12) / .0000000000 0203564E0 / DATA AI12CS(13) / -.0000000000 0071985E0 / DATA AI12CS(14) / -.0000000000 0040836E0 / DATA AI12CS(15) / -.0000000000 0002101E0 / DATA AI12CS(16) / .0000000000 0004273E0 / DATA AI12CS(17) / .0000000000 0001041E0 / DATA AI12CS(18) / -.0000000000 0000382E0 / DATA AI12CS(19) / -.0000000000 0000186E0 / DATA AI12CS(20) / .0000000000 0000033E0 / DATA AI12CS(21) / .0000000000 0000028E0 / DATA AI12CS(22) / -.0000000000 0000003E0 / DATA FIRST /.TRUE./ C***FIRST EXECUTABLE STATEMENT BESI1E IF (FIRST) THEN NTI1 = INITS (BI1CS, 11, 0.1*R1MACH(3)) NTAI1 = INITS (AI1CS, 21, 0.1*R1MACH(3)) NTAI12 = INITS (AI12CS, 22, 0.1*R1MACH(3)) C XMIN = 2.0*R1MACH(1) XSML = SQRT (4.5*R1MACH(3)) ENDIF FIRST = .FALSE. C Y = ABS(X) IF (Y.GT.3.0) GO TO 20 C BESI1E = 0.0 IF (Y.EQ.0.0) RETURN C IF (Y .LE. XMIN) THEN WRITE(ICOUT,1) CALL DPWRST('XXX','BUG ') ENDIF 1 FORMAT('***** WARNING FROM BESI1E, UNDERFLOW BECAUSE THE ', 1 'ABSOLUTE VALUE OF X IS SO SMALL. ****') IF (Y.GT.XMIN) BESI1E = 0.5*X IF (Y.GT.XSML) BESI1E = X * (.875 + CSEVL(Y*Y/4.5-1., BI1CS,NTI1)) BESI1E = EXP(-Y) * BESI1E RETURN C 20 IF (Y.LE.8.) BESI1E = (.375 + CSEVL ((48./Y-11.)/5., AI1CS, NTAI1) 1 ) / SQRT(Y) IF (Y.GT.8.) BESI1E = (.375 + CSEVL (16./Y-1.0, AI12CS, NTAI12)) 1 / SQRT(Y) BESI1E = SIGN (BESI1E, X) C RETURN END SUBROUTINE BESJ (X, ALPHA, N, Y, NZ) C***BEGIN PROLOGUE BESJ C***PURPOSE Compute an N member sequence of J Bessel functions C J/SUB(ALPHA+K-1)/(X), K=1,...,N for non-negative ALPHA C and X. C***LIBRARY SLATEC C***CATEGORY C10A3 C***TYPE SINGLE PRECISION (BESJ-S, DBESJ-D) C***KEYWORDS J BESSEL FUNCTION, SPECIAL FUNCTIONS C***AUTHOR Amos, D. E., (SNLA) C Daniel, S. L., (SNLA) C Weston, M. K., (SNLA) C***DESCRIPTION C C Abstract C BESJ computes an N member sequence of J Bessel functions C J/sub(ALPHA+K-1)/(X), K=1,...,N for non-negative ALPHA and X. C A combination of the power series, the asymptotic expansion C for X to infinity and the uniform asymptotic expansion for C NU to infinity are applied over subdivisions of the (NU,X) C plane. For values of (NU,X) not covered by one of these C formulae, the order is incremented or decremented by integer C values into a region where one of the formulae apply. Backward C recursion is applied to reduce orders by integer values except C where the entire sequence lies in the oscillatory region. In C this case forward recursion is stable and values from the C asymptotic expansion for X to infinity start the recursion C when it is efficient to do so. Leading terms of the series C and uniform expansion are tested for underflow. If a sequence C is requested and the last member would underflow, the result C is set to zero and the next lower order tried, etc., until a C member comes on scale or all members are set to zero. C Overflow cannot occur. C C Description of Arguments C C Input C X - X .GE. 0.0E0 C ALPHA - order of first member of the sequence, C ALPHA .GE. 0.0E0 C N - number of members in the sequence, N .GE. 1 C C Output C Y - a vector whose first N components contain C values for J/sub(ALPHA+K-1)/(X), K=1,...,N C NZ - number of components of Y set to zero due to C underflow, C NZ=0 , normal return, computation completed C NZ .NE. 0, last NZ components of Y set to zero, C Y(K)=0.0E0, K=N-NZ+1,...,N. C C Error Conditions C Improper input arguments - a fatal error C Underflow - a non-fatal error (NZ .NE. 0) C C***REFERENCES D. E. Amos, S. L. Daniel and M. K. Weston, CDC 6600 C subroutines IBESS and JBESS for Bessel functions C I(NU,X) and J(NU,X), X .GE. 0, NU .GE. 0, ACM C Transactions on Mathematical Software 3, (1977), C pp. 76-92. C F. W. J. Olver, Tables of Bessel Functions of Moderate C or Large Orders, NPL Mathematical Tables 6, Her C Majesty's Stationery Office, London, 1962. C***ROUTINES CALLED ALNGAM, ASYJY, I1MACH, JAIRY, R1MACH, XERMSG C***REVISION HISTORY (YYMMDD) C 750101 DATE WRITTEN C 890531 Changed all specific intrinsics to generic. (WRB) C 890531 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) C 900326 Removed duplicate information from DESCRIPTION section. C (WRB) C 920501 Reformatted the REFERENCES section. (WRB) C***END PROLOGUE BESJ C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOMC.INC' CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C EXTERNAL JAIRY INTEGER I,IALP,IDALP,IFLW,IN,INLIM,IS,I1,I2,K,KK,KM,KT,N,NN, 1 NS,NZ REAL AK,AKM,ALPHA,ANS,AP,ARG,COEF,DALPHA,DFN,DTM,EARG, 1 ELIM1,ETX,FIDAL,FLGJY,FN,FNF,FNI,FNP1,FNU,FNULIM, 2 GLN,PDF,PIDT,PP,RDEN,RELB,RTTP,RTWO,RTX,RZDEN, 3 S,SA,SB,SXO2,S1,S2,T,TA,TAU,TB,TEMP,TFN,TM,TOL, 4 TOLLN,TRX,TX,T1,T2,WK,X,XO2,XO2L,Y,RTOL,SLIM SAVE RTWO, PDF, RTTP, PIDT, PP, INLIM, FNULIM DOUBLE PRECISION DLNGAM DIMENSION Y(*), TEMP(3), FNULIM(2), PP(4), WK(7) DATA RTWO,PDF,RTTP,PIDT / 1.34839972492648E+00, 1 7.85398163397448E-01, 7.97884560802865E-01, 1.57079632679490E+00/ DATA PP(1), PP(2), PP(3), PP(4) / 8.72909153935547E+00, 1 2.65693932265030E-01, 1.24578576865586E-01, 7.70133747430388E-04/ DATA INLIM / 150 / DATA FNULIM(1), FNULIM(2) / 100.0E0, 60.0E0 / C***FIRST EXECUTABLE STATEMENT BESJ NZ = 0 KT = 1 NS=0 C I1MACH(14) REPLACES I1MACH(11) IN A DOUBLE PRECISION CODE C I1MACH(15) REPLACES I1MACH(12) IN A DOUBLE PRECISION CODE TA = R1MACH(3) TOL = MAX(TA,1.0E-15) I1 = I1MACH(11) + 1 I2 = I1MACH(12) TB = R1MACH(5) ELIM1 = -2.303E0*(I2*TB+3.0E0) RTOL=1.0E0/TOL SLIM=R1MACH(1)*1.0E+3*RTOL C TOLLN = -LN(TOL) TOLLN = 2.303E0*TB*I1 TOLLN = MIN(TOLLN,34.5388E0) IF (N-1) 720, 10, 20 10 KT = 2 20 NN = N IF (X) 730, 30, 80 30 IF (ALPHA) 710, 40, 50 40 Y(1) = 1.0E0 IF (N.EQ.1) RETURN I1 = 2 GO TO 60 50 I1 = 1 60 DO 70 I=I1,N Y(I) = 0.0E0 70 CONTINUE RETURN 80 CONTINUE IF (ALPHA.LT.0.0E0) GO TO 710 C IALP = INT(ALPHA) FNI = IALP + N - 1 FNF = ALPHA - IALP DFN = FNI + FNF FNU = DFN XO2 = X*0.5E0 SXO2 = XO2*XO2 C C DECISION TREE FOR REGION WHERE SERIES, ASYMPTOTIC EXPANSION FOR X C TO INFINITY AND ASYMPTOTIC EXPANSION FOR NU TO INFINITY ARE C APPLIED. C IF (SXO2.LE.(FNU+1.0E0)) GO TO 90 TA = MAX(20.0E0,FNU) IF (X.GT.TA) GO TO 120 IF (X.GT.12.0E0) GO TO 110 XO2L = LOG(XO2) NS = INT(SXO2-FNU) + 1 GO TO 100 90 FN = FNU FNP1 = FN + 1.0E0 XO2L = LOG(XO2) IS = KT IF (X.LE.0.50E0) GO TO 330 NS = 0 100 FNI = FNI + NS DFN = FNI + FNF FN = DFN FNP1 = FN + 1.0E0 IS = KT IF (N-1+NS.GT.0) IS = 3 GO TO 330 110 ANS = MAX(36.0E0-FNU,0.0E0) NS = INT(ANS) FNI = FNI + NS DFN = FNI + FNF FN = DFN IS = KT IF (N-1+NS.GT.0) IS = 3 GO TO 130 120 CONTINUE RTX = SQRT(X) TAU = RTWO*RTX TA = TAU + FNULIM(KT) IF (FNU.LE.TA) GO TO 480 FN = FNU IS = KT C C UNIFORM ASYMPTOTIC EXPANSION FOR NU TO INFINITY C 130 CONTINUE I1 = ABS(3-IS) I1 = MAX(I1,1) FLGJY = 1.0E0 CALL ASYJY(JAIRY,X,FN,FLGJY,I1,TEMP(IS),WK,IFLW) IF(IFLW.NE.0) GO TO 380 GO TO (320, 450, 620), IS 310 TEMP(1) = TEMP(3) KT = 1 320 IS = 2 FNI = FNI - 1.0E0 DFN = FNI + FNF FN = DFN IF(I1.EQ.2) GO TO 450 GO TO 130 C C SERIES FOR (X/2)**2.LE.NU+1 C 330 CONTINUE GLN = REAL(DLNGAM(DBLE(FNP1))) ARG = FN*XO2L - GLN IF (ARG.LT.(-ELIM1)) GO TO 400 EARG = EXP(ARG) 340 CONTINUE S = 1.0E0 IF (X.LT.TOL) GO TO 360 AK = 3.0E0 T2 = 1.0E0 T = 1.0E0 S1 = FN DO 350 K=1,17 S2 = T2 + S1 T = -T*SXO2/S2 S = S + T IF (ABS(T).LT.TOL) GO TO 360 T2 = T2 + AK AK = AK + 2.0E0 S1 = S1 + FN 350 CONTINUE 360 CONTINUE TEMP(IS) = S*EARG GO TO (370, 450, 610), IS 370 EARG = EARG*FN/XO2 FNI = FNI - 1.0E0 DFN = FNI + FNF FN = DFN IS = 2 GO TO 340 C C SET UNDERFLOW VALUE AND UPDATE PARAMETERS C UNDERFLOW CAN ONLY OCCUR FOR NS=0 SINCE THE ORDER MUST BE C LARGER THAN 36. THEREFORE, NS NEED NOT BE CONSIDERED. C 380 Y(NN) = 0.0E0 NN = NN - 1 FNI = FNI - 1.0E0 DFN = FNI + FNF FN = DFN IF (NN-1) 440, 390, 130 390 KT = 2 IS = 2 GO TO 130 400 Y(NN) = 0.0E0 NN = NN - 1 FNP1 = FN FNI = FNI - 1.0E0 DFN = FNI + FNF FN = DFN IF (NN-1) 440, 410, 420 410 KT = 2 IS = 2 420 IF (SXO2.LE.FNP1) GO TO 430 GO TO 130 430 ARG = ARG - XO2L + LOG(FNP1) IF (ARG.LT.(-ELIM1)) GO TO 400 GO TO 330 440 NZ = N - NN RETURN C C BACKWARD RECURSION SECTION C 450 CONTINUE IF(NS.NE.0) GO TO 451 NZ = N - NN IF (KT.EQ.2) GO TO 470 C BACKWARD RECUR FROM INDEX ALPHA+NN-1 TO ALPHA Y(NN) = TEMP(1) Y(NN-1) = TEMP(2) IF (NN.EQ.2) RETURN 451 CONTINUE TRX = 2.0E0/X DTM = FNI TM = (DTM+FNF)*TRX AK=1.0E0 TA=TEMP(1) TB=TEMP(2) IF(ABS(TA).GT.SLIM) GO TO 455 TA=TA*RTOL TB=TB*RTOL AK=TOL 455 CONTINUE KK=2 IN=NS-1 IF(IN.EQ.0) GO TO 690 IF(NS.NE.0) GO TO 670 K=NN-2 DO 460 I=3,NN S=TB TB=TM*TB-TA TA=S Y(K)=TB*AK K=K-1 DTM = DTM - 1.0E0 TM = (DTM+FNF)*TRX 460 CONTINUE RETURN 470 Y(1) = TEMP(2) RETURN C C ASYMPTOTIC EXPANSION FOR X TO INFINITY WITH FORWARD RECURSION IN C OSCILLATORY REGION X.GT.MAX(20, NU), PROVIDED THE LAST MEMBER C OF THE SEQUENCE IS ALSO IN THE REGION. C 480 CONTINUE IN = INT(ALPHA-TAU+2.0E0) IF (IN.LE.0) GO TO 490 IDALP = IALP - IN - 1 KT = 1 GO TO 500 490 CONTINUE IDALP = IALP IN = 0 500 IS = KT FIDAL = IDALP DALPHA = FIDAL + FNF ARG = X - PIDT*DALPHA - PDF SA = SIN(ARG) SB = COS(ARG) COEF = RTTP/RTX ETX = 8.0E0*X 510 CONTINUE DTM = FIDAL + FIDAL DTM = DTM*DTM TM = 0.0E0 IF (FIDAL.EQ.0.0E0 .AND. ABS(FNF).LT.TOL) GO TO 520 TM = 4.0E0*FNF*(FIDAL+FIDAL+FNF) 520 CONTINUE TRX = DTM - 1.0E0 T2 = (TRX+TM)/ETX S2 = T2 RELB = TOL*ABS(T2) T1 = ETX S1 = 1.0E0 FN = 1.0E0 AK = 8.0E0 DO 530 K=1,13 T1 = T1 + ETX FN = FN + AK TRX = DTM - FN AP = TRX + TM T2 = -T2*AP/T1 S1 = S1 + T2 T1 = T1 + ETX AK = AK + 8.0E0 FN = FN + AK TRX = DTM - FN AP = TRX + TM T2 = T2*AP/T1 S2 = S2 + T2 IF (ABS(T2).LE.RELB) GO TO 540 AK = AK + 8.0E0 530 CONTINUE 540 TEMP(IS) = COEF*(S1*SB-S2*SA) IF(IS.EQ.2) GO TO 560 FIDAL = FIDAL + 1.0E0 DALPHA = FIDAL + FNF IS = 2 TB = SA SA = -SB SB = TB GO TO 510 C C FORWARD RECURSION SECTION C 560 IF (KT.EQ.2) GO TO 470 S1 = TEMP(1) S2 = TEMP(2) TX = 2.0E0/X TM = DALPHA*TX IF (IN.EQ.0) GO TO 580 C C FORWARD RECUR TO INDEX ALPHA C DO 570 I=1,IN S = S2 S2 = TM*S2 - S1 TM = TM + TX S1 = S 570 CONTINUE IF (NN.EQ.1) GO TO 600 S = S2 S2 = TM*S2 - S1 TM = TM + TX S1 = S 580 CONTINUE C C FORWARD RECUR FROM INDEX ALPHA TO ALPHA+N-1 C Y(1) = S1 Y(2) = S2 IF (NN.EQ.2) RETURN DO 590 I=3,NN Y(I) = TM*Y(I-1) - Y(I-2) TM = TM + TX 590 CONTINUE RETURN 600 Y(1) = S2 RETURN C C BACKWARD RECURSION WITH NORMALIZATION BY C ASYMPTOTIC EXPANSION FOR NU TO INFINITY OR POWER SERIES. C 610 CONTINUE C COMPUTATION OF LAST ORDER FOR SERIES NORMALIZATION AKM = MAX(3.0E0-FN,0.0E0) KM = INT(AKM) TFN = FN + KM TA = (GLN+TFN-0.9189385332E0-0.0833333333E0/TFN)/(TFN+0.5E0) TA = XO2L - TA TB = -(1.0E0-1.5E0/TFN)/TFN AKM = TOLLN/(-TA+SQRT(TA*TA-TOLLN*TB)) + 1.5E0 IN = KM + INT(AKM) GO TO 660 620 CONTINUE C COMPUTATION OF LAST ORDER FOR ASYMPTOTIC EXPANSION NORMALIZATION GLN = WK(3) + WK(2) IF (WK(6).GT.30.0E0) GO TO 640 RDEN = (PP(4)*WK(6)+PP(3))*WK(6) + 1.0E0 RZDEN = PP(1) + PP(2)*WK(6) TA = RZDEN/RDEN IF (WK(1).LT.0.10E0) GO TO 630 TB = GLN/WK(5) GO TO 650 630 TB=(1.259921049E0+(0.1679894730E0+0.0887944358E0*WK(1))*WK(1)) 1 /WK(7) GO TO 650 640 CONTINUE TA = 0.5E0*TOLLN/WK(4) TA=((0.0493827160E0*TA-0.1111111111E0)*TA+0.6666666667E0)*TA*WK(6) IF (WK(1).LT.0.10E0) GO TO 630 TB = GLN/WK(5) 650 IN = INT(TA/TB+1.5E0) IF (IN.GT.INLIM) GO TO 310 660 CONTINUE DTM = FNI + IN TRX = 2.0E0/X TM = (DTM+FNF)*TRX TA = 0.0E0 TB = TOL KK = 1 AK=1.0E0 670 CONTINUE C C BACKWARD RECUR UNINDEXED AND SCALE WHEN MAGNITUDES ARE CLOSE TO C UNDERFLOW LIMITS (LESS THAN SLIM=R1MACH(1)*1.0E+3/TOL) C DO 680 I=1,IN S = TB TB = TM*TB - TA TA = S DTM = DTM - 1.0E0 TM = (DTM+FNF)*TRX 680 CONTINUE C NORMALIZATION IF (KK.NE.1) GO TO 690 S=TEMP(3) SA=TA/TB TA=S TB=S IF(ABS(S).GT.SLIM) GO TO 685 TA=TA*RTOL TB=TB*RTOL AK=TOL 685 CONTINUE TA=TA*SA KK = 2 IN = NS IF (NS.NE.0) GO TO 670 690 Y(NN) = TB*AK NZ = N - NN IF (NN.EQ.1) RETURN K = NN - 1 S=TB TB = TM*TB - TA TA=S Y(K)=TB*AK IF (NN.EQ.2) RETURN DTM = DTM - 1.0E0 TM = (DTM+FNF)*TRX K=NN-2 C C BACKWARD RECUR INDEXED C DO 700 I=3,NN S=TB TB = TM*TB - TA TA=S Y(K)=TB*AK DTM = DTM - 1.0E0 TM = (DTM+FNF)*TRX K = K - 1 700 CONTINUE RETURN C C C 710 CONTINUE WRITE(ICOUT,711) 711 FORMAT('***** ERORR FROM BESJ, THE ORDER ALPHA IS NEGATIVE. ***') CALL DPWRST('XXX','BUG ') RETURN 720 CONTINUE WRITE(ICOUT,721) 721 FORMAT('***** ERORR FROM BESJ, N IS LESS THAN ONE.. ***') CALL DPWRST('XXX','BUG ') RETURN 730 CONTINUE WRITE(ICOUT,731) 731 FORMAT('***** ERORR FROM BESJ, X IS LESS THAN ZERO.. ***') CALL DPWRST('XXX','BUG ') RETURN END FUNCTION BESJ0(X) C***BEGIN PROLOGUE BESJ0 C***DATE WRITTEN 770401 (YYMMDD) C***REVISION DATE 820801 (YYMMDD) C***CATEGORY NO. C10A1 C***KEYWORDS BESSEL FUNCTION,FIRST KIND,ORDER ZERO,SPECIAL FUNCTION C***AUTHOR FULLERTON, W., (LANL) C***PURPOSE Computes the Bessel function of the first kind of order C zero C***DESCRIPTION C C BESJ0(X) calculates the Bessel function of the first kind of C order zero for real argument X. C C Series for BJ0 on the interval 0. to 1.60000D+01 C with weighted error 7.47E-18 C log weighted error 17.13 C significant figures required 16.98 C decimal places required 17.68 C C Series for BM0 on the interval 0. to 6.25000D-02 C with weighted error 4.98E-17 C log weighted error 16.30 C significant figures required 14.97 C decimal places required 16.96 C C Series for BTH0 on the interval 0. to 6.25000D-02 C with weighted error 3.67E-17 C log weighted error 16.44 C significant figures required 15.53 C decimal places required 17.13 C***REFERENCES (NONE) C***ROUTINES CALLED CSEVL,INITS,R1MACH,XERROR C***END PROLOGUE BESJ0 C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOMC.INC' CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C DIMENSION BJ0CS(13), BM0CS(21), BTH0CS(24) DATA BJ0 CS( 1) / .1002541619 68939137E0 / DATA BJ0 CS( 2) / -.6652230077 64405132E0 / DATA BJ0 CS( 3) / .2489837034 98281314E0 / DATA BJ0 CS( 4) / -.0332527231 700357697E0 / DATA BJ0 CS( 5) / .0023114179 304694015E0 / DATA BJ0 CS( 6) / -.0000991127 741995080E0 / DATA BJ0 CS( 7) / .0000028916 708643998E0 / DATA BJ0 CS( 8) / -.0000000612 108586630E0 / DATA BJ0 CS( 9) / .0000000009 838650793E0 / DATA BJ0 CS(10) / -.0000000000 124235515E0 / DATA BJ0 CS(11) / .0000000000 001265433E0 / DATA BJ0 CS(12) / -.0000000000 000010619E0 / DATA BJ0 CS(13) / .0000000000 000000074E0 / DATA BM0 CS( 1) / .0928496163 7381644E0 / DATA BM0 CS( 2) / -.0014298770 7403484E0 / DATA BM0 CS( 3) / .0000283057 9271257E0 / DATA BM0 CS( 4) / -.0000014330 0611424E0 / DATA BM0 CS( 5) / .0000001202 8628046E0 / DATA BM0 CS( 6) / -.0000000139 7113013E0 / DATA BM0 CS( 7) / .0000000020 4076188E0 / DATA BM0 CS( 8) / -.0000000003 5399669E0 / DATA BM0 CS( 9) / .0000000000 7024759E0 / DATA BM0 CS(10) / -.0000000000 1554107E0 / DATA BM0 CS(11) / .0000000000 0376226E0 / DATA BM0 CS(12) / -.0000000000 0098282E0 / DATA BM0 CS(13) / .0000000000 0027408E0 / DATA BM0 CS(14) / -.0000000000 0008091E0 / DATA BM0 CS(15) / .0000000000 0002511E0 / DATA BM0 CS(16) / -.0000000000 0000814E0 / DATA BM0 CS(17) / .0000000000 0000275E0 / DATA BM0 CS(18) / -.0000000000 0000096E0 / DATA BM0 CS(19) / .0000000000 0000034E0 / DATA BM0 CS(20) / -.0000000000 0000012E0 / DATA BM0 CS(21) / .0000000000 0000004E0 / DATA BTH0CS( 1) / -.2463916377 4300119E0 / DATA BTH0CS( 2) / .0017370983 07508963E0 / DATA BTH0CS( 3) / -.0000621836 33402968E0 / DATA BTH0CS( 4) / .0000043680 50165742E0 / DATA BTH0CS( 5) / -.0000004560 93019869E0 / DATA BTH0CS( 6) / .0000000621 97400101E0 / DATA BTH0CS( 7) / -.0000000103 00442889E0 / DATA BTH0CS( 8) / .0000000019 79526776E0 / DATA BTH0CS( 9) / -.0000000004 28198396E0 / DATA BTH0CS(10) / .0000000001 02035840E0 / DATA BTH0CS(11) / -.0000000000 26363898E0 / DATA BTH0CS(12) / .0000000000 07297935E0 / DATA BTH0CS(13) / -.0000000000 02144188E0 / DATA BTH0CS(14) / .0000000000 00663693E0 / DATA BTH0CS(15) / -.0000000000 00215126E0 / DATA BTH0CS(16) / .0000000000 00072659E0 / DATA BTH0CS(17) / -.0000000000 00025465E0 / DATA BTH0CS(18) / .0000000000 00009229E0 / DATA BTH0CS(19) / -.0000000000 00003448E0 / DATA BTH0CS(20) / .0000000000 00001325E0 / DATA BTH0CS(21) / -.0000000000 00000522E0 / DATA BTH0CS(22) / .0000000000 00000210E0 / DATA BTH0CS(23) / -.0000000000 00000087E0 / DATA BTH0CS(24) / .0000000000 00000036E0 / DATA PI4 / 0.7853981633 9744831E0 / DATA NTJ0, NTM0, NTTH0, XSML, XMAX / 3*0, 2*0./ C***FIRST EXECUTABLE STATEMENT BESJ0 IF (NTJ0.NE.0) GO TO 10 NTJ0 = INITS (BJ0CS, 13, 0.1*R1MACH(3)) NTM0 = INITS (BM0CS, 21, 0.1*R1MACH(3)) NTTH0 = INITS (BTH0CS, 24, 0.1*R1MACH(3)) C XSML = SQRT (4.0*R1MACH(3)) XMAX = 1.0/R1MACH(4) C 10 Y = ABS(X) IF (Y.GT.4.0) GO TO 20 C BESJ0 = 1.0 IF (Y.GT.XSML) BESJ0 = CSEVL (.125*Y*Y-1., BJ0CS, NTJ0) RETURN C 20 CONTINUE IF (Y.GT.XMAX) THEN WRITE(ICOUT,1) CALL DPWRST('XXX','BUG ') BESJ0 = 0.0 RETURN ENDIF 1 FORMAT('***** ERORR FROM BESJ0, NO PRECISION BECAUSE THE ', 1 'ABSOLUTE VALUE OF X IS TOO BIG. ****') C Z = 32.0/Y**2 - 1.0 AMPL = (0.75 + CSEVL (Z, BM0CS, NTM0)) / SQRT(Y) THETA = Y - PI4 + CSEVL (Z, BTH0CS, NTTH0) / Y BESJ0 = AMPL * COS (THETA) C RETURN END FUNCTION BESJ1(X) C***BEGIN PROLOGUE BESJ1 C***DATE WRITTEN 780601 (YYMMDD) C***REVISION DATE 820801 (YYMMDD) C***CATEGORY NO. C10A1 C***KEYWORDS BESSEL FUNCTION,FIRST KIND,ORDER ONE,SPECIAL FUNCTION C***AUTHOR FULLERTON, W., (LANL) C***PURPOSE Computes the Bessel function of the first kind of order one C***DESCRIPTION C C BESJ1(X) calculates the Bessel function of the first kind of C order one for real argument X. C C Series for BJ1 on the interval 0. to 1.60000D+01 C with weighted error 4.48E-17 C log weighted error 16.35 C significant figures required 15.77 C decimal places required 16.89 C C Series for BM1 on the interval 0. to 6.25000D-02 C with weighted error 5.61E-17 C log weighted error 16.25 C significant figures required 14.97 C decimal places required 16.91 C C Series for BTH1 on the interval 0. to 6.25000D-02 C with weighted error 4.10E-17 C log weighted error 16.39 C significant figures required 15.96 C decimal places required 17.08 C***REFERENCES (NONE) C***ROUTINES CALLED CSEVL,INITS,R1MACH,XERROR C***END PROLOGUE BESJ1 C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOMC.INC' CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C DIMENSION BJ1CS(12), BM1CS(21), BTH1CS(24) DATA BJ1 CS( 1) / -.1172614151 3332787E0 / DATA BJ1 CS( 2) / -.2536152183 0790640E0 / DATA BJ1 CS( 3) / .0501270809 84469569E0 / DATA BJ1 CS( 4) / -.0046315148 09625081E0 / DATA BJ1 CS( 5) / .0002479962 29415914E0 / DATA BJ1 CS( 6) / -.0000086789 48686278E0 / DATA BJ1 CS( 7) / .0000002142 93917143E0 / DATA BJ1 CS( 8) / -.0000000039 36093079E0 / DATA BJ1 CS( 9) / .0000000000 55911823E0 / DATA BJ1 CS(10) / -.0000000000 00632761E0 / DATA BJ1 CS(11) / .0000000000 00005840E0 / DATA BJ1 CS(12) / -.0000000000 00000044E0 / DATA BM1 CS( 1) / .1047362510 931285E0 / DATA BM1 CS( 2) / .0044244389 3702345E0 / DATA BM1 CS( 3) / -.0000566163 9504035E0 / DATA BM1 CS( 4) / .0000023134 9417339E0 / DATA BM1 CS( 5) / -.0000001737 7182007E0 / DATA BM1 CS( 6) / .0000000189 3209930E0 / DATA BM1 CS( 7) / -.0000000026 5416023E0 / DATA BM1 CS( 8) / .0000000004 4740209E0 / DATA BM1 CS( 9) / -.0000000000 8691795E0 / DATA BM1 CS(10) / .0000000000 1891492E0 / DATA BM1 CS(11) / -.0000000000 0451884E0 / DATA BM1 CS(12) / .0000000000 0116765E0 / DATA BM1 CS(13) / -.0000000000 0032265E0 / DATA BM1 CS(14) / .0000000000 0009450E0 / DATA BM1 CS(15) / -.0000000000 0002913E0 / DATA BM1 CS(16) / .0000000000 0000939E0 / DATA BM1 CS(17) / -.0000000000 0000315E0 / DATA BM1 CS(18) / .0000000000 0000109E0 / DATA BM1 CS(19) / -.0000000000 0000039E0 / DATA BM1 CS(20) / .0000000000 0000014E0 / DATA BM1 CS(21) / -.0000000000 0000005E0 / DATA BTH1CS( 1) / .7406014102 6313850E0 / DATA BTH1CS( 2) / -.0045717556 59637690E0 / DATA BTH1CS( 3) / .0001198185 10964326E0 / DATA BTH1CS( 4) / -.0000069645 61891648E0 / DATA BTH1CS( 5) / .0000006554 95621447E0 / DATA BTH1CS( 6) / -.0000000840 66228945E0 / DATA BTH1CS( 7) / .0000000133 76886564E0 / DATA BTH1CS( 8) / -.0000000024 99565654E0 / DATA BTH1CS( 9) / .0000000005 29495100E0 / DATA BTH1CS(10) / -.0000000001 24135944E0 / DATA BTH1CS(11) / .0000000000 31656485E0 / DATA BTH1CS(12) / -.0000000000 08668640E0 / DATA BTH1CS(13) / .0000000000 02523758E0 / DATA BTH1CS(14) / -.0000000000 00775085E0 / DATA BTH1CS(15) / .0000000000 00249527E0 / DATA BTH1CS(16) / -.0000000000 00083773E0 / DATA BTH1CS(17) / .0000000000 00029205E0 / DATA BTH1CS(18) / -.0000000000 00010534E0 / DATA BTH1CS(19) / .0000000000 00003919E0 / DATA BTH1CS(20) / -.0000000000 00001500E0 / DATA BTH1CS(21) / .0000000000 00000589E0 / DATA BTH1CS(22) / -.0000000000 00000237E0 / DATA BTH1CS(23) / .0000000000 00000097E0 / DATA BTH1CS(24) / -.0000000000 00000040E0 / DATA PI4 / 0.7853981633 9744831E0 / DATA NTJ1, NTM1, NTTH1, XSML, XMIN, XMAX / 3*0, 3*0./ C***FIRST EXECUTABLE STATEMENT BESJ1 IF (NTJ1.NE.0) GO TO 10 NTJ1 = INITS (BJ1CS, 12, 0.1*R1MACH(3)) NTM1 = INITS (BM1CS, 21, 0.1*R1MACH(3)) NTTH1 = INITS (BTH1CS, 24, 0.1*R1MACH(3)) C XSML = SQRT (8.0*R1MACH(3)) XMIN = 2.0*R1MACH(1) XMAX = 1.0/R1MACH(4) C 10 Y = ABS(X) IF (Y.GT.4.0) GO TO 20 C BESJ1 = 0. IF (Y.EQ.0.0) RETURN IF (Y.LT.XMIN) THEN WRITE(ICOUT,2) CALL DPWRST('XXX','BUG ') ENDIF 2 FORMAT('***** WARNING FROM BESJ1, UNDERFLOW BECAUSE THE ', 1 'ABSOLUTE VALUE OF X IS TOO SMALL. ****') IF (Y.GT.XMIN) BESJ1 = 0.5*X IF (Y.GT.XSML) BESJ1 = X * (.25 + CSEVL(.125*Y*Y-1., BJ1CS, NTJ1)) RETURN C 20 CONTINUE IF (Y.GT.XMAX) THEN WRITE(ICOUT,1) CALL DPWRST('XXX','BUG ') BESJ1 = 0.0 RETURN ENDIF 1 FORMAT('***** ERORR FROM BESJ1, NO PRECISION BECAUSE THE ', 1 'ABSOLUTE VALUE OF X IS TOO BIG. ****') Z = 32.0/Y**2 - 1.0 AMPL = (0.75 + CSEVL (Z, BM1CS, NTM1)) / SQRT(Y) THETA = Y - 3.0*PI4 + CSEVL (Z, BTH1CS, NTTH1) / Y BESJ1 = SIGN (AMPL, X) * COS (THETA) C RETURN END SUBROUTINE BESK (X, FNU, KODE, N, Y, NZ) C***BEGIN PROLOGUE BESK C***PURPOSE Implement forward recursion on the three term recursion C relation for a sequence of non-negative order Bessel C functions K/SUB(FNU+I-1)/(X), or scaled Bessel functions C EXP(X)*K/SUB(FNU+I-1)/(X), I=1,...,N for real, positive C X and non-negative orders FNU. C***LIBRARY SLATEC C***CATEGORY C10B3 C***TYPE SINGLE PRECISION (BESK-S, DBESK-D) C***KEYWORDS K BESSEL FUNCTION, SPECIAL FUNCTIONS C***AUTHOR Amos, D. E., (SNLA) C***DESCRIPTION C C Abstract C BESK implements forward recursion on the three term C recursion relation for a sequence of non-negative order Bessel C functions K/sub(FNU+I-1)/(X), or scaled Bessel functions C EXP(X)*K/sub(FNU+I-1)/(X), I=1,...,N for real X .GT. 0.0E0 and C non-negative orders FNU. If FNU .LT. NULIM, orders FNU and C FNU+1 are obtained from BESKNU to start the recursion. If C FNU .GE. NULIM, the uniform asymptotic expansion is used for C orders FNU and FNU+1 to start the recursion. NULIM is 35 or C 70 depending on whether N=1 or N .GE. 2. Under and overflow C tests are made on the leading term of the asymptotic expansion C before any extensive computation is done. C C Description of Arguments C C Input C X - X .GT. 0.0E0 C FNU - order of the initial K function, FNU .GE. 0.0E0 C KODE - a parameter to indicate the scaling option C KODE=1 returns Y(I)= K/sub(FNU+I-1)/(X), C I=1,...,N C KODE=2 returns Y(I)=EXP(X)*K/sub(FNU+I-1)/(X), C I=1,...,N C N - number of members in the sequence, N .GE. 1 C C Output C y - a vector whose first n components contain values C for the sequence C Y(I)= K/sub(FNU+I-1)/(X), I=1,...,N or C Y(I)=EXP(X)*K/sub(FNU+I-1)/(X), I=1,...,N C depending on KODE C NZ - number of components of Y set to zero due to C underflow with KODE=1, C NZ=0 , normal return, computation completed C NZ .NE. 0, first NZ components of Y set to zero C due to underflow, Y(I)=0.0E0, I=1,...,NZ C C Error Conditions C Improper input arguments - a fatal error C Overflow - a fatal error C Underflow with KODE=1 - a non-fatal error (NZ .NE. 0) C C***REFERENCES F. W. J. Olver, Tables of Bessel Functions of Moderate C or Large Orders, NPL Mathematical Tables 6, Her C Majesty's Stationery Office, London, 1962. C N. M. Temme, On the numerical evaluation of the modified C Bessel function of the third kind, Journal of C Computational Physics 19, (1975), pp. 324-337. C***ROUTINES CALLED ASYIK, BESK0, BESK0E, BESK1, BESK1E, BESKNU, C I1MACH, R1MACH, XERMSG C***REVISION HISTORY (YYMMDD) C 790201 DATE WRITTEN C 890531 Changed all specific intrinsics to generic. (WRB) C 890531 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) C 900326 Removed duplicate information from DESCRIPTION section. C (WRB) C 920501 Reformatted the REFERENCES section. (WRB) C***END PROLOGUE BESK C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOMC.INC' CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C INTEGER I, J, K, KODE, MZ, N, NB, ND, NN, NUD, NULIM, NZ REAL CN, DNU, ELIM, ETX, FLGIK,FN, FNN, FNU,GLN,GNU,RTZ,S,S1,S2, 1 T, TM, TRX, W, X, XLIM, Y, ZN REAL BESK0, BESK1, BESK1E, BESK0E DIMENSION W(2), NULIM(2), Y(*) SAVE NULIM DATA NULIM(1),NULIM(2) / 35 , 70 / C***FIRST EXECUTABLE STATEMENT BESK NN = -I1MACH(12) ELIM = 2.303E0*(NN*R1MACH(5)-3.0E0) XLIM = R1MACH(1)*1.0E+3 IF (KODE.LT.1 .OR. KODE.GT.2) GO TO 280 IF (FNU.LT.0.0E0) GO TO 290 IF (X.LE.0.0E0) GO TO 300 IF (X.LT.XLIM) GO TO 320 IF (N.LT.1) GO TO 310 ETX = KODE - 1 C C ND IS A DUMMY VARIABLE FOR N C GNU IS A DUMMY VARIABLE FOR FNU C NZ = NUMBER OF UNDERFLOWS ON KODE=1 C ND = N NZ = 0 NUD = INT(FNU) DNU = FNU - NUD GNU = FNU NN = MIN(2,ND) FN = FNU + N - 1 FNN = FN IF (FN.LT.2.0E0) GO TO 150 C C OVERFLOW TEST (LEADING EXPONENTIAL OF ASYMPTOTIC EXPANSION) C FOR THE LAST ORDER, FNU+N-1.GE.NULIM C ZN = X/FN IF (ZN.EQ.0.0E0) GO TO 320 RTZ = SQRT(1.0E0+ZN*ZN) GLN = LOG((1.0E0+RTZ)/ZN) T = RTZ*(1.0E0-ETX) + ETX/(ZN+RTZ) CN = -FN*(T-GLN) IF (CN.GT.ELIM) GO TO 320 IF (NUD.LT.NULIM(NN)) GO TO 30 IF (NN.EQ.1) GO TO 20 10 CONTINUE C C UNDERFLOW TEST (LEADING EXPONENTIAL OF ASYMPTOTIC EXPANSION) C FOR THE FIRST ORDER, FNU.GE.NULIM C FN = GNU ZN = X/FN RTZ = SQRT(1.0E0+ZN*ZN) GLN = LOG((1.0E0+RTZ)/ZN) T = RTZ*(1.0E0-ETX) + ETX/(ZN+RTZ) CN = -FN*(T-GLN) 20 CONTINUE IF (CN.LT.-ELIM) GO TO 230 C C ASYMPTOTIC EXPANSION FOR ORDERS FNU AND FNU+1.GE.NULIM C FLGIK = -1.0E0 CALL ASYIK(X,GNU,KODE,FLGIK,RTZ,CN,NN,Y) IF (NN.EQ.1) GO TO 240 TRX = 2.0E0/X TM = (GNU+GNU+2.0E0)/X GO TO 130 C 30 CONTINUE IF (KODE.EQ.2) GO TO 40 C C UNDERFLOW TEST (LEADING EXPONENTIAL OF ASYMPTOTIC EXPANSION IN X) C FOR ORDER DNU C IF (X.GT.ELIM) GO TO 230 40 CONTINUE IF (DNU.NE.0.0E0) GO TO 80 IF (KODE.EQ.2) GO TO 50 S1 = BESK0(X) GO TO 60 50 S1 = BESK0E(X) 60 CONTINUE IF (NUD.EQ.0 .AND. ND.EQ.1) GO TO 120 IF (KODE.EQ.2) GO TO 70 S2 = BESK1(X) GO TO 90 70 S2 = BESK1E(X) GO TO 90 80 CONTINUE NB = 2 IF (NUD.EQ.0 .AND. ND.EQ.1) NB = 1 CALL BESKNU(X, DNU, KODE, NB, W, NZ) S1 = W(1) IF (NB.EQ.1) GO TO 120 S2 = W(2) 90 CONTINUE TRX = 2.0E0/X TM = (DNU+DNU+2.0E0)/X C FORWARD RECUR FROM DNU TO FNU+1 TO GET Y(1) AND Y(2) IF (ND.EQ.1) NUD = NUD - 1 IF (NUD.GT.0) GO TO 100 IF (ND.GT.1) GO TO 120 S1 = S2 GO TO 120 100 CONTINUE DO 110 I=1,NUD S = S2 S2 = TM*S2 + S1 S1 = S TM = TM + TRX 110 CONTINUE IF (ND.EQ.1) S1 = S2 120 CONTINUE Y(1) = S1 IF (ND.EQ.1) GO TO 240 Y(2) = S2 130 CONTINUE IF (ND.EQ.2) GO TO 240 C FORWARD RECUR FROM FNU+2 TO FNU+N-1 DO 140 I=3,ND Y(I) = TM*Y(I-1) + Y(I-2) TM = TM + TRX 140 CONTINUE GO TO 240 C 150 CONTINUE C UNDERFLOW TEST FOR KODE=1 IF (KODE.EQ.2) GO TO 160 IF (X.GT.ELIM) GO TO 230 160 CONTINUE C OVERFLOW TEST IF (FN.LE.1.0E0) GO TO 170 IF (-FN*(LOG(X)-0.693E0).GT.ELIM) GO TO 320 170 CONTINUE IF (DNU.EQ.0.0E0) GO TO 180 CALL BESKNU(X, FNU, KODE, ND, Y, MZ) GO TO 240 180 CONTINUE J = NUD IF (J.EQ.1) GO TO 210 J = J + 1 IF (KODE.EQ.2) GO TO 190 Y(J) = BESK0(X) GO TO 200 190 Y(J) = BESK0E(X) 200 IF (ND.EQ.1) GO TO 240 J = J + 1 210 IF (KODE.EQ.2) GO TO 220 Y(J) = BESK1(X) GO TO 240 220 Y(J) = BESK1E(X) GO TO 240 C C UPDATE PARAMETERS ON UNDERFLOW C 230 CONTINUE NUD = NUD + 1 ND = ND - 1 IF (ND.EQ.0) GO TO 240 NN = MIN(2,ND) GNU = GNU + 1.0E0 IF (FNN.LT.2.0E0) GO TO 230 IF (NUD.LT.NULIM(NN)) GO TO 230 GO TO 10 240 CONTINUE NZ = N - ND IF (NZ.EQ.0) RETURN IF (ND.EQ.0) GO TO 260 DO 250 I=1,ND J = N - I + 1 K = ND - I + 1 Y(J) = Y(K) 250 CONTINUE 260 CONTINUE DO 270 I=1,NZ Y(I) = 0.0E0 270 CONTINUE RETURN C C C 280 CONTINUE WRITE(ICOUT,281) 281 FORMAT('***** ERORR FROM BESK, KODE IS NOT 1 OR 2. ***') CALL DPWRST('XXX','BUG ') RETURN 290 CONTINUE WRITE(ICOUT,291) 291 FORMAT('***** ERORR FROM BESK, THE ORDER FNU IS NEGATIVE. ***') CALL DPWRST('XXX','BUG ') RETURN 300 CONTINUE WRITE(ICOUT,301) 301 FORMAT('**** ERORR FROM BESK, X IS LESS THAN OR EQUAL TO ZERO. ') CALL DPWRST('XXX','BUG ') RETURN 310 CONTINUE WRITE(ICOUT,311) 311 FORMAT('***** ERORR FROM BESK, N IS LESS THAN ONE.. ***') CALL DPWRST('XXX','BUG ') RETURN 320 CONTINUE WRITE(ICOUT,321) 321 FORMAT('***** ERORR FROM BESK, OVERFLOW, FNU OR N TOO LARGE OR ', 1 'X TOO SMALL. *****') CALL DPWRST('XXX','BUG ') RETURN END SUBROUTINE BESKNU (X, FNU, KODE, N, Y, NZ) C***BEGIN PROLOGUE BESKNU C***SUBSIDIARY C***PURPOSE Subsidiary to BESK C***LIBRARY SLATEC C***TYPE SINGLE PRECISION (BESKNU-S, DBSKNU-D) C***AUTHOR Amos, D. E., (SNLA) C***DESCRIPTION C C Abstract C BESKNU computes N member sequences of K Bessel functions C K/SUB(FNU+I-1)/(X), I=1,N for non-negative orders FNU and C positive X. Equations of the references are implemented on C small orders DNU for K/SUB(DNU)/(X) and K/SUB(DNU+1)/(X). C Forward recursion with the three term recursion relation C generates higher orders FNU+I-1, I=1,...,N. The parameter C KODE permits K/SUB(FNU+I-1)/(X) values or scaled values C EXP(X)*K/SUB(FNU+I-1)/(X), I=1,N to be returned. C C To start the recursion FNU is normalized to the interval C -0.5.LE.DNU.LT.0.5. A special form of the power series is C implemented on 0.LT.X.LE.X1 while the Miller algorithm for the C K Bessel function in terms of the confluent hypergeometric C function U(FNU+0.5,2*FNU+1,X) is implemented on X1.LT.X.LE.X2. C For X.GT.X2, the asymptotic expansion for large X is used. C When FNU is a half odd integer, a special formula for C DNU=-0.5 and DNU+1.0=0.5 is used to start the recursion. C C BESKNU assumes that a significant digit SINH(X) function is C available. C C Description of Arguments C C Input C X - X.GT.0.0E0 C FNU - Order of initial K function, FNU.GE.0.0E0 C N - Number of members of the sequence, N.GE.1 C KODE - A parameter to indicate the scaling option C KODE= 1 returns C Y(I)= K/SUB(FNU+I-1)/(X) C I=1,...,N C = 2 returns C Y(I)=EXP(X)*K/SUB(FNU+I-1)/(X) C I=1,...,N C C Output C Y - A vector whose first N components contain values C for the sequence C Y(I)= K/SUB(FNU+I-1)/(X), I=1,...,N or C Y(I)=EXP(X)*K/SUB(FNU+I-1)/(X), I=1,...,N C depending on KODE C NZ - Number of components set to zero due to C underflow, C NZ= 0 , Normal return C NZ.NE.0 , First NZ components of Y set to zero C due to underflow, Y(I)=0.0E0,I=1,...,NZ C C Error Conditions C Improper input arguments - a fatal error C Overflow - a fatal error C Underflow with KODE=1 - a non-fatal error (NZ.NE.0) C C***SEE ALSO BESK C***REFERENCES N. M. Temme, On the numerical evaluation of the modified C Bessel function of the third kind, Journal of C Computational Physics 19, (1975), pp. 324-337. C***ROUTINES CALLED GAMMA, I1MACH, R1MACH, XERMSG C***REVISION HISTORY (YYMMDD) C 790201 DATE WRITTEN C 890531 Changed all specific intrinsics to generic. (WRB) C 891214 Prologue converted to Version 4.0 format. (BAB) C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) C 900326 Removed duplicate information from DESCRIPTION section. C (WRB) C 900328 Added TYPE section. (WRB) C 900727 Added EXTERNAL statement. (WRB) C 910408 Updated the AUTHOR and REFERENCES sections. (WRB) C 920501 Reformatted the REFERENCES section. (WRB) C***END PROLOGUE BESKNU C C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOMC.INC' CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C INTEGER I, IFLAG, INU, J, K, KK, KODE, KODED, N, NN, NZ REAL A, AK, A1, A2, B, BK, CC, CK, COEF, CX, DK, DNU, DNU2, ELIM, 1 ETEST, EX, F, FC, FHS, FK, FKS, FLRX, FMU, FNU, G1, G2, P, PI, 2 PT, P1, P2, Q, RTHPI, RX, S, SMU, SQK, ST, S1, S2, TM, TOL, T1, 3 T2, X, X1, X2, Y DOUBLE PRECISION DGAMMA DIMENSION A(160), B(160), Y(*), CC(8) EXTERNAL DGAMMA SAVE X1, X2, PI, RTHPI, CC DATA X1, X2 / 2.0E0, 17.0E0 / DATA PI,RTHPI / 3.14159265358979E+00, 1.25331413731550E+00/ DATA CC(1), CC(2), CC(3), CC(4), CC(5), CC(6), CC(7), CC(8) 1 / 5.77215664901533E-01,-4.20026350340952E-02, 2-4.21977345555443E-02, 7.21894324666300E-03,-2.15241674114900E-04, 3-2.01348547807000E-05, 1.13302723200000E-06, 6.11609500000000E-09/ C***FIRST EXECUTABLE STATEMENT BESKNU KK = -I1MACH(12) ELIM = 2.303E0*(KK*R1MACH(5)-3.0E0) AK = R1MACH(3) TOL = MAX(AK,1.0E-15) IF (X.LE.0.0E0) GO TO 350 IF (FNU.LT.0.0E0) GO TO 360 IF (KODE.LT.1 .OR. KODE.GT.2) GO TO 370 IF (N.LT.1) GO TO 380 NZ = 0 IFLAG = 0 KODED = KODE RX = 2.0E0/X INU = INT(FNU+0.5E0) DNU = FNU - INU IF (ABS(DNU).EQ.0.5E0) GO TO 120 DNU2 = 0.0E0 IF (ABS(DNU).LT.TOL) GO TO 10 DNU2 = DNU*DNU 10 CONTINUE IF (X.GT.X1) GO TO 120 C C SERIES FOR X.LE.X1 C A1 = 1.0E0 - DNU A2 = 1.0E0 + DNU T1 = 1.0E0/DGAMMA(DBLE(A1)) T2 = 1.0E0/DGAMMA(DBLE(A2)) IF (ABS(DNU).GT.0.1E0) GO TO 40 C SERIES FOR F0 TO RESOLVE INDETERMINACY FOR SMALL ABS(DNU) S = CC(1) AK = 1.0E0 DO 20 K=2,8 AK = AK*DNU2 TM = CC(K)*AK S = S + TM IF (ABS(TM).LT.TOL) GO TO 30 20 CONTINUE 30 G1 = -S GO TO 50 40 CONTINUE G1 = (T1-T2)/(DNU+DNU) 50 CONTINUE G2 = (T1+T2)*0.5E0 SMU = 1.0E0 FC = 1.0E0 FLRX = LOG(RX) FMU = DNU*FLRX IF (DNU.EQ.0.0E0) GO TO 60 FC = DNU*PI FC = FC/SIN(FC) IF (FMU.NE.0.0E0) SMU = SINH(FMU)/FMU 60 CONTINUE F = FC*(G1*COSH(FMU)+G2*FLRX*SMU) FC = EXP(FMU) P = 0.5E0*FC/T2 Q = 0.5E0/(FC*T1) AK = 1.0E0 CK = 1.0E0 BK = 1.0E0 S1 = F S2 = P IF (INU.GT.0 .OR. N.GT.1) GO TO 90 IF (X.LT.TOL) GO TO 80 CX = X*X*0.25E0 70 CONTINUE F = (AK*F+P+Q)/(BK-DNU2) P = P/(AK-DNU) Q = Q/(AK+DNU) CK = CK*CX/AK T1 = CK*F S1 = S1 + T1 BK = BK + AK + AK + 1.0E0 AK = AK + 1.0E0 S = ABS(T1)/(1.0E0+ABS(S1)) IF (S.GT.TOL) GO TO 70 80 CONTINUE Y(1) = S1 IF (KODED.EQ.1) RETURN Y(1) = S1*EXP(X) RETURN 90 CONTINUE IF (X.LT.TOL) GO TO 110 CX = X*X*0.25E0 100 CONTINUE F = (AK*F+P+Q)/(BK-DNU2) P = P/(AK-DNU) Q = Q/(AK+DNU) CK = CK*CX/AK T1 = CK*F S1 = S1 + T1 T2 = CK*(P-AK*F) S2 = S2 + T2 BK = BK + AK + AK + 1.0E0 AK = AK + 1.0E0 S = ABS(T1)/(1.0E0+ABS(S1)) + ABS(T2)/(1.0E0+ABS(S2)) IF (S.GT.TOL) GO TO 100 110 CONTINUE S2 = S2*RX IF (KODED.EQ.1) GO TO 170 F = EXP(X) S1 = S1*F S2 = S2*F GO TO 170 120 CONTINUE COEF = RTHPI/SQRT(X) IF (KODED.EQ.2) GO TO 130 IF (X.GT.ELIM) GO TO 330 COEF = COEF*EXP(-X) 130 CONTINUE IF (ABS(DNU).EQ.0.5E0) GO TO 340 IF (X.GT.X2) GO TO 280 C C MILLER ALGORITHM FOR X1.LT.X.LE.X2 C ETEST = COS(PI*DNU)/(PI*X*TOL) FKS = 1.0E0 FHS = 0.25E0 FK = 0.0E0 CK = X + X + 2.0E0 P1 = 0.0E0 P2 = 1.0E0 K = 0 140 CONTINUE K = K + 1 FK = FK + 1.0E0 AK = (FHS-DNU2)/(FKS+FK) BK = CK/(FK+1.0E0) PT = P2 P2 = BK*P2 - AK*P1 P1 = PT A(K) = AK B(K) = BK CK = CK + 2.0E0 FKS = FKS + FK + FK + 1.0E0 FHS = FHS + FK + FK IF (ETEST.GT.FK*P1) GO TO 140 KK = K S = 1.0E0 P1 = 0.0E0 P2 = 1.0E0 DO 150 I=1,K PT = P2 P2 = (B(KK)*P2-P1)/A(KK) P1 = PT S = S + P2 KK = KK - 1 150 CONTINUE S1 = COEF*(P2/S) IF (INU.GT.0 .OR. N.GT.1) GO TO 160 GO TO 200 160 CONTINUE S2 = S1*(X+DNU+0.5E0-P1/P2)/X C C FORWARD RECURSION ON THE THREE TERM RECURSION RELATION C 170 CONTINUE CK = (DNU+DNU+2.0E0)/X IF (N.EQ.1) INU = INU - 1 IF (INU.GT.0) GO TO 180 IF (N.GT.1) GO TO 200 S1 = S2 GO TO 200 180 CONTINUE DO 190 I=1,INU ST = S2 S2 = CK*S2 + S1 S1 = ST CK = CK + RX 190 CONTINUE IF (N.EQ.1) S1 = S2 200 CONTINUE IF (IFLAG.EQ.1) GO TO 220 Y(1) = S1 IF (N.EQ.1) RETURN Y(2) = S2 IF (N.EQ.2) RETURN DO 210 I=3,N Y(I) = CK*Y(I-1) + Y(I-2) CK = CK + RX 210 CONTINUE RETURN C IFLAG=1 CASES 220 CONTINUE S = -X + LOG(S1) Y(1) = 0.0E0 NZ = 1 IF (S.LT.-ELIM) GO TO 230 Y(1) = EXP(S) NZ = 0 230 CONTINUE IF (N.EQ.1) RETURN S = -X + LOG(S2) Y(2) = 0.0E0 NZ = NZ + 1 IF (S.LT.-ELIM) GO TO 240 NZ = NZ - 1 Y(2) = EXP(S) 240 CONTINUE IF (N.EQ.2) RETURN KK = 2 IF (NZ.LT.2) GO TO 260 DO 250 I=3,N KK = I ST = S2 S2 = CK*S2 + S1 S1 = ST CK = CK + RX S = -X + LOG(S2) NZ = NZ + 1 Y(I) = 0.0E0 IF (S.LT.-ELIM) GO TO 250 Y(I) = EXP(S) NZ = NZ - 1 GO TO 260 250 CONTINUE RETURN 260 CONTINUE IF (KK.EQ.N) RETURN S2 = S2*CK + S1 CK = CK + RX KK = KK + 1 Y(KK) = EXP(-X+LOG(S2)) IF (KK.EQ.N) RETURN KK = KK + 1 DO 270 I=KK,N Y(I) = CK*Y(I-1) + Y(I-2) CK = CK + RX 270 CONTINUE RETURN C C ASYMPTOTIC EXPANSION FOR LARGE X, X.GT.X2 C C IFLAG=0 MEANS NO UNDERFLOW OCCURRED C IFLAG=1 MEANS AN UNDERFLOW OCCURRED- COMPUTATION PROCEEDS WITH C KODED=2 AND A TEST FOR ON SCALE VALUES IS MADE DURING FORWARD C RECURSION 280 CONTINUE NN = 2 IF (INU.EQ.0 .AND. N.EQ.1) NN = 1 DNU2 = DNU + DNU FMU = 0.0E0 IF (ABS(DNU2).LT.TOL) GO TO 290 FMU = DNU2*DNU2 290 CONTINUE EX = X*8.0E0 S2 = 0.0E0 DO 320 K=1,NN S1 = S2 S = 1.0E0 AK = 0.0E0 CK = 1.0E0 SQK = 1.0E0 DK = EX DO 300 J=1,30 CK = CK*(FMU-SQK)/DK S = S + CK DK = DK + EX AK = AK + 8.0E0 SQK = SQK + AK IF (ABS(CK).LT.TOL) GO TO 310 300 CONTINUE 310 S2 = S*COEF FMU = FMU + 8.0E0*DNU + 4.0E0 320 CONTINUE IF (NN.GT.1) GO TO 170 S1 = S2 GO TO 200 330 CONTINUE KODED = 2 IFLAG = 1 GO TO 120 C C FNU=HALF ODD INTEGER CASE C 340 CONTINUE S1 = COEF S2 = COEF GO TO 170 C C 350 CONTINUE WRITE(ICOUT,351) 351 FORMAT('** ERROR FROM BESKNU, X IS LESS THAN OR EQUAL TO ZERO. ') CALL DPWRST('XXX','BUG ') RETURN 360 CONTINUE WRITE(ICOUT,361) 361 FORMAT('***** ERROR FROM BESKNU, THE ORDER FNU IS NEGATIVE. ***') CALL DPWRST('XXX','BUG ') RETURN 370 CONTINUE WRITE(ICOUT,371) 371 FORMAT('***** ERROR FROM BESKNU, KODE IS NOT 1 OR 2. ***') CALL DPWRST('XXX','BUG ') RETURN 380 CONTINUE WRITE(ICOUT,381) 381 FORMAT('***** ERROR FROM BESKNU, N IS LESS THAN ONE.. ***') CALL DPWRST('XXX','BUG ') RETURN END FUNCTION BESK0 (X) C***BEGIN PROLOGUE BESK0 C***PURPOSE Compute the modified (hyperbolic) Bessel function of the C third kind of order zero. C***LIBRARY SLATEC (FNLIB) C***CATEGORY C10B1 C***TYPE SINGLE PRECISION (BESK0-S, DBESK0-D) C***KEYWORDS FNLIB, HYPERBOLIC BESSEL FUNCTION, C MODIFIED BESSEL FUNCTION, ORDER ZERO, SPECIAL FUNCTIONS, C THIRD KIND C***AUTHOR Fullerton, W., (LANL) C***DESCRIPTION C C BESK0(X) calculates the modified (hyperbolic) Bessel function C of the third kind of order zero for real argument X .GT. 0.0. C C Series for BK0 on the interval 0. to 4.00000D+00 C with weighted error 3.57E-19 C log weighted error 18.45 C significant figures required 17.99 C decimal places required 18.97 C C***REFERENCES (NONE) C***ROUTINES CALLED BESI0, BESK0E, CSEVL, INITS, R1MACH, XERMSG C***REVISION HISTORY (YYMMDD) C 770401 DATE WRITTEN C 890531 Changed all specific intrinsics to generic. (WRB) C 890531 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) C 900326 Removed duplicate information from DESCRIPTION section. C (WRB) C***END PROLOGUE BESK0 C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOMC.INC' CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C DIMENSION BK0CS(11) LOGICAL FIRST SAVE BK0CS, NTK0, XSML, XMAX, FIRST DATA BK0CS( 1) / -.0353273932 3390276872E0 / DATA BK0CS( 2) / .3442898999 246284869E0 / DATA BK0CS( 3) / .0359799365 1536150163E0 / DATA BK0CS( 4) / .0012646154 1144692592E0 / DATA BK0CS( 5) / .0000228621 2103119451E0 / DATA BK0CS( 6) / .0000002534 7910790261E0 / DATA BK0CS( 7) / .0000000019 0451637722E0 / DATA BK0CS( 8) / .0000000000 1034969525E0 / DATA BK0CS( 9) / .0000000000 0004259816E0 / DATA BK0CS(10) / .0000000000 0000013744E0 / DATA BK0CS(11) / .0000000000 0000000035E0 / DATA FIRST /.TRUE./ C***FIRST EXECUTABLE STATEMENT BESK0 IF (FIRST) THEN NTK0 = INITS (BK0CS, 11, 0.1*R1MACH(3)) XSML = SQRT (4.0*R1MACH(3)) XMAXT = -LOG(R1MACH(1)) XMAX = XMAXT - 0.5*XMAXT*LOG(XMAXT)/(XMAXT+0.5) - 0.01 ENDIF FIRST = .FALSE. C IF (X .LE. 0.) THEN WRITE(ICOUT,1) 1 FORMAT('***** ERORR FROM BESK0, X IS ZERO OR NEGATIVE. *****') CALL DPWRST('XXX','BUG ') BESK0 = 0.0 RETURN ENDIF IF (X.GT.2.) GO TO 20 C Y = 0. IF (X.GT.XSML) Y = X*X BESK0 = -LOG(0.5*X)*BESI0(X) - .25 + CSEVL (.5*Y-1., BK0CS, NTK0) RETURN C 20 BESK0 = 0. IF (X.GT.XMAX) THEN WRITE(ICOUT,2) CALL DPWRST('XXX','BUG ') BESK0 = 0.0 RETURN ENDIF 2 FORMAT('***** ERORR FROM BESK0, UNDERFLOWS BECAUSE THE ', 1 'VALUE OF X IS TOO BIG. ****') IF (X.GT.XMAX) RETURN C BESK0 = EXP(-X) * BESK0E(X) C RETURN END FUNCTION BESK0E (X) C***BEGIN PROLOGUE BESK0E C***PURPOSE Compute the exponentially scaled modified (hyperbolic) C Bessel function of the third kind of order zero. C***LIBRARY SLATEC (FNLIB) C***CATEGORY C10B1 C***TYPE SINGLE PRECISION (BESK0E-S, DBSK0E-D) C***KEYWORDS EXPONENTIALLY SCALED, FNLIB, HYPERBOLIC BESSEL FUNCTION, C MODIFIED BESSEL FUNCTION, ORDER ZERO, SPECIAL FUNCTIONS, C THIRD KIND C***AUTHOR Fullerton, W., (LANL) C***DESCRIPTION C C BESK0E(X) computes the exponentially scaled modified (hyperbolic) C Bessel function of third kind of order zero for real argument C X .GT. 0.0, i.e., EXP(X)*K0(X). C C Series for BK0 on the interval 0. to 4.00000D+00 C with weighted error 3.57E-19 C log weighted error 18.45 C significant figures required 17.99 C decimal places required 18.97 C C Series for AK0 on the interval 1.25000D-01 to 5.00000D-01 C with weighted error 5.34E-17 C log weighted error 16.27 C significant figures required 14.92 C decimal places required 16.89 C C Series for AK02 on the interval 0. to 1.25000D-01 C with weighted error 2.34E-17 C log weighted error 16.63 C significant figures required 14.67 C decimal places required 17.20 C C***REFERENCES (NONE) C***ROUTINES CALLED BESI0, CSEVL, INITS, R1MACH, XERMSG C***REVISION HISTORY (YYMMDD) C 770401 DATE WRITTEN C 890531 Changed all specific intrinsics to generic. (WRB) C 890531 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) C 900326 Removed duplicate information from DESCRIPTION section. C (WRB) C***END PROLOGUE BESK0E C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOMC.INC' CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C DIMENSION BK0CS(11), AK0CS(17), AK02CS(14) LOGICAL FIRST SAVE BK0CS, AK0CS, AK02CS, NTK0, NTAK0, NTAK02, XSML, FIRST DATA BK0CS( 1) / -.0353273932 3390276872E0 / DATA BK0CS( 2) / .3442898999 246284869E0 / DATA BK0CS( 3) / .0359799365 1536150163E0 / DATA BK0CS( 4) / .0012646154 1144692592E0 / DATA BK0CS( 5) / .0000228621 2103119451E0 / DATA BK0CS( 6) / .0000002534 7910790261E0 / DATA BK0CS( 7) / .0000000019 0451637722E0 / DATA BK0CS( 8) / .0000000000 1034969525E0 / DATA BK0CS( 9) / .0000000000 0004259816E0 / DATA BK0CS(10) / .0000000000 0000013744E0 / DATA BK0CS(11) / .0000000000 0000000035E0 / DATA AK0CS( 1) / -.0764394790 3327941E0 / DATA AK0CS( 2) / -.0223565260 5699819E0 / DATA AK0CS( 3) / .0007734181 1546938E0 / DATA AK0CS( 4) / -.0000428100 6688886E0 / DATA AK0CS( 5) / .0000030817 0017386E0 / DATA AK0CS( 6) / -.0000002639 3672220E0 / DATA AK0CS( 7) / .0000000256 3713036E0 / DATA AK0CS( 8) / -.0000000027 4270554E0 / DATA AK0CS( 9) / .0000000003 1694296E0 / DATA AK0CS(10) / -.0000000000 3902353E0 / DATA AK0CS(11) / .0000000000 0506804E0 / DATA AK0CS(12) / -.0000000000 0068895E0 / DATA AK0CS(13) / .0000000000 0009744E0 / DATA AK0CS(14) / -.0000000000 0001427E0 / DATA AK0CS(15) / .0000000000 0000215E0 / DATA AK0CS(16) / -.0000000000 0000033E0 / DATA AK0CS(17) / .0000000000 0000005E0 / DATA AK02CS( 1) / -.0120186982 6307592E0 / DATA AK02CS( 2) / -.0091748526 9102569E0 / DATA AK02CS( 3) / .0001444550 9317750E0 / DATA AK02CS( 4) / -.0000040136 1417543E0 / DATA AK02CS( 5) / .0000001567 8318108E0 / DATA AK02CS( 6) / -.0000000077 7011043E0 / DATA AK02CS( 7) / .0000000004 6111825E0 / DATA AK02CS( 8) / -.0000000000 3158592E0 / DATA AK02CS( 9) / .0000000000 0243501E0 / DATA AK02CS(10) / -.0000000000 0020743E0 / DATA AK02CS(11) / .0000000000 0001925E0 / DATA AK02CS(12) / -.0000000000 0000192E0 / DATA AK02CS(13) / .0000000000 0000020E0 / DATA AK02CS(14) / -.0000000000 0000002E0 / DATA FIRST /.TRUE./ C***FIRST EXECUTABLE STATEMENT BESK0E IF (FIRST) THEN NTK0 = INITS (BK0CS, 11, 0.1*R1MACH(3)) NTAK0 = INITS (AK0CS, 17, 0.1*R1MACH(3)) NTAK02 = INITS (AK02CS, 14, 0.1*R1MACH(3)) XSML = SQRT (4.0*R1MACH(3)) ENDIF FIRST = .FALSE. C IF (X .LE. 0.) THEN WRITE(ICOUT,1) 1 FORMAT('***** ERORR FROM BESK0E, X ZERO OR NEGATIVE. *******') CALL DPWRST('XXX','BUG ') BESK0E=0.0 RETURN ENDIF IF (X.GT.2.) GO TO 20 C Y = 0. IF (X.GT.XSML) Y = X*X BESK0E = EXP(X) * (-LOG(0.5*X)*BESI0(X) 1 - .25 + CSEVL (.5*Y-1., BK0CS, NTK0) ) RETURN C 20 IF (X.LE.8.) BESK0E = (1.25 + CSEVL ((16./X-5.)/3., AK0CS, NTAK0)) 1 / SQRT(X) IF (X.GT.8.) BESK0E = (1.25 + CSEVL (16./X-1., AK02CS, NTAK02)) 1 / SQRT(X) C RETURN END FUNCTION BESK1 (X) C***BEGIN PROLOGUE BESK1 C***PURPOSE Compute the modified (hyperbolic) Bessel function of the C third kind of order one. C***LIBRARY SLATEC (FNLIB) C***CATEGORY C10B1 C***TYPE SINGLE PRECISION (BESK1-S, DBESK1-D) C***KEYWORDS FNLIB, HYPERBOLIC BESSEL FUNCTION, C MODIFIED BESSEL FUNCTION, ORDER ONE, SPECIAL FUNCTIONS, C THIRD KIND C***AUTHOR Fullerton, W., (LANL) C***DESCRIPTION C C BESK1(X) computes the modified (hyperbolic) Bessel function of third C kind of order one for real argument X, where X .GT. 0. C C Series for BK1 on the interval 0. to 4.00000D+00 C with weighted error 7.02E-18 C log weighted error 17.15 C significant figures required 16.73 C decimal places required 17.67 C C***REFERENCES (NONE) C***ROUTINES CALLED BESI1, BESK1E, CSEVL, INITS, R1MACH, XERMSG C***REVISION HISTORY (YYMMDD) C 770401 DATE WRITTEN C 890531 Changed all specific intrinsics to generic. (WRB) C 890531 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) C 900326 Removed duplicate information from DESCRIPTION section. C (WRB) C***END PROLOGUE BESK1 C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOMC.INC' CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C DIMENSION BK1CS(11) LOGICAL FIRST SAVE BK1CS, NTK1, XMIN, XSML, XMAX, FIRST DATA BK1CS( 1) / .0253002273 389477705E0 / DATA BK1CS( 2) / -.3531559607 76544876E0 / DATA BK1CS( 3) / -.1226111808 22657148E0 / DATA BK1CS( 4) / -.0069757238 596398643E0 / DATA BK1CS( 5) / -.0001730288 957513052E0 / DATA BK1CS( 6) / -.0000024334 061415659E0 / DATA BK1CS( 7) / -.0000000221 338763073E0 / DATA BK1CS( 8) / -.0000000001 411488392E0 / DATA BK1CS( 9) / -.0000000000 006666901E0 / DATA BK1CS(10) / -.0000000000 000024274E0 / DATA BK1CS(11) / -.0000000000 000000070E0 / DATA FIRST /.TRUE./ C***FIRST EXECUTABLE STATEMENT BESK1 IF (FIRST) THEN NTK1 = INITS (BK1CS, 11, 0.1*R1MACH(3)) XMIN = EXP (MAX(LOG(R1MACH(1)), -LOG(R1MACH(2))) + .01) XSML = SQRT (4.0*R1MACH(3)) XMAXT = -LOG(R1MACH(1)) XMAX = XMAXT - 0.5*XMAXT*LOG(XMAXT)/(XMAXT+0.5) ENDIF FIRST = .FALSE. C IF (X .LE. 0.) THEN WRITE(ICOUT,1) 1 FORMAT('***** ERORR FROM BESK1, X ZERO OR NEGATIVE. *******') CALL DPWRST('XXX','BUG ') BESK1=0.0 RETURN ENDIF IF (X.GT.2.0) GO TO 20 C IF (X .LE. XMIN) THEN WRITE(ICOUT,2) CALL DPWRST('XXX','BUG ') ENDIF 2 FORMAT('***** WARNING FROM BESK1, UNDERFLOW BECAUSE THE ', 1 'VALUE OF X IS SO SMALL. ****') Y = 0. IF (X.GT.XSML) Y = X*X BESK1 = LOG(0.5*X)*BESI1(X) + 1 (0.75 + CSEVL (.5*Y-1., BK1CS, NTK1))/X RETURN C 20 BESK1 = 0. IF (X.GT.XMAX) THEN WRITE(ICOUT,3) CALL DPWRST('XXX','BUG ') BESK1 = 0.0 RETURN ENDIF 3 FORMAT('***** ERORR FROM BESK1, UNDERFLOW BECAUSE THE ', 1 'VALUE OF X IS TOO BIG. ****') IF (X.GT.XMAX) RETURN C BESK1 = EXP(-X) * BESK1E(X) C RETURN END FUNCTION BESK1E (X) C***BEGIN PROLOGUE BESK1E C***PURPOSE Compute the exponentially scaled modified (hyperbolic) C Bessel function of the third kind of order one. C***LIBRARY SLATEC (FNLIB) C***CATEGORY C10B1 C***TYPE SINGLE PRECISION (BESK1E-S, DBSK1E-D) C***KEYWORDS EXPONENTIALLY SCALED, FNLIB, HYPERBOLIC BESSEL FUNCTION, C MODIFIED BESSEL FUNCTION, ORDER ONE, SPECIAL FUNCTIONS, C THIRD KIND C***AUTHOR Fullerton, W., (LANL) C***DESCRIPTION C C BESK1E(X) computes the exponentially scaled modified (hyperbolic) C Bessel function of third kind of order one for real argument C X .GT. 0.0, i.e., EXP(X)*K1(X). C C Series for BK1 on the interval 0. to 4.00000D+00 C with weighted error 7.02E-18 C log weighted error 17.15 C significant figures required 16.73 C decimal places required 17.67 C C Series for AK1 on the interval 1.25000D-01 to 5.00000D-01 C with weighted error 6.06E-17 C log weighted error 16.22 C significant figures required 15.41 C decimal places required 16.83 C C Series for AK12 on the interval 0. to 1.25000D-01 C with weighted error 2.58E-17 C log weighted error 16.59 C significant figures required 15.22 C decimal places required 17.16 C C***REFERENCES (NONE) C***ROUTINES CALLED BESI1, CSEVL, INITS, R1MACH, XERMSG C***REVISION HISTORY (YYMMDD) C 770401 DATE WRITTEN C 890531 Changed all specific intrinsics to generic. (WRB) C 890531 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) C 900326 Removed duplicate information from DESCRIPTION section. C (WRB) C***END PROLOGUE BESK1E C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOMC.INC' CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C DIMENSION BK1CS(11), AK1CS(17), AK12CS(14) LOGICAL FIRST SAVE BK1CS, AK1CS, AK12CS, NTK1, NTAK1, NTAK12, XMIN, XSML, 1 FIRST DATA BK1CS( 1) / .0253002273 389477705E0 / DATA BK1CS( 2) / -.3531559607 76544876E0 / DATA BK1CS( 3) / -.1226111808 22657148E0 / DATA BK1CS( 4) / -.0069757238 596398643E0 / DATA BK1CS( 5) / -.0001730288 957513052E0 / DATA BK1CS( 6) / -.0000024334 061415659E0 / DATA BK1CS( 7) / -.0000000221 338763073E0 / DATA BK1CS( 8) / -.0000000001 411488392E0 / DATA BK1CS( 9) / -.0000000000 006666901E0 / DATA BK1CS(10) / -.0000000000 000024274E0 / DATA BK1CS(11) / -.0000000000 000000070E0 / DATA AK1CS( 1) / .2744313406 973883E0 / DATA AK1CS( 2) / .0757198995 3199368E0 / DATA AK1CS( 3) / -.0014410515 5647540E0 / DATA AK1CS( 4) / .0000665011 6955125E0 / DATA AK1CS( 5) / -.0000043699 8470952E0 / DATA AK1CS( 6) / .0000003540 2774997E0 / DATA AK1CS( 7) / -.0000000331 1163779E0 / DATA AK1CS( 8) / .0000000034 4597758E0 / DATA AK1CS( 9) / -.0000000003 8989323E0 / DATA AK1CS(10) / .0000000000 4720819E0 / DATA AK1CS(11) / -.0000000000 0604783E0 / DATA AK1CS(12) / .0000000000 0081284E0 / DATA AK1CS(13) / -.0000000000 0011386E0 / DATA AK1CS(14) / .0000000000 0001654E0 / DATA AK1CS(15) / -.0000000000 0000248E0 / DATA AK1CS(16) / .0000000000 0000038E0 / DATA AK1CS(17) / -.0000000000 0000006E0 / DATA AK12CS( 1) / .0637930834 3739001E0 / DATA AK12CS( 2) / .0283288781 3049721E0 / DATA AK12CS( 3) / -.0002475370 6739052E0 / DATA AK12CS( 4) / .0000057719 7245160E0 / DATA AK12CS( 5) / -.0000002068 9392195E0 / DATA AK12CS( 6) / .0000000097 3998344E0 / DATA AK12CS( 7) / -.0000000005 5853361E0 / DATA AK12CS( 8) / .0000000000 3732996E0 / DATA AK12CS( 9) / -.0000000000 0282505E0 / DATA AK12CS(10) / .0000000000 0023720E0 / DATA AK12CS(11) / -.0000000000 0002176E0 / DATA AK12CS(12) / .0000000000 0000215E0 / DATA AK12CS(13) / -.0000000000 0000022E0 / DATA AK12CS(14) / .0000000000 0000002E0 / DATA FIRST /.TRUE./ C***FIRST EXECUTABLE STATEMENT BESK1E IF (FIRST) THEN NTK1 = INITS (BK1CS, 11, 0.1*R1MACH(3)) NTAK1 = INITS (AK1CS, 17, 0.1*R1MACH(3)) NTAK12 = INITS (AK12CS, 14, 0.1*R1MACH(3)) C XMIN = EXP (MAX(LOG(R1MACH(1)), -LOG(R1MACH(2))) + .01) XSML = SQRT (4.0*R1MACH(3)) ENDIF FIRST = .FALSE. C IF (X .LE. 0.) THEN WRITE(ICOUT,1) 1 FORMAT('***** ERORR FROM BESK1E, X ZERO OR NEGATIVE. *******') CALL DPWRST('XXX','BUG ') BESK1E=0.0 RETURN ENDIF IF (X.GT.2.0) GO TO 20 C IF (X .LT. XMIN) THEN WRITE(ICOUT,2) CALL DPWRST('XXX','BUG ') BESK1E = 0.0 RETURN ENDIF 2 FORMAT('***** ERROR FROM BESK1E, OVERRFLOW BECAUSE THE ', 1 'VALUE OF X IS SO SMALL. ****') Y = 0. IF (X.GT.XSML) Y = X*X BESK1E = EXP(X) * (LOG(0.5*X)*BESI1(X) + 1 (0.75 + CSEVL (.5*Y-1., BK1CS, NTK1))/X ) RETURN C 20 IF (X.LE.8.) BESK1E = (1.25 + CSEVL ((16./X-5.)/3., AK1CS, NTAK1)) 1 / SQRT(X) IF (X.GT.8.) BESK1E = (1.25 + CSEVL (16./X-1., AK12CS, NTAK12)) 1 / SQRT(X) C RETURN END SUBROUTINE BESICF(ZZ,AA,NMAX,BI) C THIS ROUTINE CALCULATES BESSEL FUNCTIONS I OF COMPLEX ARGUMENT AND C REAL ORDER. ARGUMENTS ARE AS FOR BESJCF, EXCEPT THAT HERE, IT IS REAL C PART OF ZZ THAT MUST NOT EXCEED EXPARG IN ABSOLUTE VALUE C EQUATION 9.6.3 OF REFERENCE 1 AS LISTED IN BESJCF IS USED COMPLEX ZZ,BI(*),BB,CC,ZDUMMY C C Definition of real and imaginary parts of complex number, C standard Fortran and will work on Convex with -r8 -i8. REALP(ZDUMMY) = REAL(ZDUMMY) AIMAGP(ZDUMMY) = REAL((0,-1)*ZDUMMY) C CC=(0.,1.) IF(AIMAGP(ZZ).LT.0.) CC=-CC BB=-CC*ZZ CALL BESJCF(BB,AA,NMAX,BI) ANGLE= 1.5707963267949*AA*AIMAGP(CC) BB=CMPLX(COS(ANGLE),SIN(ANGLE)) BI(1)=-CC*BB*BI(1) MAXP=NMAX+2 DO 1 N=2,MAXP BI(N)=BI(N)*BB 1 BB=CC*BB RETURN END SUBROUTINE BESJCF(ZZ,AA,NMAX,BJ) C THIS ROUTINE CALCULATES BESSEL FUNCTIONS J OF COMPLEX ARGUMENT AND C REAL ORDER C ROUTINE WRITTEN AND TESTED BY DAVID SAGIN (SOOKNE), COMPUTER CENTER, C TEL-AVIV UNIVERSITY. ROUTINE DATED 3/3/77 C C DESCRIPTION OF VARIABLES IN THE CALLING VECTOR C C ZZ COMPLEX ARGUMENT. LIMITATIONS ARE ABS(AIMAG(ZZ)).LT.EXPARG (SEE C BELOW), AND ZZ*CONJG(ZZ) NOT ZERO IN THE COMPUTER C AA FRACTIONAL PART OF REAL ORDER FOR WHICH J*S AND/OR Y*S ARE TO BE C CALCULATED. AA MUST BE GREATER THAN -.5 AND AT MOST +.5. C NMAX NON-NEGATIVE INTEGER SUCH THAT NMAX+AA IS THE HIGHEST ORDER YOU C WANT. C BJ COMPLEX VECTOR OF LENGTH NMAX+2, IN C WHICH BESLCF RETURNS J*S OF ORDERS AA-1, AA, AA+1,...AA+NMAX. C C NUMBERS IN PARENTHESES (IN COMMENT CARDS BELOW) REFER TO THESE C REFERENCES C 1) MILTON ABRAMOWITZ AND IRENE A. STEGUN, HANDBOOK OF MATHEMATICAL C FUNCTIONS, NATIONAL BUREAU OF STANDARDS, 1964 C 2) M. GOLDSTEIN AND R. M. THALER, RECURRENCE TECHNIQUES FOR THE CALCU- C LATION OF BESSEL FUNCTIONS, MATHEMATICS OF COMPUTATION, VOLUME 13, C APRIL 1959, PAGE 102 C 3) F. W. J. OLVER AND D. J. SOOKNE, NOTE ON BACKWARD RECURRENCE ALGO- C RITHMS, MATHEMATICS OF COMPUTATION, VOLUME 26, OCT. 1972, PAGE 941 C 4) DAVID J. SOOKNE, BESSEL FUNCTIONS OF COMPLEX ARGUMENT AND INTEGER C ORDER, JOURNAL OF RESEARCH OF THE NATIONAL BUREAU OF STANDARDS, C SERIES B, VOLUME 77A, JULY-DEC. 1973, PAGE 111 C 5) A. ERDELYI ET AL., HIGHER TRANSCENDENTAL FUNCTIONS, VOLUME 2 C CHAPTER 7, MCGRAW-HILL, NEW YORK, 1953 C C NOTE. C THIS ROUTINE CALLS A FUNCTION GAM1(X) WHICH RETURNS THE GAMMA C FUNCTION OF X FOR POSITIVE X .LE. GAML. SEE THE DEFINITION OF C GAML UNDER MACHINE DEPENDENT CONSTANTS BELOW. C C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOMC.INC' DOUBLE PRECISION DGAMMA CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C COMPLEX BJ(*),B,BA1,BB,BBB,BD,FAC,SUM,Z,ZI,ZP,ZZ,ZDUMMY C Note: Old variable LOG changed to LOGICL by D.W. Lozier, 4/27/88, to C avoid conflict with generic function. LOGICAL LOGICL(4) C----------------------------------------------------------------------- C C MACHINE DEPENDENT CONSTANTS. C --------------------------- C SAVE ISAVE, SQRTPI, DYOUK, EXPARG, GAML, LOU DATA ISAVE /1/ C C Definition of real and imaginary parts of complex number, C standard Fortran and will work on Convex with -r8 -i8. REALP(ZDUMMY) = REAL(ZDUMMY) AIMAGP(ZDUMMY) = REAL((0,-1)*ZDUMMY) C IF (ISAVE.GT.0) THEN ISAVE = 0 C SQUARE ROOT OF PI, MACHINE ACCURACY, AND LIMIT ON ARGUMENT TO EXP SQRTPI = SQRT (4.0*ATAN (1.0)) DYOUK = R1MACH (4) EXPARG = LOG (R1MACH (2)) C GAML IS AN INTEGER (PREFERABLY THE SMALLEST) SUCH THAT C 1./(1680*LGAMMA(GAML)*GAML**7).LE.DYOUK. SEE FORMULA 6.1.41 OF (1) C Note: Code changed 4/27/88 by D.W. Lozier to prevent integer overflow. C Previously, an integer factorial was formed, then the log was taken. C In IEEE double precision, GAML=32 and i! overflows, causing the old C code to fail. I = 2 GAMLF = LOG(2.0) 6 I = I + 1 GAML = I GAMLF = GAMLF + LOG(GAML) IF ((1680.0*GAMLF*(GAML**7)*DYOUK) .LT. 1.0) GO TO 6 LOU = I1MACH(2) ENDIF C C----------------------------------------------------------------------- Z=ZZ A=AA N=NMAX E=REALP(Z)**2+AIMAGP(Z)**2 C CHECK THAT INPUT DATA IS LEGAL IF ((A .LE. -0.5) .OR. (A .GT. 0.5) .OR. * (ABS(AIMAGP(Z)) .GT. EXPARG) .OR. (E .EQ. 0.) .OR. (N .LT. 0)) * GO TO 86 MAXN=N MAXP=2+MAXN C AVOID UNDERFLOW OR OVERFLOW IN COMPLEX DIVIDE F=1./MAX(ABS(REALP(Z)),ABS(AIMAGP(Z))) ZI=2.*F/(Z*F) BD=LOG(.5*Z) ZP=EXP(A*BD) BBB=ZP/REAL(DGAMMA(DBLE(1.+A))) LOGICL(1)=MAXN.LE.0 LOGICL(3)=E.LE.DYOUK LOGICL(4)=A.EQ.0. FAC = (1.0, 0.0) IF(LOGICL(3)) GO TO 72 C ROUTINE BACALC RETURNS N AND B (=J-SUB(N+A)OF-X) WITH WHICH TO START C CALCULATING J*S VIA BACK RECURSION CALL BACKLC(Z,A,N,B) K=(N+1)/2 IF(N.LE.MAXN) GO TO 80 C C INITIALIZE VARIABLES FOR THE BACK-RECURSION. COEF IS THE COEFFICIENT C OF THE NORMALIZATION SUM, AND FAC IS USED IN CALCULATING THE NORMALI- C ZATION FACTOR. THESE ARE CALCULATED VIA EQUATION 44 OF CHAPTER 7.15 C OF (5) IF A.NE.0. IN THIS CASE, COS(PHI) IS ZERO OR 1 DEPENDING ON C WHETHER ABS(COS(Z)) IS LESS THAN 1 OR GREATER THAN 1 RESPECTIVELY. C IF A.EQ.0, THE NORMALIZATION IS VIA EQUATION 9.1.46 OR 9.1.47 OF (1), C DEPENDING OR COS(Z). C 8 COEF=2. KD=1 BB=COS(Z) LOGICL(2)=.FALSE. IF(ABS(BB).LE.1.) GO TO 11 KD=2 FAC=BB LOGICL(2)=.TRUE. 11 IF(LOGICL(4)) GO TO 14 D=REAL(KD*K) G=A*REAL(KD) C=D+G F=2.+A/REAL(K) IF(LOGICL(2)) F=F*SQRTPI/(REAL(DGAMMA(DBLE(A+.5)))*2.**(2.*A)) IF(C.GT.GAML) GO TO 12 COEF=F*REAL(DGAMMA(DBLE(C)))/REAL(DGAMMA(DBLE(D))) GO TO 14 12 E=C*D COEF=(D-.5)*LOG(C/D)+G*(LOG(C)-1.- 1(1.-(C*C+E+D*D-(C**4+C*C*E+E*E+D*D*E+D**4)/(3.5*E*E))/(30.*E*E)) 2/(12.*E)) COEF=F*EXP(COEF) 14 BB = (0.0, 0.0) SUM = (0.0, 0.0) G=1. IF(LOGICL(2).AND.K.NE.2*(K/2)) COEF=-COEF LOGICL(3)=2*K.NE.N IF(LOGICL(3)) GO TO 20 SUM=COEF*B C USING 9.1.27 OF (1) (EQUATION 1 OF (4) IS THE ANALOG FOR INTEGER C ORDERS), CALCULATE UNNORMALIZED J*S OF ORDERS N-1+A, N-2+A,...A. C ACCUMULATE THE NORMALIZATION SUM AS DESCRIBED ABOVE. 20 E=REAL(N)+A N=N-1 BBB=BB BB=B B=(ZI*E)*BB-BBB IF(LOGICL(1)) GO TO 22 IF(N.LE.MAXN) BJ(N+2)=B 22 LOGICL(3)=.NOT.LOGICL(3) IF(LOGICL(3)) GO TO 20 D=REAL(K) K=K-1 F=REAL(K)+A IF(LOGICL(4)) GO TO 24 G=D*(REAL(N)+A)/(F*(E+1.)) COEF=COEF*G IF(LOGICL(2)) COEF=COEF*REAL(N+1)/(2.*F+1.) 24 IF(LOGICL(2)) COEF=-COEF IF(N.EQ.0) GO TO 28 SUM=SUM+COEF*B GO TO 20 28 BA1=(ZI*A)*B-BB IF(LOGICL(4)) COEF=1. C THE BACK-RECURSION IS FINISHED. CALCULATE THE NORMALIZATION FACTOR SUM=SUM+COEF*B F=1./MAX(ABS(REALP(SUM)),ABS(AIMAGP(SUM))) FAC=ZP*(F*(FAC/(CMPLX(REALP(SUM)*F,AIMAGP(SUM)*F)))) BJ(1)=BA1*FAC BJ(2)=B*FAC IF(MAXN.EQ.0) GO TO 70 DO 34 M=3,MAXP 34 BJ(M)=FAC*BJ(M) C C THIS IS THE ONLY RETURN STATEMENT IN THE ROUTINE C 70 RETURN C C FOR VERY SMALL Z, CALCULATE J*S VIA ASYMPTOTIC FORMULA 9.1.7 OF (1) C 72 BJ(2)=BBB BB=(Z*BJ(2))*(.5/(1.+A)) BJ(1)=-BB IF(.NOT.LOGICL(4)) BJ(1)=(ZI*BJ(2))*AA IF(MAXP.GE.3) BJ(3)=BB IF(MAXP.LT.4) GO TO 70 DO 74 N=4,MAXP 74 BJ(N)=(Z*BJ(N-1))*(.5/(A+REAL(N-2))) GO TO 70 C UNDERFLOW. SET J*S ZERO 80 DO 81 M=N,MAXN 81 BJ(M + 2) = (0.0, 0.0) BJ(N+2)=B GO TO 8 C CONK OUT 86 CONTINUE WRITE (ICOUT, 88) CALL DPWRST('XXX','BUG') WRITE (ICOUT, 89) N, A, Z CALL DPWRST('XXX','BUG') 88 FORMAT('***** FATAL ERROR (BESJCF) --- INVALID INPUT ') 89 FORMAT(' NMAX = ',I6,' A = ',1PE22.14,' Z = ',2(1PE22.14)) RETURN END SUBROUTINE BESKCF(ZZ,AA,NMAX,BK) C THIS ROUTINE CALCULATES BESSEL FUNCTIONS K OF COMPLEX ARGUMENT AND C REAL ORDER. ARGUMENTS ARE AS FOR ROUTINE BESJCF, EXCEPT HERE IT IS C REAL(ZZ) WHICH MUST NOT EXCEED EXPARG IN ABSOLUTE VALUE C K*S ARE CALCULATED BY FORWARD RECURSION, USING EQUATION 1.9 OF THE C REFERENCE LISTED IN ROUTINE RECIPG. TO START THE RECURSION, FUNCTION C VALUES OF ORDERS A AND A+1 ARE CALCULATED IF A.LE.0, WHILE ORDERS A C AND A-1 ARE CALCULATED IF A.GT.0. C NOTE IF ANY K-VALUE IS SO BIG THAT ITS CALCULATION WOULD CAUSE OVER- C FLOW, IT (AND ALL HIGHER ORDERS) ARE SET TO ZERO. C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOMC.INC' CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C COMPLEX AK(21),AK1(21),BK(*),BB,CC,DD,EE,FF,GG,HH,PP,QQ,SS,Z,ZINV, 1 ZZ,RR,ZDUMMY C----------------------------------------------------------------------- C C MACHINE DEPENDENT CONSTANTS. C --------------------------- C C MACHINE-DEPENDENT CONSTANTS ARE EXPLAINED IN C ROUTINES BESJCF, BACKLC, AND BESYCF. C SAVE ISAVE,PI,SQRTPI,GADOL,EXPARG,DYOUK,DYOUKH,NTERM,DYOUKI,LOU DATA ISAVE /1/ C C Definition of real and imaginary parts of complex number, C standard Fortran and will work on Convex with -r8 -i8. REALP(ZDUMMY) = REAL(ZDUMMY) AIMAGP(ZDUMMY) = REAL((0,-1)*ZDUMMY) C IF (ISAVE.GT.0) THEN ISAVE = 0 PI = 4.0*ATAN (1.0) SQRTPI = SQRT (PI) GADOL = R1MACH (2) EXPARG = LOG (GADOL) DYOUK = R1MACH (4) DYOUKH = SQRT (DYOUK) NTERM = 20 DYOUKI = 1.0 / DYOUK LOU = I1MACH(2) ENDIF C C----------------------------------------------------------------------- Z=ZZ A=AA MAXP=NMAX+2 Q=ABS(REALP(Z)) E=Q*Q+AIMAGP(Z)**2 IF ((A .LE. - 0.5) .OR. (A .GT. 0.5) .OR. (MAXP .LT. 2) .OR. * (E .EQ. 0.0) .OR. (Q .GT. EXPARG)) GO TO 86 F=SQRT(E) BIG=GADOL*MIN(.25,F/REAL(4*MAX(1,NMAX))) C AVOID UNDERFLOW OR OVERFLOW IN COMPLEX DIVIDE F=1./F ZINV=2.*F/(Z*F) IF(A.EQ..5.OR.E.GE.196.) GO TO 30 IF(E.GE.9.) GO TO 20 C FOR SMALL Z, CALCULATE K*S VIA EQUATIONS 2.1 OF THE REFERENCE LISTED C IN ROUTINE RECIPG BB=.5*Z DD=-LOG(BB) EE=A*DD C=1. IF(PI*ABS(A).GT.DYOUKH) C=PI*A/SIN(PI*A) SS = (1.0, 0.0) IF ((REALP (EE) ** 2 + AIMAGP (EE) ** 2) .GT. DYOUK) * SS = CMPLX (0.0, - 1.0) * SIN (CMPLX (0., 1.0) * EE) / EE EE=EXP(EE) CALL RECIPG(A,P,Q,G) GG=G*EE EE=.5*(EE+1./EE) FF=C*(P*EE+Q*SS*DD) E=A*A PP=.5*C*GG QQ=.5/GG CC = (1.0, 0.0) DD=BB*BB AK(1)=FF C IF A.GT.0, CALCULATE KSUB(A-1) BY SUBSTITUTING EQUATIONS 2.1 AND 2.9 C INTO 1.9 AK1(1)=PP C IF A.LE.0, CALCULATE KSUB(A+1) VIA 2.9 IF(A.GT.0.) AK1(1)=QQ TEST=DYOUK*MAX(ABS(REALP(AK(1))),ABS(AIMAGP(AK(1)))) DO 10 N=1,NTERM EN=N G=1./(EN*EN-E) IF(A.GT.0.) GO TO 6 HH=-G*(EN*(EN*FF+QQ)-A*PP) GO TO 8 6 HH=-G*(EN*(EN*FF+PP)+A*QQ) 8 FF=G*(EN*FF+PP+QQ) CC=CC*DD/EN AK(N+1) =CC*FF AK1(N+1)=CC*HH IF(MAX(ABS(REALP(AK(N+1))),ABS(AIMAGP(AK(N+1)))).LE.TEST) GO TO 12 PP=PP/(EN-A) 10 QQ=QQ/(EN+A) RETURN 12 N=N+1 M=N+1 GG = (0.0, 0.0) HH = (0.0, 0.0) DO 14 L=1,N ITEMP = M - L GG=GG+AK(ITEMP) 14 HH=HH+AK1(ITEMP) BK(2)=GG BK(1)=HH*ZINV GO TO 40 C FOR ABS(Z) BETWEEN 3 AND 14, CALCULATE K*S VIA THE ALGORITHM GIVEN C IN SECTION 3 OF THE REFERENCE. THE ALGORITHM IS GIVEN FOR REAL Z, BUT C CAN BE USED WHEN THE REAL PART OF Z IS NON-NEGATIVE. 20 TEST=DYOUKI*COS(A*PI)/(E*PI) E=1. PP = (1.0, 0.0) QQ = (0.0, 0.0) FF=Z IF(REALP(Z).LT.0.) FF=-Z C=.25-A*A DO 22 N=1,99 AN=(REAL(N*N-N)+C)/REAL(N*N+N) E=E*AN EN=1./REAL(N+1) BB=2.*EN*(REAL(N)+FF) RR=QQ QQ=PP PP=BB*QQ-AN*RR IF(MAX(ABS(REALP(PP)),ABS(AIMAGP(PP))).GE.EN*TEST) GO TO 23 22 CONTINUE RETURN 23 PP=E/PP QQ = (0.0, 0.0) EE=PP M=N N=N+1 DO 25 L=1,M N=N-1 RR=QQ QQ=PP AINV=REAL(N*N+N)/(REAL(N*N-N)+C) BB=2.*(REAL(N)+FF)/REAL(N+1) PP=(BB*QQ-RR)*AINV 25 EE=EE+PP BB=LOG(2.*FF) GG=EXP(-BB*(A+.5))/EE BK(2)=SQRTPI*EXP(A*BB-FF)*GG*PP E=A IF(A.GT.0.) E=-A BK(1)=.5*BK(2)*(FF-QQ/PP+(.5+E))*ZINV IF(REALP(Z).GE.0.) GO TO 40 C REAL(Z) IS NEGATIVE, SO USE EQUATION 9.6.31 OF REFERENCE (1) OF BESJCF BK(1)=-BK(1) 26 ZINV=-ZINV HH=BK(1) GG=BK(2) QQ=HH IF(A.GT.0.) HH=QQ+A*(ZINV*GG) IF(A.LE.0.) QQ=HH-A*(ZINV*GG) C NOW QQ, GG, HH ARE FUNCTIONS K OF ARGUMENT (-Z) AND ORDER A-1, A, A+1 CALL BESICF(FF,A,NMAX,BK) E=1. IF(AIMAGP(Z).GE.0.) E=-1. DD=CMPLX(0.,E) E=-E*PI EE=CMPLX(0.,E) E=-E*A IF(A.NE..5) DD=CMPLX(COS(E),SIN(E)) BK(1)=-DD*QQ-EE*BK(1) BK(2)=DD*GG-EE*BK(2) IF(MAXP.LE.2) GO TO 70 DD=-DD BK(3)=DD*HH-EE*BK(3) IF(MAXP.EQ.3) GO TO 70 C USE FORMULA 9.6.31, RECURRING FORWARD ON K OF ARGUMENT (-Z) DO 28 N=4,MAXP IF(MAX(ABS(REALP(HH)),ABS(AIMAGP(HH))).GT.BIG) GO TO 82 FF=GG GG=HH DD=-DD HH=(ZINV*(A+REAL(N-3)))*GG+FF 28 BK(N)=DD*HH-EE*BK(N) GO TO 70 C FOR LARGE Z, CALCULATE K*S VIA PHASE-AMPLITUDE EQUATION 9.7.2 OF C REFERENCE (1) LISTED IN BESJCF. 30 FF=Z EE=ZINV IF(REALP(Z).LT.0.) FF=-FF IF(REALP(Z).LT.0.) EE=-EE DD=SQRT(.25*PI*EE)*EXP(-FF) C=A R=1. IF(A.GT.0.) R=-1. DO 32 M=1,2 IF(M.EQ.2) C=C+R CALL PHASMP(C,EE,1,PP,QQ) ITEMP = 3 - M 32 BK(ITEMP) = DD * PP IF(REALP(Z).LT.0.) GO TO 26 40 M=3 IF(A.GT.0.) GO TO 60 M=4 IF(MAXP.GE.3) BK(3)=BK(1) BK(1)=BK(1)-(A*ZINV)*BK(2) C CALCULATE K*S VIA FORWARD RECURSION, CHECKING FOR POSSIBLE OVERFLOW 60 IF(M.GT.MAXP) GO TO 70 DO 65 N=M,MAXP IF(MAX(ABS(REALP(BK(N-1))),ABS(AIMAGP(BK(N-1)))).GT.BIG) GO TO 82 65 BK(N)=(ZINV*(A+REAL(N-3)))*BK(N-1)+BK(N-2) 70 RETURN 82 DO 83 M=N,MAXP 83 BK(M) = (0.0, 0.0) GO TO 70 86 CONTINUE WRITE (ICOUT, 88)NMAX CALL DPWRST('XXX','BUG') WRITE (ICOUT, 89)A,Z CALL DPWRST('XXX','BUG') 88 FORMAT('***** ERROR (BESKCF) --- INVALID INPUT, NMAX = ', I6) 89 FORMAT(' A = ', 1PE22.14,' Z = ',2(1PE22.14)) RETURN END SUBROUTINE BESY (X, FNU, N, Y) C***BEGIN PROLOGUE BESY C***PURPOSE Implement forward recursion on the three term recursion C relation for a sequence of non-negative order Bessel C functions Y/SUB(FNU+I-1)/(X), I=1,...,N for real, positive C X and non-negative orders FNU. C***LIBRARY SLATEC C***CATEGORY C10A3 C***TYPE SINGLE PRECISION (BESY-S, DBESY-D) C***KEYWORDS SPECIAL FUNCTIONS, Y BESSEL FUNCTION C***AUTHOR Amos, D. E., (SNLA) C***DESCRIPTION C C Abstract C BESY implements forward recursion on the three term C recursion relation for a sequence of non-negative order Bessel C functions Y/sub(FNU+I-1)/(X), I=1,N for real X .GT. 0.0E0 and C non-negative orders FNU. If FNU .LT. NULIM, orders FNU and C FNU+1 are obtained from BESYNU which computes by a power C series for X .LE. 2, the K Bessel function of an imaginary C argument for 2 .LT. X .LE. 20 and the asymptotic expansion for C X .GT. 20. C C If FNU .GE. NULIM, the uniform asymptotic expansion is coded C in ASYJY for orders FNU and FNU+1 to start the recursion. C NULIM is 70 or 100 depending on whether N=1 or N .GE. 2. An C overflow test is made on the leading term of the asymptotic C expansion before any extensive computation is done. C C Description of Arguments C C Input C X - X .GT. 0.0E0 C FNU - order of the initial Y function, FNU .GE. 0.0E0 C N - number of members in the sequence, N .GE. 1 C C Output C Y - a vector whose first N components contain values C for the sequence Y(I)=Y/sub(FNU+I-1)/(X), I=1,N. C C Error Conditions C Improper input arguments - a fatal error C Overflow - a fatal error C C***REFERENCES F. W. J. Olver, Tables of Bessel Functions of Moderate C or Large Orders, NPL Mathematical Tables 6, Her C Majesty's Stationery Office, London, 1962. C N. M. Temme, On the numerical evaluation of the modified C Bessel function of the third kind, Journal of C Computational Physics 19, (1975), pp. 324-337. C N. M. Temme, On the numerical evaluation of the ordinary C Bessel function of the second kind, Journal of C Computational Physics 21, (1976), pp. 343-350. C***ROUTINES CALLED ASYJY, BESY0, BESY1, BESYNU, I1MACH, R1MACH, C XERMSG, YAIRY C***REVISION HISTORY (YYMMDD) C 800501 DATE WRITTEN C 890531 Changed all specific intrinsics to generic. (WRB) C 890531 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) C 900326 Removed duplicate information from DESCRIPTION section. C (WRB) C 920501 Reformatted the REFERENCES section. (WRB) C***END PROLOGUE BESY C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOMC.INC' CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C EXTERNAL YAIRY, BESY0, BESY1 INTEGER I, IFLW, J, N, NB, ND, NN, NUD, NULIM REAL AZN,CN,DNU,ELIM,FLGJY,FN,FNU,RAN,S,S1,S2,TM,TRX, 1 W,WK,W2N,X,XLIM,XXN,Y REAL BESY0, BESY1 DIMENSION W(2), NULIM(2), Y(*), WK(7) SAVE NULIM DATA NULIM(1),NULIM(2) / 70 , 100 / C***FIRST EXECUTABLE STATEMENT BESY NN = -I1MACH(12) ELIM = 2.303E0*(NN*R1MACH(5)-3.0E0) XLIM = R1MACH(1)*1.0E+3 IF (FNU.LT.0.0E0) GO TO 140 IF (X.LE.0.0E0) GO TO 150 IF (X.LT.XLIM) GO TO 170 IF (N.LT.1) GO TO 160 C C ND IS A DUMMY VARIABLE FOR N C ND = N NUD = INT(FNU) DNU = FNU - NUD NN = MIN(2,ND) FN = FNU + N - 1 IF (FN.LT.2.0E0) GO TO 100 C C OVERFLOW TEST (LEADING EXPONENTIAL OF ASYMPTOTIC EXPANSION) C FOR THE LAST ORDER, FNU+N-1.GE.NULIM C XXN = X/FN W2N = 1.0E0-XXN*XXN IF(W2N.LE.0.0E0) GO TO 10 RAN = SQRT(W2N) AZN = LOG((1.0E0+RAN)/XXN) - RAN CN = FN*AZN IF(CN.GT.ELIM) GO TO 170 10 CONTINUE IF (NUD.LT.NULIM(NN)) GO TO 20 C C ASYMPTOTIC EXPANSION FOR ORDERS FNU AND FNU+1.GE.NULIM C FLGJY = -1.0E0 CALL ASYJY(YAIRY,X,FNU,FLGJY,NN,Y,WK,IFLW) IF(IFLW.NE.0) GO TO 170 IF (NN.EQ.1) RETURN TRX = 2.0E0/X TM = (FNU+FNU+2.0E0)/X GO TO 80 C 20 CONTINUE IF (DNU.NE.0.0E0) GO TO 30 S1 = BESY0(X) IF (NUD.EQ.0 .AND. ND.EQ.1) GO TO 70 S2 = BESY1(X) GO TO 40 30 CONTINUE NB = 2 IF (NUD.EQ.0 .AND. ND.EQ.1) NB = 1 CALL BESYNU(X, DNU, NB, W) S1 = W(1) IF (NB.EQ.1) GO TO 70 S2 = W(2) 40 CONTINUE TRX = 2.0E0/X TM = (DNU+DNU+2.0E0)/X C FORWARD RECUR FROM DNU TO FNU+1 TO GET Y(1) AND Y(2) IF (ND.EQ.1) NUD = NUD - 1 IF (NUD.GT.0) GO TO 50 IF (ND.GT.1) GO TO 70 S1 = S2 GO TO 70 50 CONTINUE DO 60 I=1,NUD S = S2 S2 = TM*S2 - S1 S1 = S TM = TM + TRX 60 CONTINUE IF (ND.EQ.1) S1 = S2 70 CONTINUE Y(1) = S1 IF (ND.EQ.1) RETURN Y(2) = S2 80 CONTINUE IF (ND.EQ.2) RETURN C FORWARD RECUR FROM FNU+2 TO FNU+N-1 DO 90 I=3,ND Y(I) = TM*Y(I-1) - Y(I-2) TM = TM + TRX 90 CONTINUE RETURN C 100 CONTINUE C OVERFLOW TEST IF (FN.LE.1.0E0) GO TO 110 IF (-FN*(LOG(X)-0.693E0).GT.ELIM) GO TO 170 110 CONTINUE IF (DNU.EQ.0.0E0) GO TO 120 CALL BESYNU(X, FNU, ND, Y) RETURN 120 CONTINUE J = NUD IF (J.EQ.1) GO TO 130 J = J + 1 Y(J) = BESY0(X) IF (ND.EQ.1) RETURN J = J + 1 130 CONTINUE Y(J) = BESY1(X) IF (ND.EQ.1) RETURN TRX = 2.0E0/X TM = TRX GO TO 80 C C C 140 CONTINUE WRITE(ICOUT,141) 141 FORMAT('***** ERORR FROM BESY, THE ORDER FNU IS NEGATIVE. ***') CALL DPWRST('XXX','BUG ') RETURN 150 CONTINUE WRITE(ICOUT,151) 151 FORMAT('**** ERORR FROM BESY, X IS LESS THAN OR EQUAL TO ZERO. ') CALL DPWRST('XXX','BUG ') RETURN 160 CONTINUE WRITE(ICOUT,161) 161 FORMAT('***** ERORR FROM BESY, N IS LESS THAN ONE.. ***') CALL DPWRST('XXX','BUG ') RETURN 170 CONTINUE WRITE(ICOUT,171) 171 FORMAT('***** ERORR FROM BESY, OVERFLOW, FNU OR N TOO LARGE OR ', 1 'X TOO SMALL. *****') RETURN END SUBROUTINE BESYNU (X, FNU, N, Y) C***BEGIN PROLOGUE BESYNU C***SUBSIDIARY C***PURPOSE Subsidiary to BESY C***LIBRARY SLATEC C***TYPE SINGLE PRECISION (BESYNU-S, DBSYNU-D) C***AUTHOR Amos, D. E., (SNLA) C***DESCRIPTION C C Abstract C BESYNU computes N member sequences of Y Bessel functions C Y/SUB(FNU+I-1)/(X), I=1,N for non-negative orders FNU and C positive X. Equations of the references are implemented on C small orders DNU for Y/SUB(DNU)/(X) and Y/SUB(DNU+1)/(X). C Forward recursion with the three term recursion relation C generates higher orders FNU+I-1, I=1,...,N. C C To start the recursion FNU is normalized to the interval C -0.5.LE.DNU.LT.0.5. A special form of the power series is C implemented on 0.LT.X.LE.X1 while the Miller algorithm for the C K Bessel function in terms of the confluent hypergeometric C function U(FNU+0.5,2*FNU+1,I*X) is implemented on X1.LT.X.LE.X C Here I is the complex number SQRT(-1.). C For X.GT.X2, the asymptotic expansion for large X is used. C When FNU is a half odd integer, a special formula for C DNU=-0.5 and DNU+1.0=0.5 is used to start the recursion. C C BESYNU assumes that a significant digit SINH(X) function is C available. C C Description of Arguments C C Input C X - X.GT.0.0E0 C FNU - Order of initial Y function, FNU.GE.0.0E0 C N - Number of members of the sequence, N.GE.1 C C Output C Y - A vector whose first N components contain values C for the sequence Y(I)=Y/SUB(FNU+I-1), I=1,N. C C Error Conditions C Improper input arguments - a fatal error C Overflow - a fatal error C C***SEE ALSO BESY C***REFERENCES N. M. Temme, On the numerical evaluation of the ordinary C Bessel function of the second kind, Journal of C Computational Physics 21, (1976), pp. 343-350. C N. M. Temme, On the numerical evaluation of the modified C Bessel function of the third kind, Journal of C Computational Physics 19, (1975), pp. 324-337. C***ROUTINES CALLED GAMMA, R1MACH, XERMSG C***REVISION HISTORY (YYMMDD) C 800501 DATE WRITTEN C 890531 Changed all specific intrinsics to generic. (WRB) C 891214 Prologue converted to Version 4.0 format. (BAB) C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) C 900326 Removed duplicate information from DESCRIPTION section. C (WRB) C 900328 Added TYPE section. (WRB) C 900727 Added EXTERNAL statement. (WRB) C 910408 Updated the AUTHOR and REFERENCES sections. (WRB) C 920501 Reformatted the REFERENCES section. (WRB) C***END PROLOGUE BESYNU C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOMC.INC' CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C INTEGER I, INU, J, K, KK, N, NN REAL A, AK, ARG, A1, A2, BK, CB, CBK, CC, CCK, CK, COEF, CPT, 1 CP1, CP2, CS, CS1, CS2, CX, DNU, DNU2, ETEST, ETX, F, FC, FHS, 2 FK, FKS, FLRX, FMU, FN, FNU, FX, G, G1, G2, HPI, P, PI, PT, Q, 3 RB, RBK, RCK, RELB, RPT, RP1, RP2, RS, RS1, RS2, RTHPI, RX, S, 4 SA, SB, SMU, SS, ST, S1, S2, TB, TM, TOL, T1, T2, X, X1, X2, Y DIMENSION A(120), RB(120), CB(120), Y(*), CC(8) DOUBLE PRECISION DGAMMA EXTERNAL DGAMMA SAVE X1, X2, PI, RTHPI, HPI, CC DATA X1, X2 / 3.0E0, 20.0E0 / DATA PI,RTHPI / 3.14159265358979E+00, 7.97884560802865E-01/ DATA HPI / 1.57079632679490E+00/ DATA CC(1), CC(2), CC(3), CC(4), CC(5), CC(6), CC(7), CC(8) 1 / 5.77215664901533E-01,-4.20026350340952E-02, 2-4.21977345555443E-02, 7.21894324666300E-03,-2.15241674114900E-04, 3-2.01348547807000E-05, 1.13302723200000E-06, 6.11609500000000E-09/ C***FIRST EXECUTABLE STATEMENT BESYNU AK = R1MACH(3) TOL = MAX(AK,1.0E-15) IF (X.LE.0.0E0) GO TO 270 IF (FNU.LT.0.0E0) GO TO 280 IF (N.LT.1) GO TO 290 RX = 2.0E0/X INU = INT(FNU+0.5E0) DNU = FNU - INU IF (ABS(DNU).EQ.0.5E0) GO TO 260 DNU2 = 0.0E0 IF (ABS(DNU).LT.TOL) GO TO 10 DNU2 = DNU*DNU 10 CONTINUE IF (X.GT.X1) GO TO 120 C C SERIES FOR X.LE.X1 C A1 = 1.0E0 - DNU A2 = 1.0E0 + DNU T1 = 1.0E0/REAL(DGAMMA(DBLE(A1))) T2 = 1.0E0/REAL(DGAMMA(DBLE(A2))) IF (ABS(DNU).GT.0.1E0) GO TO 40 C SERIES FOR F0 TO RESOLVE INDETERMINACY FOR SMALL ABS(DNU) S = CC(1) AK = 1.0E0 DO 20 K=2,8 AK = AK*DNU2 TM = CC(K)*AK S = S + TM IF (ABS(TM).LT.TOL) GO TO 30 20 CONTINUE 30 G1 = -(S+S) GO TO 50 40 CONTINUE G1 = (T1-T2)/DNU 50 CONTINUE G2 = T1 + T2 SMU = 1.0E0 FC = 1.0E0/PI FLRX = LOG(RX) FMU = DNU*FLRX TM = 0.0E0 IF (DNU.EQ.0.0E0) GO TO 60 TM = SIN(DNU*HPI)/DNU TM = (DNU+DNU)*TM*TM FC = DNU/SIN(DNU*PI) IF (FMU.NE.0.0E0) SMU = SINH(FMU)/FMU 60 CONTINUE F = FC*(G1*COSH(FMU)+G2*FLRX*SMU) FX = EXP(FMU) P = FC*T1*FX Q = FC*T2/FX G = F + TM*Q AK = 1.0E0 CK = 1.0E0 BK = 1.0E0 S1 = G S2 = P IF (INU.GT.0 .OR. N.GT.1) GO TO 90 IF (X.LT.TOL) GO TO 80 CX = X*X*0.25E0 70 CONTINUE F = (AK*F+P+Q)/(BK-DNU2) P = P/(AK-DNU) Q = Q/(AK+DNU) G = F + TM*Q CK = -CK*CX/AK T1 = CK*G S1 = S1 + T1 BK = BK + AK + AK + 1.0E0 AK = AK + 1.0E0 S = ABS(T1)/(1.0E0+ABS(S1)) IF (S.GT.TOL) GO TO 70 80 CONTINUE Y(1) = -S1 RETURN 90 CONTINUE IF (X.LT.TOL) GO TO 110 CX = X*X*0.25E0 100 CONTINUE F = (AK*F+P+Q)/(BK-DNU2) P = P/(AK-DNU) Q = Q/(AK+DNU) G = F + TM*Q CK = -CK*CX/AK T1 = CK*G S1 = S1 + T1 T2 = CK*(P-AK*G) S2 = S2 + T2 BK = BK + AK + AK + 1.0E0 AK = AK + 1.0E0 S = ABS(T1)/(1.0E0+ABS(S1)) + ABS(T2)/(1.0E0+ABS(S2)) IF (S.GT.TOL) GO TO 100 110 CONTINUE S2 = -S2*RX S1 = -S1 GO TO 160 120 CONTINUE COEF = RTHPI/SQRT(X) IF (X.GT.X2) GO TO 210 C C MILLER ALGORITHM FOR X1.LT.X.LE.X2 C ETEST = COS(PI*DNU)/(PI*X*TOL) FKS = 1.0E0 FHS = 0.25E0 FK = 0.0E0 RCK = 2.0E0 CCK = X + X RP1 = 0.0E0 CP1 = 0.0E0 RP2 = 1.0E0 CP2 = 0.0E0 K = 0 130 CONTINUE K = K + 1 FK = FK + 1.0E0 AK = (FHS-DNU2)/(FKS+FK) PT = FK + 1.0E0 RBK = RCK/PT CBK = CCK/PT RPT = RP2 CPT = CP2 RP2 = RBK*RPT - CBK*CPT - AK*RP1 CP2 = CBK*RPT + RBK*CPT - AK*CP1 RP1 = RPT CP1 = CPT RB(K) = RBK CB(K) = CBK A(K) = AK RCK = RCK + 2.0E0 FKS = FKS + FK + FK + 1.0E0 FHS = FHS + FK + FK PT = MAX(ABS(RP1),ABS(CP1)) FC = (RP1/PT)**2 + (CP1/PT)**2 PT = PT*SQRT(FC)*FK IF (ETEST.GT.PT) GO TO 130 KK = K RS = 1.0E0 CS = 0.0E0 RP1 = 0.0E0 CP1 = 0.0E0 RP2 = 1.0E0 CP2 = 0.0E0 DO 140 I=1,K RPT = RP2 CPT = CP2 RP2 = (RB(KK)*RPT-CB(KK)*CPT-RP1)/A(KK) CP2 = (CB(KK)*RPT+RB(KK)*CPT-CP1)/A(KK) RP1 = RPT CP1 = CPT RS = RS + RP2 CS = CS + CP2 KK = KK - 1 140 CONTINUE PT = MAX(ABS(RS),ABS(CS)) FC = (RS/PT)**2 + (CS/PT)**2 PT = PT*SQRT(FC) RS1 = (RP2*(RS/PT)+CP2*(CS/PT))/PT CS1 = (CP2*(RS/PT)-RP2*(CS/PT))/PT FC = HPI*(DNU-0.5E0) - X P = COS(FC) Q = SIN(FC) S1 = (CS1*Q-RS1*P)*COEF IF (INU.GT.0 .OR. N.GT.1) GO TO 150 Y(1) = S1 RETURN 150 CONTINUE PT = MAX(ABS(RP2),ABS(CP2)) FC = (RP2/PT)**2 + (CP2/PT)**2 PT = PT*SQRT(FC) RPT = DNU + 0.5E0 - (RP1*(RP2/PT)+CP1*(CP2/PT))/PT CPT = X - (CP1*(RP2/PT)-RP1*(CP2/PT))/PT CS2 = CS1*CPT - RS1*RPT RS2 = RPT*CS1 + RS1*CPT S2 = (RS2*Q+CS2*P)*COEF/X C C FORWARD RECURSION ON THE THREE TERM RECURSION RELATION C 160 CONTINUE CK = (DNU+DNU+2.0E0)/X IF (N.EQ.1) INU = INU - 1 IF (INU.GT.0) GO TO 170 IF (N.GT.1) GO TO 190 S1 = S2 GO TO 190 170 CONTINUE DO 180 I=1,INU ST = S2 S2 = CK*S2 - S1 S1 = ST CK = CK + RX 180 CONTINUE IF (N.EQ.1) S1 = S2 190 CONTINUE Y(1) = S1 IF (N.EQ.1) RETURN Y(2) = S2 IF (N.EQ.2) RETURN DO 200 I=3,N Y(I) = CK*Y(I-1) - Y(I-2) CK = CK + RX 200 CONTINUE RETURN C C ASYMPTOTIC EXPANSION FOR LARGE X, X.GT.X2 C 210 CONTINUE NN = 2 IF (INU.EQ.0 .AND. N.EQ.1) NN = 1 DNU2 = DNU + DNU FMU = 0.0E0 IF (ABS(DNU2).LT.TOL) GO TO 220 FMU = DNU2*DNU2 220 CONTINUE ARG = X - HPI*(DNU+0.5E0) SA = SIN(ARG) SB = COS(ARG) ETX = 8.0E0*X DO 250 K=1,NN S1 = S2 T2 = (FMU-1.0E0)/ETX SS = T2 RELB = TOL*ABS(T2) T1 = ETX S = 1.0E0 FN = 1.0E0 AK = 0.0E0 DO 230 J=1,13 T1 = T1 + ETX AK = AK + 8.0E0 FN = FN + AK T2 = -T2*(FMU-FN)/T1 S = S + T2 T1 = T1 + ETX AK = AK + 8.0E0 FN = FN + AK T2 = T2*(FMU-FN)/T1 SS = SS + T2 IF (ABS(T2).LE.RELB) GO TO 240 230 CONTINUE 240 S2 = COEF*(S*SA+SS*SB) FMU = FMU + 8.0E0*DNU + 4.0E0 TB = SA SA = -SB SB = TB 250 CONTINUE IF (NN.GT.1) GO TO 160 S1 = S2 GO TO 190 C C FNU=HALF ODD INTEGER CASE C 260 CONTINUE COEF = RTHPI/SQRT(X) S1 = COEF*SIN(X) S2 = -COEF*COS(X) GO TO 160 C C 270 CONTINUE WRITE(ICOUT,271) 271 FORMAT('**** ERORR FROM BESYNU, X IS NOT POSITIVE.') CALL DPWRST('XXX','BUG ') RETURN 280 CONTINUE WRITE(ICOUT,281) 281 FORMAT('***** ERORR FROM BESYNU, THE ORDER FNU IS NEGATIVE. ***') CALL DPWRST('XXX','BUG ') RETURN 290 CONTINUE WRITE(ICOUT,291) 291 FORMAT('***** ERORR FROM BESYNU, N IS LESS THAN ONE.. ***') CALL DPWRST('XXX','BUG ') RETURN END FUNCTION BESY0 (X) C***BEGIN PROLOGUE BESY0 C***PURPOSE Compute the Bessel function of the second kind of order C zero. C***LIBRARY SLATEC (FNLIB) C***CATEGORY C10A1 C***TYPE SINGLE PRECISION (BESY0-S, DBESY0-D) C***KEYWORDS BESSEL FUNCTION, FNLIB, ORDER ZERO, SECOND KIND, C SPECIAL FUNCTIONS C***AUTHOR Fullerton, W., (LANL) C***DESCRIPTION C C BESY0(X) calculates the Bessel function of the second kind C of order zero for real argument X. C C Series for BY0 on the interval 0. to 1.60000D+01 C with weighted error 1.20E-17 C log weighted error 16.92 C significant figures required 16.15 C decimal places required 17.48 C C Series for BM0 on the interval 0. to 6.25000D-02 C with weighted error 4.98E-17 C log weighted error 16.30 C significant figures required 14.97 C decimal places required 16.96 C C Series for BTH0 on the interval 0. to 6.25000D-02 C with weighted error 3.67E-17 C log weighted error 16.44 C significant figures required 15.53 C decimal places required 17.13 C C***REFERENCES (NONE) C***ROUTINES CALLED BESJ0, CSEVL, INITS, R1MACH, XERMSG C***REVISION HISTORY (YYMMDD) C 770401 DATE WRITTEN C 890531 Changed all specific intrinsics to generic. (WRB) C 890531 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) C 900326 Removed duplicate information from DESCRIPTION section. C (WRB) C***END PROLOGUE BESY0 C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOMC.INC' CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C EXTERNAL BESJ0, CSEVL C DIMENSION BY0CS(13), BM0CS(21), BTH0CS(24) LOGICAL FIRST SAVE BY0CS, BM0CS, BTH0CS, TWODPI, PI4, 1 NTY0, NTM0, NTTH0, XSML, XMAX, FIRST DATA BY0CS( 1) / -.0112778393 92865573E0 / DATA BY0CS( 2) / -.1283452375 6042035E0 / DATA BY0CS( 3) / -.1043788479 9794249E0 / DATA BY0CS( 4) / .0236627491 83969695E0 / DATA BY0CS( 5) / -.0020903916 47700486E0 / DATA BY0CS( 6) / .0001039754 53939057E0 / DATA BY0CS( 7) / -.0000033697 47162423E0 / DATA BY0CS( 8) / .0000000772 93842676E0 / DATA BY0CS( 9) / -.0000000013 24976772E0 / DATA BY0CS(10) / .0000000000 17648232E0 / DATA BY0CS(11) / -.0000000000 00188105E0 / DATA BY0CS(12) / .0000000000 00001641E0 / DATA BY0CS(13) / -.0000000000 00000011E0 / DATA BM0CS( 1) / .0928496163 7381644E0 / DATA BM0CS( 2) / -.0014298770 7403484E0 / DATA BM0CS( 3) / .0000283057 9271257E0 / DATA BM0CS( 4) / -.0000014330 0611424E0 / DATA BM0CS( 5) / .0000001202 8628046E0 / DATA BM0CS( 6) / -.0000000139 7113013E0 / DATA BM0CS( 7) / .0000000020 4076188E0 / DATA BM0CS( 8) / -.0000000003 5399669E0 / DATA BM0CS( 9) / .0000000000 7024759E0 / DATA BM0CS(10) / -.0000000000 1554107E0 / DATA BM0CS(11) / .0000000000 0376226E0 / DATA BM0CS(12) / -.0000000000 0098282E0 / DATA BM0CS(13) / .0000000000 0027408E0 / DATA BM0CS(14) / -.0000000000 0008091E0 / DATA BM0CS(15) / .0000000000 0002511E0 / DATA BM0CS(16) / -.0000000000 0000814E0 / DATA BM0CS(17) / .0000000000 0000275E0 / DATA BM0CS(18) / -.0000000000 0000096E0 / DATA BM0CS(19) / .0000000000 0000034E0 / DATA BM0CS(20) / -.0000000000 0000012E0 / DATA BM0CS(21) / .0000000000 0000004E0 / DATA BTH0CS( 1) / -.2463916377 4300119E0 / DATA BTH0CS( 2) / .0017370983 07508963E0 / DATA BTH0CS( 3) / -.0000621836 33402968E0 / DATA BTH0CS( 4) / .0000043680 50165742E0 / DATA BTH0CS( 5) / -.0000004560 93019869E0 / DATA BTH0CS( 6) / .0000000621 97400101E0 / DATA BTH0CS( 7) / -.0000000103 00442889E0 / DATA BTH0CS( 8) / .0000000019 79526776E0 / DATA BTH0CS( 9) / -.0000000004 28198396E0 / DATA BTH0CS(10) / .0000000001 02035840E0 / DATA BTH0CS(11) / -.0000000000 26363898E0 / DATA BTH0CS(12) / .0000000000 07297935E0 / DATA BTH0CS(13) / -.0000000000 02144188E0 / DATA BTH0CS(14) / .0000000000 00663693E0 / DATA BTH0CS(15) / -.0000000000 00215126E0 / DATA BTH0CS(16) / .0000000000 00072659E0 / DATA BTH0CS(17) / -.0000000000 00025465E0 / DATA BTH0CS(18) / .0000000000 00009229E0 / DATA BTH0CS(19) / -.0000000000 00003448E0 / DATA BTH0CS(20) / .0000000000 00001325E0 / DATA BTH0CS(21) / -.0000000000 00000522E0 / DATA BTH0CS(22) / .0000000000 00000210E0 / DATA BTH0CS(23) / -.0000000000 00000087E0 / DATA BTH0CS(24) / .0000000000 00000036E0 / DATA TWODPI / 0.6366197723 6758134E0 / DATA PI4 / 0.7853981633 9744831E0 / DATA FIRST /.TRUE./ C***FIRST EXECUTABLE STATEMENT BESY0 IF (FIRST) THEN NTY0 = INITS (BY0CS, 13, 0.1*R1MACH(3)) NTM0 = INITS (BM0CS, 21, 0.1*R1MACH(3)) NTTH0 = INITS (BTH0CS, 24, 0.1*R1MACH(3)) C XSML = SQRT (4.0*R1MACH(3)) XMAX = 1.0/R1MACH(4) ENDIF FIRST = .FALSE. C IF (X .LE. 0.) THEN WRITE(ICOUT,1) 1 FORMAT('***** ERORR FROM BESY0, X ZERO OR NEGATIVE. *******') CALL DPWRST('XXX','BUG ') BESY0=0.0 RETURN ENDIF IF (X.GT.4.0) GO TO 20 C Y = 0. IF (X.GT.XSML) Y = X*X BESY0 = TWODPI*LOG(0.5*X)*BESJ0(X) + .375 + CSEVL (.125*Y-1., 1 BY0CS, NTY0) RETURN C 20 CONTINUE IF (X.GT.XMAX) THEN WRITE(ICOUT,2) CALL DPWRST('XXX','BUG ') BESY0 = 0.0 RETURN ENDIF 2 FORMAT('***** ERORR FROM BESY0, NO PRECISION BECAUSE THE ', 1 'VALUE OF X IS TOO BIG. ****') C Z = 32.0/X**2 - 1.0 AMPL = (0.75 + CSEVL (Z, BM0CS, NTM0)) / SQRT(X) THETA = X - PI4 + CSEVL (Z, BTH0CS, NTTH0) / X BESY0 = AMPL * SIN (THETA) C RETURN END FUNCTION BESY1 (X) C***BEGIN PROLOGUE BESY1 C***PURPOSE Compute the Bessel function of the second kind of order C one. C***LIBRARY SLATEC (FNLIB) C***CATEGORY C10A1 C***TYPE SINGLE PRECISION (BESY1-S, DBESY1-D) C***KEYWORDS BESSEL FUNCTION, FNLIB, ORDER ONE, SECOND KIND, C SPECIAL FUNCTIONS C***AUTHOR Fullerton, W., (LANL) C***DESCRIPTION C C BESY1(X) calculates the Bessel function of the second kind of C order one for real argument X. C C Series for BY1 on the interval 0. to 1.60000D+01 C with weighted error 1.87E-18 C log weighted error 17.73 C significant figures required 17.83 C decimal places required 18.30 C C Series for BM1 on the interval 0. to 6.25000D-02 C with weighted error 5.61E-17 C log weighted error 16.25 C significant figures required 14.97 C decimal places required 16.91 C C Series for BTH1 on the interval 0. to 6.25000D-02 C with weighted error 4.10E-17 C log weighted error 16.39 C significant figures required 15.96 C decimal places required 17.08 C C***REFERENCES (NONE) C***ROUTINES CALLED BESJ1, CSEVL, INITS, R1MACH, XERMSG C***REVISION HISTORY (YYMMDD) C 770401 DATE WRITTEN C 890531 Changed all specific intrinsics to generic. (WRB) C 890531 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) C 900326 Removed duplicate information from DESCRIPTION section. C (WRB) C***END PROLOGUE BESY1 C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOMC.INC' CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C EXTERNAL BESJ1, CSEVL C DIMENSION BY1CS(14), BM1CS(21), BTH1CS(24) LOGICAL FIRST SAVE BY1CS, BM1CS, BTH1CS, TWODPI, PI4, 1 NTY1, NTM1, NTTH1, XMIN, XSML, XMAX, FIRST DATA BY1CS( 1) / .0320804710 0611908629E0 / DATA BY1CS( 2) / 1.2627078974 33500450E0 / DATA BY1CS( 3) / .0064999618 9992317500E0 / DATA BY1CS( 4) / -.0893616452 8860504117E0 / DATA BY1CS( 5) / .0132508812 2175709545E0 / DATA BY1CS( 6) / -.0008979059 1196483523E0 / DATA BY1CS( 7) / .0000364736 1487958306E0 / DATA BY1CS( 8) / -.0000010013 7438166600E0 / DATA BY1CS( 9) / .0000000199 4539657390E0 / DATA BY1CS(10) / -.0000000003 0230656018E0 / DATA BY1CS(11) / .0000000000 0360987815E0 / DATA BY1CS(12) / -.0000000000 0003487488E0 / DATA BY1CS(13) / .0000000000 0000027838E0 / DATA BY1CS(14) / -.0000000000 0000000186E0 / DATA BM1CS( 1) / .1047362510 931285E0 / DATA BM1CS( 2) / .0044244389 3702345E0 / DATA BM1CS( 3) / -.0000566163 9504035E0 / DATA BM1CS( 4) / .0000023134 9417339E0 / DATA BM1CS( 5) / -.0000001737 7182007E0 / DATA BM1CS( 6) / .0000000189 3209930E0 / DATA BM1CS( 7) / -.0000000026 5416023E0 / DATA BM1CS( 8) / .0000000004 4740209E0 / DATA BM1CS( 9) / -.0000000000 8691795E0 / DATA BM1CS(10) / .0000000000 1891492E0 / DATA BM1CS(11) / -.0000000000 0451884E0 / DATA BM1CS(12) / .0000000000 0116765E0 / DATA BM1CS(13) / -.0000000000 0032265E0 / DATA BM1CS(14) / .0000000000 0009450E0 / DATA BM1CS(15) / -.0000000000 0002913E0 / DATA BM1CS(16) / .0000000000 0000939E0 / DATA BM1CS(17) / -.0000000000 0000315E0 / DATA BM1CS(18) / .0000000000 0000109E0 / DATA BM1CS(19) / -.0000000000 0000039E0 / DATA BM1CS(20) / .0000000000 0000014E0 / DATA BM1CS(21) / -.0000000000 0000005E0 / DATA BTH1CS( 1) / .7406014102 6313850E0 / DATA BTH1CS( 2) / -.0045717556 59637690E0 / DATA BTH1CS( 3) / .0001198185 10964326E0 / DATA BTH1CS( 4) / -.0000069645 61891648E0 / DATA BTH1CS( 5) / .0000006554 95621447E0 / DATA BTH1CS( 6) / -.0000000840 66228945E0 / DATA BTH1CS( 7) / .0000000133 76886564E0 / DATA BTH1CS( 8) / -.0000000024 99565654E0 / DATA BTH1CS( 9) / .0000000005 29495100E0 / DATA BTH1CS(10) / -.0000000001 24135944E0 / DATA BTH1CS(11) / .0000000000 31656485E0 / DATA BTH1CS(12) / -.0000000000 08668640E0 / DATA BTH1CS(13) / .0000000000 02523758E0 / DATA BTH1CS(14) / -.0000000000 00775085E0 / DATA BTH1CS(15) / .0000000000 00249527E0 / DATA BTH1CS(16) / -.0000000000 00083773E0 / DATA BTH1CS(17) / .0000000000 00029205E0 / DATA BTH1CS(18) / -.0000000000 00010534E0 / DATA BTH1CS(19) / .0000000000 00003919E0 / DATA BTH1CS(20) / -.0000000000 00001500E0 / DATA BTH1CS(21) / .0000000000 00000589E0 / DATA BTH1CS(22) / -.0000000000 00000237E0 / DATA BTH1CS(23) / .0000000000 00000097E0 / DATA BTH1CS(24) / -.0000000000 00000040E0 / DATA TWODPI / 0.6366197723 6758134E0 / DATA PI4 / 0.7853981633 9744831E0 / DATA FIRST /.TRUE./ C***FIRST EXECUTABLE STATEMENT BESY1 IF (FIRST) THEN NTY1 = INITS (BY1CS, 14, 0.1*R1MACH(3)) NTM1 = INITS (BM1CS, 21, 0.1*R1MACH(3)) NTTH1 = INITS (BTH1CS, 24, 0.1*R1MACH(3)) C XMIN = 1.571*EXP ( MAX(LOG(R1MACH(1)), -LOG(R1MACH(2)))+.01) XSML = SQRT (4.0*R1MACH(3)) XMAX = 1.0/R1MACH(4) ENDIF FIRST = .FALSE. C IF (X .LE. 0.) THEN WRITE(ICOUT,1) 1 FORMAT('***** ERORR FROM BESY1, X ZERO OR NEGATIVE. *******') CALL DPWRST('XXX','BUG ') BESY1=0.0 RETURN ENDIF IF (X.GT.4.0) GO TO 20 C IF (X .LE. XMIN) THEN WRITE(ICOUT,2) CALL DPWRST('XXX','BUG ') ENDIF 2 FORMAT('***** WARNING FROM BESY1, UNDERFLOW BECAUSE THE ', 1 'VALUE OF X IS SO SMALL. ****') Y = 0. IF (X.GT.XSML) Y = X*X BESY1 = TWODPI*LOG(0.5*X)*BESJ1(X) + 1 (0.5 + CSEVL (.125*Y-1., BY1CS, NTY1))/X RETURN C 20 CONTINUE IF (X.GT.XMAX) THEN WRITE(ICOUT,3) CALL DPWRST('XXX','BUG ') BESY1 = 0.0 RETURN ENDIF 3 FORMAT('***** ERORR FROM BESY1, NO PRECISION BECAUSE THE ', 1 'VALUE OF X IS TOO BIG. ****') C Z = 32.0/X**2 - 1.0 AMPL = (0.75 + CSEVL (Z, BM1CS, NTM1)) / SQRT(X) THETA = X - 3.0*PI4 + CSEVL (Z, BTH1CS, NTTH1) / X BESY1 = AMPL * SIN (THETA) C RETURN END SUBROUTINE BESYCF(ZZ,AA,NMAX,BY) C THIS ROUTINE CALCULATES BESSEL FUNCTIONS Y OF COMPLEX ARGUMENT AND C REAL ORDER. ARGUMENTS ARE AS FOR ROUTINE BESJCF. C Y*S ARE CALCULATED BY FORWARD RECURSION, USING EQUATION 9.1.27 OF C REFERENCE (1) LISTED IN BESJCF. TO START THE RECURSION, FUNCTION C VALUES OF ORDERS A AND A+1 ARE CALCULATED IF A.LE.0, WHILE ORDERS A C AND A-1 ARE CALCULATED IF A.GT.0. C NOTE IF ANY Y-VALUE IS SO BIG THAT ITS CALCULATION WOULD CAUSE OVER- C FLOW, IT (AND ALL HIGHER ORDERS) ARE SET TO ZERO. C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOMC.INC' CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C COMPLEX BY(*),BB,CC,DD,EE,FF,GG,HH,PP,QQ,SS,YA(21),YA1(21),Z,ZINV, 1 ZZ,ZDUMMY DOUBLE PRECISION PIDBL C----------------------------------------------------------------------- C C MACHINE DEPENDENT CONSTANTS. C --------------------------- C SAVE ISAVE,PI,PINV,PIDBL,GADOL,EXPARG,DYOUK,DYOUKH,NTERM,LOU DATA ISAVE /1/ C C Definition of real and imaginary parts of complex number, C standard Fortran and will work on Convex with -r8 -i8. REALP(ZDUMMY) = REAL(ZDUMMY) AIMAGP(ZDUMMY) = REAL((0,-1)*ZDUMMY) C IF (ISAVE.GT.0) THEN ISAVE = 0 C PI AND 1/PI PI = 4.0*ATAN (1.0) PINV = 1.0 / PI PIDBL = 4.0D0 * ATAN (1.0D0) C MACHINE-DEPENDENT CONSTANTS LARGEST REAL NUMBER (APPROX), LIMIT ON C ARGUMENT TO LIBRARY EXP ROUTINE, MACHINE ACCURACY, ITS SQUARE ROOT, C AND LENGTH OF VECTORS YA1 AND YA, MINUS 1. FOR ABS(Z).LE.3, 21 TERMS C ARE SUFFICIENT FOR 14 SIGNIFICANT FIGURE (SEE REFERENCE LISTED BELOW). GADOL = R1MACH (2) EXPARG = LOG (GADOL) DYOUK = R1MACH (4) DYOUKH = SQRT (DYOUK) NTERM = 20 LOU = I1MACH(2) ENDIF C C----------------------------------------------------------------------- Z=ZZ A=AA MAXP=NMAX+2 Q=REALP(Z) R=ABS(AIMAGP(Z)) E=Q*Q+R*R IF ((A. LE. - 0.5) .OR. (A .GT. 0.5) .OR. (MAXP .LT. 2) .OR. * (E .EQ. 0.0) .OR. (R. GT. EXPARG)) GO TO 86 F=SQRT(E) BIG=GADOL*MIN(.25,F/REAL(4*MAX(1,NMAX))) C AVOID UNDERFLOW OR OVERFLOW IN COMPLEX DIVIDE F=1./F ZINV=2.*F/(Z*F) C Following statement rewritten to make compilation possible C on Convex with -r8 -i8. C IF(MIN(R,REAL(MAXP)).GT.3.) GO TO 20 IF(R.GT.3.0 .AND. MAXP.GT.3) GO TO 20 IF(E.GE.196.) GO TO 30 IF(E.GE.9.) GO TO 20 C FOR SMALL Z, Y IS CALCULATED VIA EQUATIONS 2.1 OR N. M. TEMME, ON THE C NUMERICAL EVALUATION OF THE ORDINARY BESSEL FUNCTION OF THE SECOND C KIND, REPORT TW152/75, STICHTING MATHEMATISCH CENTRUM, AMSTERDAM, 9/75 BB=.5*Z DD=-LOG(BB) EE=A*DD C=PINV IF(ABS(A).GT.DYOUKH) C=A/SIN(PI*A) SS = (1.0, 0.0) IF ((REALP (EE) ** 2 + AIMAGP (EE) ** 2) .GT. DYOUK) * SS = CMPLX (0.0, - 1.0) * SIN (CMPLX (0.0, 1.0) * EE) / EE EE=EXP(EE) CALL RECIPG(A,P,Q,G) GG=G*EE EE=.5*(EE+1./EE) FF=(2.*C)*(P*EE+Q*SS*DD) E=A*A PP=C*GG QQ=PINV/GG C=.5*PI*A R=1. IF(ABS(C).GT.DYOUKH) R=SIN(C)/C R=PI*C*R*R CC = (1.0, 0.0) DD=-BB*BB GG=FF+R*QQ C=0. IF(A.NE..5) C=DCOS(PIDBL*DBLE(A)) IF(C.LE..5) GG=(PP-QQ*C)/A YA(1)=GG C IF A.LE.0, CALCULATE YA1=YSUB(A+1) AS IN THE REFERENCE YA1(1)=PP C IF A.GT.0, CALCULATE YA1=YSUB(A-1)=SUM(N=0 TO INFINITY) OF C CN*(N*GN-QN*COSPI*A), WHICH CAN BE DERIVED BY SUBSTITUTING 2.2 AND 2.3 C OF THE REFERENCE INTO 1.3. IF(A.GT.0.) YA1(1)=-C*QQ TEST =DYOUK*MAX(ABS(REALP(YA(1))),ABS(AIMAGP(YA(1)))) DO 10 N=1,NTERM EN=N G=1./(EN*EN-E) IF(A.GT.0.) GO TO 6 C RECUR DIRECTLY ON GG AND HH WITHOUT USING FF AS IN THE ORIGINAL PROG. HH=-G*(EN*(EN*GG+C*QQ)-A*PP) GO TO 8 6 HH= G*(EN*(EN*GG+PP)+A*C*QQ) 8 GG=G*(EN*GG+PP+C*QQ) CC=CC*DD/EN YA(N+1)=CC*GG YA1(N+1)=CC*HH IF(MAX(ABS(REALP(YA(N+1))),ABS(AIMAGP(YA(N+1)))).LE.TEST)GOTO12 PP=PP/(EN-A) 10 QQ=QQ/(EN+A) RETURN 12 N=N+1 M=N+1 GG = (0.0, 0.0) HH = (0.0, 0.0) DO 14 L=1,N ITEMP = M - L GG=GG+YA(ITEMP) 14 HH=HH+YA1(ITEMP) BY(2)=-GG BY(1)=-HH*ZINV M=3 IF(A) 40,40,60 C FOR MAG(Z) BETWEEN 3 AND 14, OR FOR ABS(IM(Z)).GT.3, CALCULATE Y VIA C EQUATIONS 9.6.3 AND 9.6.5 OF REFERENCE 1 LISTED IN BESJCF 20 CALL BESJCF(Z,A,NMAX,BY) C=-1. IF(AIMAGP(Z).LT.0.) C=1. CC=CMPLX(0.,C) DD=CC*Z CALL BESKCF(DD,A,1,YA1) C=.5*C*PI*A DD=2.*PINV*CMPLX(COS(C),SIN(C)) BY(1)=CC*(DD*YA1(1)-BY(1)) GG=YA1(2) BY(2)=-CC*BY(2)-DD*GG IF(MAXP.LE.2) GO TO 70 HH=YA1(3) DD=CC*DD BY(3)=-CC*BY(3)-DD*HH IF(MAXP.EQ.3) GO TO 70 ZINV=-CC*ZINV C IN THIS LOOP, HH IS THE FUNCTION K (OF ARGUMENT IZ OR -IZ) AND CAN BE C CALCULATED BY FORWARD RECURSION, SINCE THE REAL PART OF THE ARGUMENT C IS NON-NEGATIVE DO 24 N=4,MAXP IF(MAX(ABS(REALP(HH)),ABS(AIMAGP(HH))).GT.BIG) GO TO 82 FF=GG GG=HH DD=CC*DD HH=(ZINV*(A+REAL(N-3)))*GG+FF 24 BY(N)=-CC*BY(N)-DD*HH GO TO 70 C FOR LARGE Z, USE PHASE-AMPLITUDE EQUATIONS 9.2.5 AND 9.2.6 OF REFER- C ENCE 1 AS LISTED IN BESJCF 30 BB=Z EE=ZINV C Set FF and GG here to avoid Univac FTN compiler warnings C that arise due to logic here and in 38-loop below. FF = (0.0,0.0) GG = (0.0,0.0) IF(REALP(Z).GE.0.) GO TO 32 BB=-BB EE=-EE E=1. IF(AIMAGP(Z).LT.0.) E=-1. C=0. IF(A.NE..5) C=DCOS(PIDBL*DBLE(A)) S=SIN(-E*A*PI) FF=CMPLX(C,S) GG=CMPLX(0.,2.*E*C) 32 BB=BB-.5*PI*(A+.5) CC=COS(BB) SS=SIN(BB) DD=SQRT(PINV*EE) C=A DO 38 M=1,2 CALL PHASMP(C,EE,0,PP,QQ) IF(REALP(Z).LT.0.) GO TO 34 C REAL(Z).GE.0, SO USE EQUATION 9.2.6 ITEMP = 3 - M BY(ITEMP)=DD*(PP*SS+QQ*CC) IF(M-1) 36,36,38 C REAL(Z).LT.0, SO SUBSTITUTE 9.2.5 AND 9.2.6 INTO 9.1.36 34 PP=PP*(FF*SS+GG*CC) QQ=QQ*(FF*CC-GG*SS) ITEMP = 3 - M BY(ITEMP)=DD*(PP+QQ) IF(M.EQ.2) GO TO 38 FF=-FF GG=-GG 36 IF(A.GT.0.) GO TO 37 C=C+1. BB=-CC CC=SS SS=BB GO TO 38 37 C=C-1. BB=-SS SS=CC CC=BB 38 CONTINUE M=3 IF(A.GT.0.) GO TO 60 40 IF(MAXP.GE.3) BY(3)=BY(1) BY(1)=(A*ZINV)*BY(2)-BY(1) M=4 C CALCULATE Y*S BY FORWARD RECURSION, CHECKING FOR POSSIBLE OVERFLOW 60 IF(M.GT.MAXP) GO TO 70 DO 65 N=M,MAXP IF(MAX(ABS(REALP(BY(N-1))),ABS(AIMAGP(BY(N-1)))).GT.BIG) GO TO 82 65 BY(N)=(ZINV*(A+REAL(N-3)))*BY(N-1)-BY(N-2) 70 RETURN 82 DO 83 L=N,MAXP 83 BY(L) = (0.0, 0.0) GO TO 70 86 CONTINUE WRITE (ICOUT, 88)NMAX CALL DPWRST('XXX','BUG') WRITE (ICOUT, 89)A,Z CALL DPWRST('XXX','BUG') 88 FORMAT('***** ERROR (BESYCF) --- INVALID INPUT, NMAX = ', I6) 89 FORMAT(' A = ', 1PE22.14,' Z = ',2(1PE22.14)) RETURN END SUBROUTINE BETCDF(X,ALPHA,BETA,CDF) C C NOTE--ALGORITHM ADDED SEPTEMBER 1994 (ALAN) C USE DBETAI ROUTINE FROM SLATEC. THIS USES THE C BOSTEN AND BATTISTE ALGORITHM. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-921-3651 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--94/8 C ORIGINAL VERSION--SEPTEMBER 1994. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C DOUBLE PRECISION DCDF DOUBLE PRECISION DALPHA DOUBLE PRECISION DBETA DOUBLE PRECISION DX DOUBLE PRECISION DBETAI C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IF(ALPHA.LE.0.0 .OR. BETA.LE.0.0)THEN WRITE(ICOUT,101) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,102) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,103)ALPHA CALL DPWRST('XXX','BUG ') WRITE(ICOUT,104)BETA CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF IF(X.LT.0.0)THEN WRITE(ICOUT,301) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,302)X CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF IF(X.GT.1.0)THEN WRITE(ICOUT,401) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,402)X CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF 101 FORMAT('***** FATAL DIAGNOSTIC--EITHER THE ALPHA OR BETA IS') 102 FORMAT(' NON-POSITIVE.') 103 FORMAT(' THE VALUE OF ALPHA IS ',E15.7) 104 FORMAT(' THE VALUE OF BETA IS ',E15.7,' ******') 301 FORMAT('***** FATAL DIAGNOSTIC--THE INPUT ARGUMENT IS ') 302 FORMAT(' NON-POSITIVE. IT HAS THE VALUE ',E15.7) 401 FORMAT('***** FATAL DIAGNOSTIC--THE INPUT ARGUMENT IS GRETATER') 402 FORMAT(' THAN 1. IT HAS THE VALUE ',E15.7) C IF(X.LE.0.)THEN CDF=0.0 GOTO9999 ELSEIF(X.GE.1)THEN CDF=1.0 GOTO9999 ENDIF C DX=DBLE(X) DALPHA=DBLE(ALPHA) DBETA=DBLE(BETA) DCDF=DBETAI(DX,DALPHA,DBETA) CDF=REAL(DCDF) C 9999 CONTINUE RETURN END DOUBLE PRECISION FUNCTION BETFU2 (DALPHA,DX) C C PURPOSE--THIS ROUTINE IS USED IN FINDING THE LIKELIHOOD RATIO C BASED CONFIDECE INTERVAL FOR THE 2-PARAMETER BETA C MODEL (FULL SAMPLE). THIS FUNCTION FINDS THE ROOT C OF THE EQUATION: C C 2*LL(ALPHA,BETA) - 2*LL(ALPHA,BETA(ALPHA)) - C CHSPPF(alpha,1) C C WITH C C LL(ALPHA,BETA) = -N*LOG(BETA(ALPHA,BETA)) + C N*(ALPHA-1)*S3 +N*(BETA-1)*S4 C C GIVEN CURRENT VALUE OF ALPHA, WE COMPUTE VALUE OF C BETA(ALPHA). WE THEN COMPUTE THE LIKELIHOOD FUNCTION. C NOTE THAT LL(ALPHA,BETA) IS COMPUTED ONCE IN DPMLBE C AND PASSED VIA COMMON. C C CALLED BY DFZER2 ROUTINE FOR FINDING THE ROOT OF A C FUNCTION. C C EXAMPLE--BETA MAXIMUM LIKELIHOOD Y C REFERENCE--KARL BURY, "STATISTICAL DISTRIBUTIONS IN ENGINEERING", C CAMBRIDGE UNIVERSITY PRESS, 1999, CHAPTER 13 (SEE C EXAMPLE 13.3). C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBUG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2004/12 C ORIGINAL VERSION--DECEMBER 2004. C C--------------------------------------------------------------------- C DOUBLE PRECISION DALPHA DOUBLE PRECISION DX(*) C INTEGER N DOUBLE PRECISION DSUM3 DOUBLE PRECISION DSUM4 DOUBLE PRECISION DLLAB DOUBLE PRECISION DK COMMON/BETCO9/DSUM3,DSUM4,DLLAB,DK,N C DOUBLE PRECISION DBETA COMMON/BETCO2/DBETA C DOUBLE PRECISION DALPH2 COMMON/BETCO4/DALPH2 C DOUBLE PRECISION DLBETA EXTERNAL DLBETA DOUBLE PRECISION BETFU4 EXTERNAL BETFU4 C DOUBLE PRECISION AE DOUBLE PRECISION RE DOUBLE PRECISION XLOW DOUBLE PRECISION XUP DOUBLE PRECISION XSTRT DOUBLE PRECISION DBETA2 DOUBLE PRECISION DN DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 DOUBLE PRECISION DTERM3 DOUBLE PRECISION DTERM4 C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C DALPH2=DALPHA DBETA2=DBETA AE=1.D-7 RE=1.D-7 XSTRT=DBETA2 XLOW=XSTRT/3.0D0 XUP=XSTRT*3.0D0 CALL DFZER3(BETFU4,XLOW,XUP,XSTRT,RE,AE,IFLAG,DX) DBETA2=XLOW C C COMPUTE LL(ALPHA,BETA) C DN=DBLE(N) DTERM1=0.0D0 IF(DALPHA.GT.0.0D0 .AND. DBETA.GT.0.0D0)THEN DTERM1=-DN*DLBETA(DALPHA,DBETA2) ENDIF DTERM2=DN*(DALPHA-1.0D0)*DSUM3 DTERM3=DN*(DBETA2-1.0D0)*DSUM4 DTERM4=DTERM1 + DTERM2 + DTERM3 C BETFU2=2.0*DLLAB - 2.0D0*DTERM4 - DK C RETURN END DOUBLE PRECISION FUNCTION BETFU5 (DBETA,DX) C C PURPOSE--THIS ROUTINE IS USED IN FINDING THE LIKELIHOOD RATIO C BASED CONFIDECE INTERVAL FOR THE 2-PARAMETER BETA C MODEL (FULL SAMPLE). THIS FUNCTION FINDS THE ROOT C OF THE EQUATION: C C 2*LL(ALPHA,BETA) - 2*LL(ALPHA,ALPHA(BETA)) - C CHSPPF(alpha,1) C C WITH C C LL(ALPHA,BETA) = -N*LOG(BETA(ALPHA,BETA)) + C N*(ALPHA-1)*S3 +N*(BETA-1)*S4 C C GIVEN CURRENT VALUE OF BETA, WE COMPUTE VALUE OF C ALPHA(BETA). WE THEN COMPUTE THE LIKELIHOOD FUNCTION. C NOTE THAT LL(ALPHA,BETA) IS COMPUTED ONCE IN DPMLBE C AND PASSED VIA COMMON. C C CALLED BY DFZER2 ROUTINE FOR FINDING THE ROOT OF A C FUNCTION. C C EXAMPLE--BETA MAXIMUM LIKELIHOOD Y C REFERENCE--KARL BURY, "STATISTICAL DISTRIBUTIONS IN ENGINEERING", C CAMBRIDGE UNIVERSITY PRESS, 1999, CHAPTER 14 (SEE C EXAMPLE 14.3). C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBUG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2004/12 C ORIGINAL VERSION--DECEMBER 2004. C C--------------------------------------------------------------------- C DOUBLE PRECISION DBETA DOUBLE PRECISION DX(*) C INTEGER N DOUBLE PRECISION DSUM3 DOUBLE PRECISION DSUM4 DOUBLE PRECISION DLLAB DOUBLE PRECISION DK COMMON/BETCO9/DSUM3,DSUM4,DLLAB,DK,N C DOUBLE PRECISION DALPHA COMMON/BETCO5/DALPHA C DOUBLE PRECISION DBETA2 COMMON/BETCO3/DBETA2 C DOUBLE PRECISION DLBETA EXTERNAL DLBETA DOUBLE PRECISION BETFU3 EXTERNAL BETFU3 C DOUBLE PRECISION AE DOUBLE PRECISION RE DOUBLE PRECISION XLOW DOUBLE PRECISION XUP DOUBLE PRECISION XSTRT DOUBLE PRECISION DALPH2 DOUBLE PRECISION DN DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 DOUBLE PRECISION DTERM3 DOUBLE PRECISION DTERM4 C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C DBETA2=DBETA DALPH2=DALPHA AE=1.D-7 RE=1.D-7 XSTRT=DALPH2 XLOW=XSTRT/3.0D0 XUP=XSTRT*3.0D0 CALL DFZER3(BETFU3,XLOW,XUP,XSTRT,RE,AE,IFLAG,DX) DALPH2=XLOW C C COMPUTE LL(ALPHA,BETA) C DN=DBLE(N) DTERM1=0.0D0 IF(DALPHA.GT.0.0D0 .AND. DBETA.GT.0.0D0)THEN DTERM1=-DN*DLBETA(DALPH2,DBETA) ENDIF DTERM2=DN*(DALPH2-1.0D0)*DSUM3 DTERM3=DN*(DBETA-1.0D0)*DSUM4 DTERM4=DTERM1 + DTERM2 + DTERM3 C BETFU5=2.0*DLLAB - 2.0D0*DTERM4 - DK C RETURN END DOUBLE PRECISION FUNCTION BETFU3 (DALPHA,DX) C C PURPOSE--THIS ROUTINE IS USED IN FINDING THE LIKELIHOOD RATIO C BASED CONFIDENCE INTERVAL FOR THE ALPHA SHAPE PARAMETER C OF A 2-PARAMETER BETA MODEL (FULL SAMPLE). THIS C FUNCTION FINDS THE ROOT OF THE EQUATION: C C DIGAMMA(BETA) - DIGAMMA(ALPHA + BETA) - SUM4 C C WITH C C SUM4 = (1/N)*SUM[i=1 to N][LOG((B - X(i))]/(B-A) C N = SAMPLE SIZE C A = LOWER LIMIT C B = UPPER LIMIT C C NOTE THAT DIGAMMA(BETA) AND SUM4 DO NOT DEPEND ON C THE VALUE OF ALPHA, SO THESE ARE COMPUTED ONCE AND C PASSED VIA COMMON BLOCKS. C C GIVEN A VALUE FOR THE BETA SHAPE PARAMETER (DBETA), WE C NEED TO DETERMINE THE VALUE OF THE ALPHA SHAPE PARAMETER C (DALPHA). C C CALLED BY DFZER2 ROUTINE FOR FINDING THE ROOT OF A C FUNCTION. DFZER2 IS MODIFIED VERSION OF DFZERO THAT C PASSES ALONG THE DATA ARRAY. C C EXAMPLE--BETA MAXIMUM LIKELIHOOD Y C REFERENCE--KARL BURY, "STATISTICAL DISTRIBUTIONS IN ENGINEERING", C CAMBRIDGE UNIVERSITY PRESS, 1999, CHAPTER 14 (SEE C EXAMPLE 14.3). C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBUG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2004/12 C ORIGINAL VERSION--DECEMBER 2004. C C--------------------------------------------------------------------- C DOUBLE PRECISION DALPHA DOUBLE PRECISION DX(*) C INTEGER N DOUBLE PRECISION DSUM3 DOUBLE PRECISION DSUM4 DOUBLE PRECISION DLLAB DOUBLE PRECISION DK COMMON/BETCO9/DSUM3,DSUM4,DLLAB,DK,N C DOUBLE PRECISION DBETA COMMON/BETCO3/DBETA C DOUBLE PRECISION DN C DOUBLE PRECISION DPSI EXTERNAL DPSI C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C DN=DBLE(N) BETFU3=DPSI(DALPHA) - DPSI(DALPHA + DBETA) - DSUM3 C RETURN END DOUBLE PRECISION FUNCTION BETFU4 (DBETA,DX) C C PURPOSE--THIS ROUTINE IS USED IN FINDING THE LIKELIHOOD RATIO C BASED CONFIDENCE INTERVAL FOR THE BETA SHAPE PARAMETER C OF A 2-PARAMETER BETA MODEL (FULL SAMPLE). THIS C FUNCTION FINDS THE ROOT OF THE EQUATION: C C DIGAMMA(ALPHA) - DIGAMMA(ALPHA + BETA) - SUM3 C C WITH C C SUM3 = (1/N)*SUM[i=1 to N][LOG((X(i) - A)]/(B-A) C N = SAMPLE SIZE C A = LOWER LIMIT C B = UPPER LIMIT C C NOTE THAT DIGAMMA(ALPHA) AND SUM3 DO NOT DEPEND ON C THE VALUE OF BETA, SO THESE ARE COMPUTED ONCE AND C PASSED VIA COMMON BLOCKS. C C GIVEN A VALUE FOR THE ALPHA SHAPE PARAMETER (DALPHA), C DETERMINE VALUE OF BETA. THIS IS C THE ROOT OF THE ABOVE EQUATION. C C CALLED BY DFZER2 ROUTINE FOR FINDING THE ROOT OF A C FUNCTION. DFZER2 IS MODIFIED VERSION OF DFZERO THAT C PASSES ALONG THE DATA ARRAY. C C EXAMPLE--BETA MAXIMUM LIKELIHOOD Y C REFERENCE--KARL BURY, "STATISTICAL DISTRIBUTIONS IN ENGINEERING", C CAMBRIDGE UNIVERSITY PRESS, 1999, CHAPTER 14 (SEE C EXAMPLE 14.3). C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBUG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2004/12 C ORIGINAL VERSION--DECEMBER 2004. C C--------------------------------------------------------------------- C DOUBLE PRECISION DBETA DOUBLE PRECISION DX(*) C INTEGER N DOUBLE PRECISION DSUM3 DOUBLE PRECISION DSUM4 DOUBLE PRECISION DLLAB DOUBLE PRECISION DK COMMON/BETCO9/DSUM3,DSUM4,DLLAB,DK,N C DOUBLE PRECISION DALPHA COMMON/BETCO4/DALPHA C DOUBLE PRECISION DN C DOUBLE PRECISION DPSI EXTERNAL DPSI C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C DN=DBLE(N) BETFU4=DPSI(DBETA) - DPSI(DALPHA + DBETA) - DSUM4 C RETURN END REAL FUNCTION BETFU7(ALPHA) C C PURPOSE--THIS ROUTINE IS USED IN FINDING CONFIDENCE LIMITS C FOR PERCENTILES OF THE BETA DISTRIBUTION (BASED ON C MAXIMUM LIKELIHOOD ESTIMATION). THIS FUNCTION C COMPUTES THE DERIVATIVE OF THE BETA PERCENT POINT C FUNCTION WITH RESPECT TO THE ALPHA SHAPE PARAMETER. C C CALLED BY DIFF ROUTINE FOR FINDING THE DERIVATIVE C OF A FUNCTION. C EXAMPLE--BETA MAXIMUM LIKELIHOOD Y C REFERENCE--KARL BURY, "STATISTICAL DISTRIBUTIONS IN C ENGINEERING", CAMBRIDGE UNIVERSITY PRESS, C 1999, CHAPTER 13. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBUG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2004/12 C ORIGINAL VERSION--DECEMBER 2004. C C--------------------------------------------------------------------- C REAL ALPHA C COMMON/BETCO7/P,BETA C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C CALL BETPPF(P,ALPHA,BETA,APPF) BETFU7=APPF C RETURN END REAL FUNCTION BETFU8(BETA) C C PURPOSE--THIS ROUTINE IS USED IN FINDING CONFIDENCE LIMITS C FOR PERCENTILES OF THE BETA DISTRIBUTION (BASED ON C MAXIMUM LIKELIHOOD ESTIMATION). THIS FUNCTION C COMPUTES THE DERIVATIVE OF THE BETA PERCENT POINT C FUNCTION WITH RESPECT TO THE BETA SHAPE PARAMETER. C C CALLED BY DIFF ROUTINE FOR FINDING THE DERIVATIVE C OF A FUNCTION. C EXAMPLE--BETA MAXIMUM LIKELIHOOD Y C REFERENCE--KARL BURY, "STATISTICAL DISTRIBUTIONS IN C ENGINEERING", CAMBRIDGE UNIVERSITY PRESS, C 1999, CHAPTER 13. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBUG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2004/12 C ORIGINAL VERSION--DECEMBER 2004. C C--------------------------------------------------------------------- C REAL BETA C COMMON/BETCO8/P,ALPHA C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C CALL BETPPF(P,ALPHA,BETA,APPF) BETFU8=APPF C RETURN END SUBROUTINE BETPDF(X,ALPHA,BETA,PDF) C C NOTE--BETA PDF IS: C BETPDF(X,A,B) = X**(A-1)*(1-X)**(B-1)/BETA(A,B) C WHERE BETA(A,B) IS THE COMPLETE BETA FUNCTION. C USE LOGARITHMS TO OBTAIN: C LN(BETAPDF) = (A-1)*LN(X)+(B-1)*LN(1-X)-LN(BETA(A,B)) C AND THEN TAKE EXPONENT. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-921-3651 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--94/8 C ORIGINAL VERSION--SEPTEMBER 1994. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C DOUBLE PRECISION DPDF DOUBLE PRECISION DALPHA DOUBLE PRECISION DBETA DOUBLE PRECISION DX DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 DOUBLE PRECISION DTERM3 DOUBLE PRECISION DTERM4 DOUBLE PRECISION DLBETA C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C PDF=0.0 IF(ALPHA.LE.0.0 .OR. BETA.LE.0.0)THEN WRITE(ICOUT,101) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,102) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,103)ALPHA CALL DPWRST('XXX','BUG ') WRITE(ICOUT,104)BETA CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF IF(X.LE.0.0)THEN WRITE(ICOUT,301) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,302)X CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF IF(X.GE.1.0)THEN WRITE(ICOUT,401) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,402)X CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF 101 FORMAT('***** FATAL DIAGNOSTIC--EITHER THE ALPHA OR BETA IS') 102 FORMAT(' NON-POSITIVE.') 103 FORMAT(' THE VALUE OF ALPHA IS ',E15.7) 104 FORMAT(' THE VALUE OF BETA IS ',E15.7,' ******') 301 FORMAT('***** FATAL DIAGNOSTIC--THE INPUT ARGUMENT IS ') 302 FORMAT(' NON-POSITIVE. IT HAS THE VALUE ',E15.7) 401 FORMAT('***** FATAL DIAGNOSTIC--THE INPUT ARGUMENT IS GRETATER') 402 FORMAT(' THAN OR EQUAL TO 1. IT HAS THE VALUE ',E15.7) C IF(X.LE.0.0.OR.X.GE.1.0)GOTO900 DX=DBLE(X) DALPHA=DBLE(ALPHA) DBETA=DBLE(BETA) DTERM3=DLBETA(DALPHA,DBETA) DTERM1=(DALPHA-1.D0)*DLOG(DX) DTERM2=(DBETA-1.D0)*DLOG(1.D0-DX) DTERM4=DTERM1 + DTERM2 - DTERM3 DPDF=DEXP(DTERM4) PDF=REAL(DPDF) GOTO9999 C C HANDLE X = 0 OR 1 CASE SEPARATELY. FOR NOW, LEAVE AS UNDEFINED C (SO PDF = 0.0). C 900 CONTINUE PDF=0.0 CCCCC DX=DBLE(X) CCCCC DALPHA=DBLE(ALPHA) CCCCC DBETA=DBLE(BETA) CCCCC DTERM3=DLBETA(DALPHA,DBETA) CCCCC DTERM1=0.D0 CCCCC DTERM2=0.D0 CCCCC DTERM4=DTERM1 + DTERM2 - DTERM3 CCCCC DPDF=DEXP(DTERM4) CCCCC PDF=SNGL(DPDF) GOTO9999 C 9999 CONTINUE RETURN END SUBROUTINE BETPPF(P,ALPHA,BETA,PPF) C C NOTE--ALGORITHM ADDED SEPTEMBER 1994 (ALAN) C USE ALGORITHM FROM KENNEDY AND GENTLE (PP. 109-112) WITH C THE MODIFICATION THAT WE USE OUR BETA CDF ROUTINE. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-921-3651 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION--JULY 1981. C UPDATED --FEBRUARY 1982. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C DOUBLE PRECISION DCDF DOUBLE PRECISION DALPHA DOUBLE PRECISION DBETA DOUBLE PRECISION DX DOUBLE PRECISION DBETAI C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C DATA EPS /1.0E-6/ DATA SIG /1.0E-5/ DATA ZERO /0./ DATA MAXIT /200/ C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(P.LT.0.0.OR.P.GT.1.0)GOTO50 IF(ALPHA.LE.0.0)GOTO55 IF(BETA.LE.0.0)GOTO60 GOTO90 50 WRITE(ICOUT,1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)P CALL DPWRST('XXX','BUG ') PPF=0.0 RETURN 55 WRITE(ICOUT,11) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)ALPHA CALL DPWRST('XXX','BUG ') PPF=0.0 RETURN 60 WRITE(ICOUT,25) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)BETA CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9999 90 CONTINUE 1 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ', 1' BETPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL') 11 FORMAT('***** FATAL ERROR--THE 2ND INPUT ARGUMENT TO THE ', 1' BETPPF SUBROUTINE IS NON-POSITIVE') 25 FORMAT('***** FATAL ERROR--THE 3RD INPUT ARGUMENT TO THE ', 1' BETPPF SUBROUTINE IS NON-POSITIVE *****') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') C A = ALPHA B = BETA C IERR=0 IC = 0 AB = A/B XL = 0.0 XR = 1.0 FXL = -P FXR = 1.0 - P CCCCC INVALID P EXPLICITLY CHECKED FOR EARLIER. IF(FXL*FXR .GT. ZERO)GOTO50 C C BISECTION METHOD C 105 CONTINUE X = (XL+XR)*0.5 DX=DBLE(X) DALPHA=DBLE(A) DBETA=DBLE(B) DCDF=DBETAI(DX,DALPHA,DBETA) P1=REAL(DCDF) PPF=X CCCCC IF(IERR.NE.0)THEN CCCCC WRITE(ICOUT,120) CCCCC CALL DPWRST('XXX','BUG ') CCCCC ENDIF CC120 FORMAT('***** FATAL ERROR--ERROR IN BETCDF ROUTINE. *****') FCS = P1 - P IF(FCS*FXL.GT.ZERO)GOTO110 XR = X FXR = FCS GOTO115 110 CONTINUE XL = X FXL = FCS 115 CONTINUE XRML = XR - XL IF(XRML.LE.SIG .AND. ABS(FCS).LE.EPS)GOTO9999 IC = IC + 1 IF(IC.LE.MAXIT)GOTO105 WRITE(ICOUT,130) CALL DPWRST('XXX','BUG ') 130 FORMAT('***** FATAL ERROR--BETPPF ROUTINE DID NOT CONVERGE. ***') GOTO9999 C 9999 CONTINUE RETURN END SUBROUTINE BETRAN(N,ALPHA,BETA,ISEED,X) C C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N C FROM THE BETA DISTRIBUTION C WITH SINGLE PRECISION SHAPE C PARAMETERS = ALPHA AND BETA. C THE PROTOTYPE BETA DISTRIBUTION USED C HEREIN HAS MEAN = ALPHA/(ALPHA+BETA) C AND STANDARD DEVIATION = C SQRT((ALPHA*BETA) / ((ALPHA+BETA)**2)*(ALPHA+BETA+1)) C THIS DISTRIBUTION IS DEFINED FOR ALL X C BETWEEN 0.0 (INCLUSIVELY) AND 1.0 (INCLUSIVELY). C AND HAS THE PROBABILITY DENSITY FUNCTION C F(X) = (1/CONSTANT) * X**(ALPHA-1) * (1.0-X)**(BETA-1) C WHERE THE CONSTANT = THE BETA FUNCTION EVALUATED C AT THE VALUES ALPHA AND BETA. C INPUT ARGUMENTS--N = THE DESIRED INTEGER NUMBER C OF RANDOM NUMBERS TO BE C GENERATED. C --ALPHA = THE SINGLE PRECISION VALUE OF THE C FIRST SHAPE PARAMETER. C ALPHA SHOULD BE GREATER THAN C OR EQUAL TO 1.0. C --BETA = THE SINGLE PRECISION VALUE OF THE C SECOND SHAPE PARAMETER. C BETA SHOULD BE GREATER THAN C OR EQUAL TO 1.0. C OUTPUT ARGUMENTS--X = A SINGLE PRECISION VECTOR C (OF DIMENSION AT LEAST N) C INTO WHICH THE GENERATED C RANDOM SAMPLE WILL BE PLACED. C OUTPUT--A RANDOM SAMPLE OF SIZE N C FROM THE BETA DISTRIBUTION C WITH SHAPE PARAMETER VALUES = ALPHA AND BETA. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C --ALPHA SHOULD BE GREATER THAN C OR EQUAL TO 1.0. C --BETA SHOULD BE GREATER THAN C OR EQUAL TO 1.0. C OTHER DATAPAC SUBROUTINES NEEDED--UNIRAN, NORRAN. C FORTRAN LIBRARY SUBROUTINES NEEDED--SQRT, EXP. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--GREENWOOD, 'A FAST GENERATOR FOR C BETA-DISTRIBUTED RANDOM VARIABLES', C COMPSTAT 1974, PROCEEDINGS IN C COMPUTATIONAL STATISTICS, VIENNA, C SEPTEMBER, 1974, PAGES 19-27. C --TOCHER, THE ART OF SIMULATION, C 1963, PAGES 24-27. C --HAMMERSLEY AND HANDSCOMB, MONTE CARLO METHODS, C 1964, PAGES 36-37. C --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE C DISTRIBUTIONS--2, 1970, PAGES 37-56. C --HASTINGS AND PEACOCK, STATISTICAL C DISTRIBUTIONS--A HANDBOOK FOR C STUDENTS AND PRACTITIONERS, 1975, C PAGES 30-35. C --NATIONAL BUREAU OF STANDARDS APPLIED MATHEMATICS C SERIES 55, 1964, PAGE 952. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-921-3651 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLARITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--82.3 C ORIGINAL VERSION--NOVEMBER 1975. C UPDATED --FEBRUARY 1976. C UPDATED --JUNE 1978. C UPDATED --DECEMBER 1981. C UPDATED --DECEMBER 2001. FOR ALPHA < 1 OR BETA < 1, C USE PERCENT POINT METHOD C UPDATED --NOVEMBER 2001. FOR ALPHA < 1 OR BETA < 1, C USE JOHNK'S ALGORITHM C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DIMENSION X(*) C DIMENSION XN(2) DIMENSION U(2) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----DATA STATEMENTS------------------------------------------------- C DATA ATHIRD/0.33333333/ DATA SQRT3 /1.73205081/ C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(N.LT.1)GOTO50 IF(ALPHA.LE.0.0)GOTO60 IF(BETA.LT.0.0)GOTO65 GOTO90 50 WRITE(ICOUT, 5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)N CALL DPWRST('XXX','BUG ') RETURN 60 WRITE(ICOUT,16) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)ALPHA CALL DPWRST('XXX','BUG ') RETURN 65 WRITE(ICOUT,26) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)BETA CALL DPWRST('XXX','BUG ') RETURN 90 CONTINUE 5 FORMAT('***** FATAL ERROR--THE FIRST INPUT ARGUMENT TO THE ', 1' BETRAN SUBROUTINE IS NON-POSITIVE *****') 16 FORMAT('***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE ', 1' BETRAN SUBROUTINE IS SMALLER THAN 0.0 *****') 26 FORMAT('***** FATAL ERROR--THE THIRD INPUT ARGUMENT TO THE ', 1' BETRAN SUBROUTINE IS SMALLER THAN 0.0 *****') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****') C C GENERATE N BETA RANDOM NUMBERS C BY USING THE FACT THAT C IF X1 IS A GAMMA VARIATE WITH PARAMETER ALPHA C AND IF X2 IS A GAMMA VARIATE WITH PARAMETER BETA, C THEN THE RATIO X1/(X1+X2) IS A BETA VARIATE C WITH PARAMETERS ALPHA AND BETA. C C TO GENERATE N GAMMA DISTRIBUTION RANDOM NUMBERS, C USE GREENWOOD'S REJECTION ALGORITHM-- C 1) GENERATE A NORMAL RANDOM NUMBER; C 2) TRANSFORM THE NORMAL VARIATE TO AN APPROXIMATE C GAMMA VARIATE USING THE WILSON-HILFERTY C APPROXIMATION (SEE THE JOHNSON AND KOTZ C REFERENCE, PAGE 176); C 3) FORM THE REJECTION FUNCTION VALUE, BASED C ON THE PROBABILITY DENSITY FUNCTION VALUE C OF THE ACTUAL DISTRIBUTION OF THE PSEUDO-GAMMA C VARIATE, AND THE PROBABILITY DENSITY FUNCTION VALUE C OF A TRUE GAMMA VARIATE. C 4) GENERATE A UNIFORM RANDOM NUMBER; C 5) IF THE UNIFORM RANDOM NUMBER IS LESS THAN C THE REJECTION FUNCTION VALUE, THEN ACCEPT C THE PSEUDO-RANDOM NUMBER AS A GAMMA VARIATE; C IF THE UNIFORM RANDOM NUMBER IS LARGER THAN C THE REJECTION FUNCTION VALUE, THEN REJECT C THE PSEUDO-RANDOM NUMBER AS A GAMMA VARIATE. C C FOR ALPHA < 1 AND BETA < 1, USE JOHNK'S ALGORITHM C (JAMES GENTLE, "RANDOM NUMBER GENERATION AND MONTE CARLO C METHODS", SECOND EDITION, SPRINGER-VERLANG, 2003. C FOR ALPHA OR BETA <= 0, THEN USE THE PERCENT POINT METHOD. C IF(ALPHA.EQ.1.0 .AND. BETA.EQ.1.0)THEN CALL UNIRAN(N,ISEED,X) GOTO9000 ENDIF C IF(ALPHA.LT.1.0 .AND. BETA.LT.1.0)THEN NTEMP=1 DO400I=1,N 401 CONTINUE CALL UNIRAN(NTEMP,ISEED,X(I)) U1=X(I) CALL UNIRAN(NTEMP,ISEED,X(I)) U2=X(I) V1=U1**(1.0/ALPHA) V2=U2**(1.0/BETA) W=V1 + V2 IF(W.GT.1)GOTO401 X(I)=V1/W 400 CONTINUE GOTO9000 ENDIF C C FOR CASE WHERE ALPHA < 1 AND BETA > 1 (OR SIMILARLY, C WHEN ALPHA > 1 AND BETA < 1), USE ALGORITHM GIVEN BY C IN: "A FAMILY OF SWITCHING ALGORITHMS FOR THE COMPUTER C GENERATION OF BETA RANDOM VARIABLES", A. C. ATKINSON, C BIOMETRIKA, 1979, 66, 1, PP. 141-145. C IF(ALPHA.LE.1.0 .AND. BETA.GE.1.0)THEN NTEMP=2 P=ALPHA Q=BETA S1=1.0 CCCCC T=(ALPHA-1.0)/(BETA+1.0-ALPHA) T=(1.0-ALPHA)/(BETA+1.0-ALPHA) S2=T**(ALPHA-1.0) R=BETA*T/(BETA*T + ALPHA*(1.0-T)**BETA) C DO600I=1,N 610 CONTINUE CALL UNIRAN(NTEMP,ISEED,U) U1=U(1) U2=U(2) IF(U1.LE.R)THEN XTEMP=T*(U1/R)**(1.0/P) H1=XTEMP**(ALPHA-P)*(1.0-XTEMP)**(BETA-1.0) IF(S1*U2.LE.H1)THEN X(I)=XTEMP GOTO600 ELSE GOTO610 ENDIF ELSE XTEMP=1.0 - (1.0-T)*((1.0-U1)/(1.0-R))**(1.0/Q) H2=XTEMP**(ALPHA-1.0) IF(S2*U2.LE.H2)THEN X(I)=XTEMP GOTO600 ELSE GOTO610 ENDIF ENDIF 600 CONTINUE CCCCC DO600I=1,N CCCCC CALL BETPPF(X(I),ALPHA,BETA,XTEMP) CCCCC X(I)=XTEMP CC600 CONTINUE GOTO9000 ENDIF IF(ALPHA.GE.1.0 .AND. BETA.LE.1.0)THEN C ALPSAV=ALPHA BETSAV=BETA ALPHA=BETSAV BETA=ALPSAV C NTEMP=2 P=ALPHA Q=BETA S1=1.0 T=(1.0-ALPHA)/(BETA+1.0-ALPHA) S2=T**(ALPHA-1.0) R=BETA*T/(BETA*T + ALPHA*(1.0-T)**BETA) C DO700I=1,N 710 CONTINUE CALL UNIRAN(NTEMP,ISEED,U) U1=U(1) U2=U(2) IF(U1.LE.R)THEN XTEMP=T*(U1/R)**(1.0/P) H1=XTEMP**(ALPHA-P)*(1.0-XTEMP)**(BETA-1.0) IF(S1*U2.LE.H1)THEN X(I)=1.0-XTEMP GOTO700 ELSE GOTO710 ENDIF ELSE XTEMP=1.0 - (1.0-T)*((1.0-U1)/(1.0-R))**(1.0/Q) H2=XTEMP**(ALPHA-1.0)*(1.0-XTEMP)**(BETA-Q) IF(S2*U2.LE.H2)THEN X(I)=1.0-XTEMP GOTO700 ELSE GOTO710 ENDIF ENDIF 700 CONTINUE ALPHA=ALPSAV BETA=BETSAV GOTO9000 ENDIF C A1=1.0/(9.0*ALPHA) B1=SQRT(A1) XN01=-SQRT3+B1 XG01=ALPHA*(1.0-A1+B1*XN01)**3 A2=1.0/(9.0*BETA) B2=SQRT(A2) XN02=-SQRT3+B2 XG02=BETA*(1.0-A2+B2*XN02)**3 C DO100I=1,N C 150 CALL NORRAN(1,ISEED,XN) XG=ALPHA*(1.0-A1+B1*XN(1))**3 IF(XG.LT.0.0)GOTO150 TERM=(XG/XG01)**(ALPHA-ATHIRD) ARG=0.5*XN(1)*XN(1)-XG-0.5*XN01*XN01+XG01 FUNCT=TERM*EXP(ARG) CALL UNIRAN(1,ISEED,U) IF(U(1).LE.FUNCT)GOTO170 GOTO150 170 XG1=XG C 250 CALL NORRAN(1,ISEED,XN) XG=BETA*(1.0-A2+B2*XN(1))**3 IF(XG.LT.0.0)GOTO250 TERM=(XG/XG02)**(BETA-ATHIRD) ARG=0.5*XN(1)*XN(1)-XG-0.5*XN02*XN02+XG02 FUNCT=TERM*EXP(ARG) CALL UNIRAN(1,ISEED,U) IF(U(1).LE.FUNCT)GOTO270 GOTO250 270 XG2=XG C X(I)=XG1/(XG1+XG2) C 100 CONTINUE C 9000 CONTINUE RETURN END FUNCTION BI (X) C***BEGIN PROLOGUE BI C***PURPOSE Evaluate the Bairy function (the Airy function of the C second kind). C***LIBRARY SLATEC (FNLIB) C***CATEGORY C10D C***TYPE SINGLE PRECISION (BI-S, DBI-D) C***KEYWORDS BAIRY FUNCTION, FNLIB, SPECIAL FUNCTIONS C***AUTHOR Fullerton, W., (LANL) C***DESCRIPTION C C BI(X) calculates the Airy function of the second kind for real C argument X. C C Series for BIF on the interval -1.00000D+00 to 1.00000D+00 C with weighted error 1.88E-19 C log weighted error 18.72 C significant figures required 17.74 C decimal places required 19.20 C C Series for BIG on the interval -1.00000D+00 to 1.00000D+00 C with weighted error 2.61E-17 C log weighted error 16.58 C significant figures required 15.17 C decimal places required 17.03 C C Series for BIF2 on the interval 1.00000D+00 to 8.00000D+00 C with weighted error 1.11E-17 C log weighted error 16.95 C approx significant figures required 16.5 C decimal places required 17.45 C C Series for BIG2 on the interval 1.00000D+00 to 8.00000D+00 C with weighted error 1.19E-18 C log weighted error 17.92 C approx significant figures required 17.2 C decimal places required 18.42 C C***REFERENCES (NONE) C***ROUTINES CALLED BIE, CSEVL, INITS, R1MACH, R9AIMP, XERMSG C***REVISION HISTORY (YYMMDD) C 770701 DATE WRITTEN C 890531 Changed all specific intrinsics to generic. (WRB) C 890531 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) C 900326 Removed duplicate information from DESCRIPTION section. C (WRB) C***END PROLOGUE BI C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOMC.INC' CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C DIMENSION BIFCS(9), BIGCS(8), BIF2CS(10), BIG2CS(10) LOGICAL FIRST SAVE BIFCS, BIGCS, BIF2CS, BIG2CS, NBIF, NBIG, NBIF2, 1 NBIG2, X3SML, XMAX, FIRST DATA BIFCS( 1) / -.0167302164 7198664948E0 / DATA BIFCS( 2) / .1025233583 424944561E0 / DATA BIFCS( 3) / .0017083092 5073815165E0 / DATA BIFCS( 4) / .0000118625 4546774468E0 / DATA BIFCS( 5) / .0000000449 3290701779E0 / DATA BIFCS( 6) / .0000000001 0698207143E0 / DATA BIFCS( 7) / .0000000000 0017480643E0 / DATA BIFCS( 8) / .0000000000 0000020810E0 / DATA BIFCS( 9) / .0000000000 0000000018E0 / DATA BIGCS( 1) / .0224662232 4857452E0 / DATA BIGCS( 2) / .0373647754 5301955E0 / DATA BIGCS( 3) / .0004447621 8957212E0 / DATA BIGCS( 4) / .0000024708 0756363E0 / DATA BIGCS( 5) / .0000000079 1913533E0 / DATA BIGCS( 6) / .0000000000 1649807E0 / DATA BIGCS( 7) / .0000000000 0002411E0 / DATA BIGCS( 8) / .0000000000 0000002E0 / DATA BIF2CS( 1) / 0.0998457269 3816041E0 / DATA BIF2CS( 2) / .4786249778 63005538E0 / DATA BIF2CS( 3) / .0251552119 604330118E0 / DATA BIF2CS( 4) / .0005820693 885232645E0 / DATA BIF2CS( 5) / .0000074997 659644377E0 / DATA BIF2CS( 6) / .0000000613 460287034E0 / DATA BIF2CS( 7) / .0000000003 462753885E0 / DATA BIF2CS( 8) / .0000000000 014288910E0 / DATA BIF2CS( 9) / .0000000000 000044962E0 / DATA BIF2CS(10) / .0000000000 000000111E0 / DATA BIG2CS( 1) / .0333056621 45514340E0 / DATA BIG2CS( 2) / .1613092151 23197068E0 / DATA BIG2CS( 3) / .0063190073 096134286E0 / DATA BIG2CS( 4) / .0001187904 568162517E0 / DATA BIG2CS( 5) / .0000013045 345886200E0 / DATA BIG2CS( 6) / .0000000093 741259955E0 / DATA BIG2CS( 7) / .0000000000 474580188E0 / DATA BIG2CS( 8) / .0000000000 001783107E0 / DATA BIG2CS( 9) / .0000000000 000005167E0 / DATA BIG2CS(10) / .0000000000 000000011E0 / DATA FIRST /.TRUE./ C***FIRST EXECUTABLE STATEMENT BI IF (FIRST) THEN ETA = 0.1*R1MACH(3) NBIF = INITS (BIFCS , 9, ETA) NBIG = INITS (BIGCS , 8, ETA) NBIF2 = INITS (BIF2CS, 10, ETA) NBIG2 = INITS (BIG2CS, 10, ETA) C X3SML = ETA**0.3333 XMAX = (1.5*LOG(R1MACH(2)))**0.6666 ENDIF FIRST = .FALSE. C IF (X.GE.(-1.0)) GO TO 20 CALL R9AIMP (X, XM, THETA) BI = XM * SIN(THETA) RETURN C 20 IF (X.GT.1.0) GO TO 30 Z = 0.0 IF (ABS(X).GT.X3SML) Z = X**3 BI = 0.625 + CSEVL (Z, BIFCS, NBIF) + X*(0.4375 + 1 CSEVL (Z, BIGCS, NBIG)) RETURN C 30 IF (X.GT.2.0) GO TO 40 Z = (2.0*X**3 - 9.0) / 7.0 BI = 1.125 + CSEVL (Z, BIF2CS, NBIF2) + X*(0.625 + 1 CSEVL (Z, BIG2CS, NBIG2)) RETURN C 40 IF (X .GT. XMAX) THEN WRITE(ICOUT,1) CALL DPWRST('XXX','BUG ') BI = 0.0 RETURN ENDIF 1 FORMAT('***** ERORR FROM BI, OVERFLOWS BECAUSE THE ', 1 'VALUE OF X IS TOO BIG. ****') C BI = BIE(X) * EXP(2.0*X*SQRT(X)/3.0) RETURN C END FUNCTION BIE (X) C***BEGIN PROLOGUE BIE C***PURPOSE Calculate the Bairy function for a negative argument and an C exponentially scaled Bairy function for a non-negative C argument. C***LIBRARY SLATEC (FNLIB) C***CATEGORY C10D C***TYPE SINGLE PRECISION (BIE-S, DBIE-D) C***KEYWORDS BAIRY FUNCTION, EXPONENTIALLY SCALED, FNLIB, C SPECIAL FUNCTIONS C***AUTHOR Fullerton, W., (LANL) C***DESCRIPTION C C Evaluate BI(X) for X .LE. 0 and BI(X)*EXP(ZETA) where C ZETA = 2/3 * X**(3/2) for X .GE. 0.0 C C Series for BIF on the interval -1.00000D+00 to 1.00000D+00 C with weighted error 1.88E-19 C log weighted error 18.72 C significant figures required 17.74 C decimal places required 19.20 C C Series for BIG on the interval -1.00000D+00 to 1.00000D+00 C with weighted error 2.61E-17 C log weighted error 16.58 C significant figures required 15.17 C decimal places required 17.03 C C Series for BIF2 on the interval 1.00000D+00 to 8.00000D+00 C with weighted error 1.11E-17 C log weighted error 16.95 C approx significant figures required 16.5 C decimal places required 17.45 C C Series for BIG2 on the interval 1.00000D+00 to 8.00000D+00 C with weighted error 1.19E-18 C log weighted error 17.92 C approx significant figures required 17.2 C decimal places required 18.42 C C Series for BIP on the interval 1.25000D-01 to 3.53553D-01 C with weighted error 1.91E-17 C log weighted error 16.72 C significant figures required 15.35 C decimal places required 17.41 C C Series for BIP2 on the interval 0. to 1.25000D-01 C with weighted error 1.05E-18 C log weighted error 17.98 C significant figures required 16.74 C decimal places required 18.71 C C***REFERENCES (NONE) C***ROUTINES CALLED CSEVL, INITS, R1MACH, R9AIMP C***REVISION HISTORY (YYMMDD) C 770701 DATE WRITTEN C 890206 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C***END PROLOGUE BIE C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOMC.INC' CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C LOGICAL FIRST DIMENSION BIFCS(9), BIGCS(8), BIF2CS(10), BIG2CS(10), BIPCS(24), 1 BIP2CS(29) SAVE BIFCS, BIGCS, BIF2CS, BIG2CS, BIPCS, BIP2CS, ATR, BTR, 1 NBIF, NBIG, NBIF2, NBIG2, NBIP, NBIP2, X3SML, X32SML, XBIG, FIRST DATA BIFCS( 1) / -.0167302164 7198664948E0 / DATA BIFCS( 2) / .1025233583 424944561E0 / DATA BIFCS( 3) / .0017083092 5073815165E0 / DATA BIFCS( 4) / .0000118625 4546774468E0 / DATA BIFCS( 5) / .0000000449 3290701779E0 / DATA BIFCS( 6) / .0000000001 0698207143E0 / DATA BIFCS( 7) / .0000000000 0017480643E0 / DATA BIFCS( 8) / .0000000000 0000020810E0 / DATA BIFCS( 9) / .0000000000 0000000018E0 / DATA BIGCS( 1) / .0224662232 4857452E0 / DATA BIGCS( 2) / .0373647754 5301955E0 / DATA BIGCS( 3) / .0004447621 8957212E0 / DATA BIGCS( 4) / .0000024708 0756363E0 / DATA BIGCS( 5) / .0000000079 1913533E0 / DATA BIGCS( 6) / .0000000000 1649807E0 / DATA BIGCS( 7) / .0000000000 0002411E0 / DATA BIGCS( 8) / .0000000000 0000002E0 / DATA BIF2CS( 1) / 0.0998457269 3816041E0 / DATA BIF2CS( 2) / .4786249778 63005538E0 / DATA BIF2CS( 3) / .0251552119 604330118E0 / DATA BIF2CS( 4) / .0005820693 885232645E0 / DATA BIF2CS( 5) / .0000074997 659644377E0 / DATA BIF2CS( 6) / .0000000613 460287034E0 / DATA BIF2CS( 7) / .0000000003 462753885E0 / DATA BIF2CS( 8) / .0000000000 014288910E0 / DATA BIF2CS( 9) / .0000000000 000044962E0 / DATA BIF2CS(10) / .0000000000 000000111E0 / DATA BIG2CS( 1) / .0333056621 45514340E0 / DATA BIG2CS( 2) / .1613092151 23197068E0 / DATA BIG2CS( 3) / .0063190073 096134286E0 / DATA BIG2CS( 4) / .0001187904 568162517E0 / DATA BIG2CS( 5) / .0000013045 345886200E0 / DATA BIG2CS( 6) / .0000000093 741259955E0 / DATA BIG2CS( 7) / .0000000000 474580188E0 / DATA BIG2CS( 8) / .0000000000 001783107E0 / DATA BIG2CS( 9) / .0000000000 000005167E0 / DATA BIG2CS(10) / .0000000000 000000011E0 / DATA BIPCS( 1) / -.0832204747 7943447E0 / DATA BIPCS( 2) / .0114611892 7371174E0 / DATA BIPCS( 3) / .0004289644 0718911E0 / DATA BIPCS( 4) / -.0001490663 9379950E0 / DATA BIPCS( 5) / -.0000130765 9726787E0 / DATA BIPCS( 6) / .0000063275 9839610E0 / DATA BIPCS( 7) / -.0000004222 6696982E0 / DATA BIPCS( 8) / -.0000001914 7186298E0 / DATA BIPCS( 9) / .0000000645 3106284E0 / DATA BIPCS(10) / -.0000000078 4485467E0 / DATA BIPCS(11) / -.0000000009 6077216E0 / DATA BIPCS(12) / .0000000007 0004713E0 / DATA BIPCS(13) / -.0000000001 7731789E0 / DATA BIPCS(14) / .0000000000 2272089E0 / DATA BIPCS(15) / .0000000000 0165404E0 / DATA BIPCS(16) / -.0000000000 0185171E0 / DATA BIPCS(17) / .0000000000 0059576E0 / DATA BIPCS(18) / -.0000000000 0012194E0 / DATA BIPCS(19) / .0000000000 0001334E0 / DATA BIPCS(20) / .0000000000 0000172E0 / DATA BIPCS(21) / -.0000000000 0000145E0 / DATA BIPCS(22) / .0000000000 0000049E0 / DATA BIPCS(23) / -.0000000000 0000011E0 / DATA BIPCS(24) / .0000000000 0000001E0 / DATA BIP2CS( 1) / -.1135967375 85988679E0 / DATA BIP2CS( 2) / .0041381473 947881595E0 / DATA BIP2CS( 3) / .0001353470 622119332E0 / DATA BIP2CS( 4) / .0000104273 166530153E0 / DATA BIP2CS( 5) / .0000013474 954767849E0 / DATA BIP2CS( 6) / .0000001696 537405438E0 / DATA BIP2CS( 7) / -.0000000100 965008656E0 / DATA BIP2CS( 8) / -.0000000167 291194937E0 / DATA BIP2CS( 9) / -.0000000045 815364485E0 / DATA BIP2CS(10) / .0000000003 736681366E0 / DATA BIP2CS(11) / .0000000005 766930320E0 / DATA BIP2CS(12) / .0000000000 621812650E0 / DATA BIP2CS(13) / -.0000000000 632941202E0 / DATA BIP2CS(14) / -.0000000000 149150479E0 / DATA BIP2CS(15) / .0000000000 078896213E0 / DATA BIP2CS(16) / .0000000000 024960513E0 / DATA BIP2CS(17) / -.0000000000 012130075E0 / DATA BIP2CS(18) / -.0000000000 003740493E0 / DATA BIP2CS(19) / .0000000000 002237727E0 / DATA BIP2CS(20) / .0000000000 000474902E0 / DATA BIP2CS(21) / -.0000000000 000452616E0 / DATA BIP2CS(22) / -.0000000000 000030172E0 / DATA BIP2CS(23) / .0000000000 000091058E0 / DATA BIP2CS(24) / -.0000000000 000009814E0 / DATA BIP2CS(25) / -.0000000000 000016429E0 / DATA BIP2CS(26) / .0000000000 000005533E0 / DATA BIP2CS(27) / .0000000000 000002175E0 / DATA BIP2CS(28) / -.0000000000 000001737E0 / DATA BIP2CS(29) / -.0000000000 000000010E0 / DATA ATR / 8.750690570 8484345 E0 / DATA BTR / -2.093836321 356054 E0 / DATA FIRST /.TRUE./ C***FIRST EXECUTABLE STATEMENT BIE IF (FIRST) THEN ETA = 0.1*R1MACH(3) NBIF = INITS (BIFCS, 9, ETA) NBIG = INITS (BIGCS, 8, ETA) NBIF2 = INITS (BIF2CS, 10, ETA) NBIG2 = INITS (BIG2CS, 10, ETA) NBIP = INITS (BIPCS , 24, ETA) NBIP2 = INITS (BIP2CS, 29, ETA) C X3SML = ETA**0.3333 X32SML = 1.3104*X3SML**2 XBIG = R1MACH(2)**0.6666 ENDIF FIRST = .FALSE. C IF (X.GE.(-1.0)) GO TO 20 CALL R9AIMP (X, XM, THETA) BIE = XM * SIN(THETA) RETURN C 20 IF (X.GT.1.0) GO TO 30 Z = 0.0 IF (ABS(X).GT.X3SML) Z = X**3 BIE = 0.625 + CSEVL (Z, BIFCS, NBIF) + X*(0.4375 + 1 CSEVL (Z, BIGCS, NBIG)) IF (X.GT.X32SML) BIE = BIE * EXP(-2.0*X*SQRT(X)/3.0) RETURN C 30 IF (X.GT.2.0) GO TO 40 Z = (2.0*X**3 - 9.0) / 7.0 BIE = EXP(-2.0*X*SQRT(X)/3.0) * (1.125 + CSEVL (Z, BIF2CS, NBIF2) 1 + X*(0.625 + CSEVL (Z, BIG2CS, NBIG2)) ) RETURN C 40 IF (X.GT.4.0) GO TO 50 SQRTX = SQRT(X) Z = ATR/(X*SQRTX) + BTR BIE = (0.625 + CSEVL (Z, BIPCS, NBIP)) / SQRT(SQRTX) RETURN C 50 SQRTX = SQRT(X) Z = -1.0 IF (X.LT.XBIG) Z = 16.0/(X*SQRTX) - 1.0 BIE = (0.625 + CSEVL (Z, BIP2CS, NBIP2))/SQRT(SQRTX) RETURN C END SUBROUTINE BGECDF(X,ALPHA,BETA,CDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION C FUNCTION VALUE AT THE SINGLE PRECISION VALUE X C FOR THE BETA-GEOMETRIC DISTRIBUTION C WITH SINGLE PRECISION SHAPE PARAMETERS ALPHA AND BETA. C THIS DISTRIBUTION IS DEFINED FOR ALL C NON-NEGATIVE INTEGER X. C C THIS DISTRIBUTION HAS THE PROBABILITY FUNCTION C p(X;ALPHA,BETA) = B(ALPHA+1,X+BETA-1)/BETA(ALPHA,BETA) C WHERE B(A,B) IS THE BETA FUNCTION. C NOTE THAT HESSELAGER GIVES THIS AS C p(X;ALPHA,BETA) = B(X+ALPHA,BETA+1)/BETA(ALPHA,BETA) C (WE USE HESSELAGER'S RECCURENCE FORMUALAS FOR THE C CDF). C C HESSELAGER'S RECURRENCE FORMULA FOR THE CUMULATIVE C DISTRIBUTION FUNCTION IS: C C p(X;ALHA,BETA) - [(X+ALPHA-1)/(X+ALPHA+BETA)]* C p(X-1;ALPHA,BETA) C C CONVERTING THIS TO THE MORE COMMON PARAMETERIZATION C YIELDS C C p(X;ALHA,BETA) - [(X+BETA-2)/(X+ALPHA+BETA-1)]* C p(X-1;ALPHA,BETA) C C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE C AT WHICH THE CUMULATIVE DISTRIBUTION C FUNCTION IS TO BE EVALUATED. C X SHOULD BE A NON-NEGATIVE INTEGR C --ALPHA = THE SINGLE PRECISION VALUE C OF THE FIRST SHAPE PARAMETER. C --BETA = THE SINGLE PRECISION VALUE C OF THE SECOND SHAPE PARAMETER. C OUTPUT ARGUMENTS--CDF = THE SINGLE PRECISION CUMULATIVE C DISTRIBUTION FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION PROBABILITY DISTRIBUTION C FUNCTION VALUE CDF C FOR THE BETA-GEOMETRIC DISTRIBUTION C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--X SHOULD BE A NON-NEGATIVE INTEGER C --ALPHA AND BETA SHOULD BE POSITIVE C OTHER DATAPAC SUBROUTINES NEEDED--DLBETA. C FORTRAN LIBRARY SUBROUTINES NEEDED--DEXP C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--OLE HESSELAGER (1994). "A RECURSIVE PROCEDURE C FOR CALCULATIONS OF SOME COMPOUND DISTRIBUTIONS", C ASTIN BULLETIN, VOL. 24, NO. 1, PP. 19-32. C --JOHNSON, KOTZ, AND KEMP (1992). "UNIVARIATE C DISCRETE DISTRIBUTIONS", SECOND EDITION, C WILEY, CHAPTER 6. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG< MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2006/5 C ORIGINAL VERSION--MAY 2006. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DX DOUBLE PRECISION DALPHA DOUBLE PRECISION DBETA DOUBLE PRECISION DCDF DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 DOUBLE PRECISION DTERM3 DOUBLE PRECISION DLBETA DOUBLE PRECISION DSUM DOUBLE PRECISION DPDF DOUBLE PRECISION DPDFSV C INCLUDE 'DPCOMC.INC' C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C CDF=0.0 C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(ALPHA.LE.0.0)THEN WRITE(ICOUT,11) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)ALPHA CALL DPWRST('XXX','BUG ') CDF=0.0 GOTO9999 ENDIF IF(BETA.LE.0.0)THEN WRITE(ICOUT,12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)BETA CALL DPWRST('XXX','BUG ') CDF=0.0 GOTO9999 ENDIF INTX=X+0.5 FINTX=INTX IF(INTX.LT.1)THEN CDF=0.0 GOTO9999 ENDIF C 11 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO THE ', 1' BGECDF SUBROUTINE IS NON-POSITIVE') 12 FORMAT('***** ERROR--THE THIRD INPUT ARGUMENT TO THE ', 1' BGECDF SUBROUTINE IS NON-POSITIVE') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8) 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8) C DX=DBLE(FINTX) IF(DX.GT.DBLE(I1MACH(9)))THEN WRITE(ICOUT,55) 55 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO THE ', 1 'BGECDF SUBROUTINE IS GREATER THAN') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,56) 56 FORMAT(' THE LARGEST MACHINE INTEGER.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') CDF=0.0 GOTO9999 ENDIF C DALPHA=DBLE(ALPHA) DBETA=DBLE(BETA) DSUM=0.0D0 C C COMPUTE PDF FOR X = 1 C DTERM1=DLBETA(DALPHA+1.0D0,DBETA) DTERM2=DLBETA(DALPHA,DBETA) DTERM3=DTERM1-DTERM2 DPDFSV=DEXP(DTERM3) DSUM=DPDFSV C IF(INTX.GT.1)THEN DO100I=2,INTX CCCCC DPDF= DPDFSV*(DBLE(I)+DALPHA-1.0D0)/(DBLE(I)+DALPHA+DBETA) DPDF= DPDFSV*(DBLE(I)+DBETA-2.0D0)/ 1 (DBLE(I)+DALPHA+DBETA-1.0D0) DPDFSV=DPDF DSUM=DSUM + DPDF 100 CONTINUE CDF=REAL(DSUM) ELSE CDF=REAL(DPDFSV) ENDIF C 9999 CONTINUE RETURN END SUBROUTINE BG2CDF(X,ALPHA,BETA,CDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION C FUNCTION VALUE AT THE SINGLE PRECISION VALUE X C FOR THE BETA-GEOMETRIC DISTRIBUTION C WITH SINGLE PRECISION SHAPE PARAMETERS ALPHA AND BETA. C THIS DISTRIBUTION IS DEFINED FOR ALL C NON-NEGATIVE INTEGER X. C C THIS DISTRIBUTION HAS THE PROBABILITY FUNCTION C p(X;ALPHA,BETA) = B(ALPHA+1,X+BETA)/BETA(ALPHA,BETA) C WHERE B(A,B) IS THE BETA FUNCTION. C NOTE THAT HESSELAGER GIVES THIS AS C p(X;ALPHA,BETA) = B(X+ALPHA,BETA+1)/BETA(ALPHA,BETA) C THAT IS, THE ALPHA AND BETA ARE REVERSED. C (WE USE HESSELAGER'S RECCURENCE FORMUALAS FOR THE C CDF). C C HESSELAGER'S RECURRENCE FORMULA FOR THE CUMULATIVE C DISTRIBUTION FUNCTION IS: C C p(X;ALHA,BETA) - [(X+ALPHA-1)/(X+ALPHA+BETA)]* C p(X-1;ALPHA,BETA) C C REVERSING THE ALPHA AND BETA YIELDS C C p(X;ALHA,BETA) - [(X+BETA-1)/(X+ALPHA+BETA)]* C p(X-1;ALPHA,BETA) C C NOTE THAT THE BGECDF ROUTINE IS THE BETA-GEOMETRIC C THAT STARTS WITH X = 1 WHEREAS THIS ROUTINE IS C SHIFTED TO START AT X = 0. C C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE C AT WHICH THE CUMULATIVE DISTRIBUTION C FUNCTION IS TO BE EVALUATED. C X SHOULD BE A NON-NEGATIVE INTEGR C --ALPHA = THE SINGLE PRECISION VALUE C OF THE FIRST SHAPE PARAMETER. C --BETA = THE SINGLE PRECISION VALUE C OF THE SECOND SHAPE PARAMETER. C OUTPUT ARGUMENTS--CDF = THE SINGLE PRECISION CUMULATIVE C DISTRIBUTION FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION PROBABILITY DISTRIBUTION C FUNCTION VALUE CDF C FOR THE BETA-GEOMETRIC DISTRIBUTION C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--X SHOULD BE A NON-NEGATIVE INTEGER C --ALPHA AND BETA SHOULD BE POSITIVE C OTHER DATAPAC SUBROUTINES NEEDED--DLBETA. C FORTRAN LIBRARY SUBROUTINES NEEDED--DEXP C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--OLE HESSELAGER (1994). "A RECURSIVE PROCEDURE C FOR CALCULATIONS OF SOME COMPOUND DISTRIBUTIONS", C ASTIN BULLETIN, VOL. 24, NO. 1, PP. 19-32. C --JOHNSON, KOTZ, AND KEMP (1992). "UNIVARIATE C DISCRETE DISTRIBUTIONS", SECOND EDITION, C WILEY, CHAPTER 6. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG< MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2006/5 C ORIGINAL VERSION--MAY 2006. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DX DOUBLE PRECISION DALPHA DOUBLE PRECISION DBETA DOUBLE PRECISION DCDF DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 DOUBLE PRECISION DTERM3 DOUBLE PRECISION DLBETA DOUBLE PRECISION DSUM DOUBLE PRECISION DPDF DOUBLE PRECISION DPDFSV C INCLUDE 'DPCOMC.INC' C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C CDF=0.0 C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(ALPHA.LE.0.0)THEN WRITE(ICOUT,11) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)ALPHA CALL DPWRST('XXX','BUG ') CDF=0.0 GOTO9999 ENDIF IF(BETA.LE.0.0)THEN WRITE(ICOUT,12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)BETA CALL DPWRST('XXX','BUG ') CDF=0.0 GOTO9999 ENDIF INTX=X+0.5 FINTX=INTX IF(INTX.LT.0)THEN CDF=0.0 GOTO9999 ENDIF C 11 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO THE ', 1' BG2CDF SUBROUTINE IS NON-POSITIVE') 12 FORMAT('***** ERROR--THE THIRD INPUT ARGUMENT TO THE ', 1' BG2CDF SUBROUTINE IS NON-POSITIVE') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8) 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8) C DX=DBLE(FINTX) IF(DX.GT.DBLE(I1MACH(9)))THEN WRITE(ICOUT,55) 55 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO THE ', 1 'BG2CDF SUBROUTINE IS GREATER THAN') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,56) 56 FORMAT(' THE LARGEST MACHINE INTEGER.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') CDF=0.0 GOTO9999 ENDIF C DALPHA=DBLE(ALPHA) DBETA=DBLE(BETA) DSUM=0.0D0 C C COMPUTE PDF FOR X = 0 C DTERM1=DLBETA(DALPHA+1.0D0,DBETA) DTERM2=DLBETA(DALPHA,DBETA) DTERM3=DTERM1-DTERM2 DPDFSV=DEXP(DTERM3) DSUM=DPDFSV C IF(INTX.GT.0)THEN DO100I=1,INTX DPDF= DPDFSV*(DBLE(I)+DBETA-1.0D0)/ 1 (DBLE(I)+DALPHA+DBETA) DPDFSV=DPDF DSUM=DSUM + DPDF 100 CONTINUE CDF=REAL(DSUM) ELSE CDF=REAL(DPDFSV) ENDIF C 9999 CONTINUE RETURN END SUBROUTINE BGEFUN(N,X,FVEC,IFLAG,XDATA,NOBS) C C PURPOSE--THIS ROUTINE COMPUTES THE FUNCTIONS FOR THE C BETA-GEOMETRIC MAXIMUM LIKELIHOOD EQUATIONS. C C (N/PI) - SUM[i=1 to N]{SUM[r=1 to Y(i)-1] C [1/(1-PI+(r-1)*THETA)]} = 0 C C SUM[i=1 to N]{SUM[r=1 to Y(i)-1] C [(r-1)/(1-PI+(r-1)*THETA)] - SUM[r=1 to Y*i] C [(r-1)/(1+(r-1)*THETA)] = 0 C C WITH THETA AND PI DENOTING THE SHAPE PARAMETERS. C C NOTE THAT C C PI = ALPHA/(ALPHA+BETA) C THETA = 1/(ALPHA + BETA) C C CALLED BY DNSQE ROUTINE FOR SOLVING SIMULTANEOUS C NONLINEAR EQUATIONS. NOTE THAT THE CALLING SEQUENCE C DID NOT ACCOMODATE A DATA ARRAY (AND ASSCIATED NUMBER OF C OBSERVATIONS), SO THESE WERE ADDED TO THE CALL LIST. C EXAMPLE--BETA-GEOMETRIC MAXIMUM LIKELIHOOD Y C REFERENCE --SUDHIR R. PAUL (2004). "APPLICATIONS OF THE C BETA DISTRIBUTION" in "HANDBOOK OF THE BETA C DISTRIBUTION", EDITED BY GUPTA AND NADARAJAH, C MARCEL-DEKKER, PP.431-436. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBUG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2006/5 C ORIGINAL VERSION--MAY 2006. C C--------------------------------------------------------------------- C DOUBLE PRECISION X(*) DOUBLE PRECISION FVEC(*) REAL XDATA(*) C DOUBLE PRECISION DN DOUBLE PRECISION DX DOUBLE PRECISION DTHETA DOUBLE PRECISION DPI DOUBLE PRECISION DC1 DOUBLE PRECISION DC2 DOUBLE PRECISION DSUM1 DOUBLE PRECISION DSUM2 DOUBLE PRECISION DSUM3 DOUBLE PRECISION DSUM4 DOUBLE PRECISION DSUM5 C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C COMPUTE SOME SUMS C DTHETA=X(1) DPI=X(2) DN=DBLE(NOBS) C DC1=DN/DPI DSUM1=0.0D0 DSUM2=0.0D0 C DO200I=1,NOBS DSUM3=0.0D0 DSUM4=0.0D0 DSUM5=0.0D0 C DX=DBLE(XDATA(I)) IX1=INT(DX+0.01) - 1 IX2=IX1+1 IF(IX1.GE.1)THEN DO300IR=1,IX1 DR=DBLE(IR) DC2=1.0D0-DPI+(DR-1.0D0)*DTHETA DSUM3=DSUM3 + 1.0D0/DC2 DSUM4=DSUM4 + (DR-1.0D0)/DC2 300 CONTINUE DSUM1=DSUM1 + DSUM3 ENDIF C IF(IX2.GE.1)THEN DO400IR=1,IX2 DR=DBLE(IR) DC2=1.0D0 + (DR-1.0D0)*DTHETA DSUM5=DSUM5 + (DR-1.0D0)/DC2 400 CONTINUE DSUM2=DSUM2 + (DSUM4 - DSUM5) ENDIF C 200 CONTINUE C FVEC(1)=DC1 - DSUM1 FVEC(2)=DSUM2 C RETURN END SUBROUTINE BGEPDF(X,ALPHA,BETA,PDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY C FUNCTION VALUE AT THE SINGLE PRECISION VALUE X C FOR THE BETA-GEOMETRIC DISTRIBUTION C WITH SINGLE PRECISION SHAPE PARAMETERS ALPHA AND BETA. C THIS DISTRIBUTION IS DEFINED FOR ALL C POSITIVE INTEGER X. C THIS DISTRIBUTION HAS THE PROBABILITY FUNCTION C p(X;ALPHA,BETA) = B(ALPHA+1,X+BETA-1)/BETA(ALPHA,BETA) C WHERE B(A,B) IS THE BETA FUNCTION. C NOTE THAT HESSELAGER GIVES THIS AS C p(X;ALPHA,BETA) = B(X+ALPHA,BETA+1)/BETA(ALPHA,BETA) C (WE USE HESSELAGER'S RECCURENCE FORMUALAS FOR THE C CDF). C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE C AT WHICH THE PROBABILITY DENSITY C FUNCTION IS TO BE EVALUATED. C X SHOULD BE A NON-NEGATIVE INTEGR C --ALPHA = THE SINGLE PRECISION VALUE C OF THE FIRST SHAPE PARAMETER. C --BETA = THE SINGLE PRECISION VALUE C OF THE SECOND SHAPE PARAMETER. C OUTPUT ARGUMENTS--PDF = THE SINGLE PRECISION PROBABILITY C C OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY C FUNCTION VALUE PDF C FOR THE BETA-GEOMETRIC DISTRIBUTION C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--X SHOULD BE A POSITIVE INTEGER C --ALPHA AND BETA SHOULD BE POSITIVE C OTHER DATAPAC SUBROUTINES NEEDED--DLBETA. C FORTRAN LIBRARY SUBROUTINES NEEDED--DEXP C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--OLE HESSELAGER (1994). "A RECURSIVE PROCEDURE C FOR CALCULATIONS OF SOME COMPOUND DISTRIBUTIONS", C ASTIN BULLETIN, VOL. 24, NO. 1, PP. 19-32. C --SUDHIR R. PAUL (2004). "APPLICATIONS OF THE C BETA DISTRIBUTION" in "HANDBOOK OF THE BETA C DISTRIBUTION", EDITED BY GUPTA AND NADARAJAH, C MARCEL-DEKKER, PP.431-436. C --JOHNSON, KOTZ, AND KEMP (1992). "UNIVARIATE C DISCRETE DISTRIBUTIONS", SECOND EDITION, C WILEY, CHAPTER 6. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG< MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2006/5 C ORIGINAL VERSION--MAY 2006. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DX DOUBLE PRECISION DALPHA DOUBLE PRECISION DBETA DOUBLE PRECISION DPDF DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 DOUBLE PRECISION DTERM3 DOUBLE PRECISION DLBETA C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C PDF=0.0 C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(ALPHA.LE.0.0)THEN WRITE(ICOUT,11) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)ALPHA CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9999 ENDIF IF(BETA.LE.0.0)THEN WRITE(ICOUT,12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)BETA CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9999 ENDIF INTX=X+0.5 FINTX=INTX IF(INTX.LT.1)THEN WRITE(ICOUT,5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)INTX CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9999 ENDIF C 5 FORMAT('***** ERROR--THE FIRST INPUT ', 1'ARGUMENT TO THE BGEPDF SUBROUTINE IS NON-POSITIVE') 11 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO THE ', 1' BGEPDF SUBROUTINE IS NON-POSITIVE') 12 FORMAT('***** ERROR--THE THIRD INPUT ARGUMENT TO THE ', 1' BGEPDF SUBROUTINE IS NON-POSITIVE') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8) 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8) C DX=DBLE(FINTX) DALPHA=DBLE(ALPHA) DBETA=DBLE(BETA) C DTERM1=DLBETA(DALPHA+1.0D0,DX+DBETA-1.0D0) DTERM2=DLBETA(DALPHA,DBETA) DTERM3=DTERM1-DTERM2 DPDF=DEXP(DTERM3) PDF=REAL(DPDF) C 9999 CONTINUE RETURN END SUBROUTINE BG2PDF(X,ALPHA,BETA,PDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY C FUNCTION VALUE AT THE SINGLE PRECISION VALUE X C FOR THE BETA-GEOMETRIC DISTRIBUTION C WITH SINGLE PRECISION SHAPE PARAMETERS ALPHA AND BETA. C THIS DISTRIBUTION IS DEFINED FOR ALL C NON-NEGATIVE INTEGER X. C THIS DISTRIBUTION HAS THE PROBABILITY FUNCTION C p(X;ALPHA,BETA) = B(ALPHA+1,X+BETA)/BETA(ALPHA,BETA) C WHERE B(A,B) IS THE BETA FUNCTION. C NOTE THAT HESSELAGER GIVES THIS AS C p(X;ALPHA,BETA) = B(X+ALPHA,BETA+1)/BETA(ALPHA,BETA) C THAT IS, THE ALPHA AND BETA ARE REVERSED. C (WE USE HESSELAGER'S RECCURENCE FORMUALAS FOR THE C CDF). C C NOTE THAT THE BGEPDF ROUTINE IS THE BETA-GEOMETRIC C THAT STARTS WITH X = 1 WHEREAS THIS ROUTINE IS C SHIFTED TO START AT X = 0. C C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE C AT WHICH THE PROBABILITY DENSITY C FUNCTION IS TO BE EVALUATED. C X SHOULD BE A NON-NEGATIVE INTEGR C --ALPHA = THE SINGLE PRECISION VALUE C OF THE FIRST SHAPE PARAMETER. C --BETA = THE SINGLE PRECISION VALUE C OF THE SECOND SHAPE PARAMETER. C OUTPUT ARGUMENTS--PDF = THE SINGLE PRECISION PROBABILITY C C OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY C FUNCTION VALUE PDF C FOR THE BETA-GEOMETRIC DISTRIBUTION C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--X SHOULD BE A NON-NEGATIVE INTEGER C --ALPHA AND BETA SHOULD BE POSITIVE C OTHER DATAPAC SUBROUTINES NEEDED--DLBETA. C FORTRAN LIBRARY SUBROUTINES NEEDED--DEXP C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--OLE HESSELAGER (1994). "A RECURSIVE PROCEDURE C FOR CALCULATIONS OF SOME COMPOUND DISTRIBUTIONS", C ASTIN BULLETIN, VOL. 24, NO. 1, PP. 19-32. C --SUDHIR R. PAUL (2004). "APPLICATIONS OF THE C BETA DISTRIBUTION" in "HANDBOOK OF THE BETA C DISTRIBUTION", EDITED BY GUPTA AND NADARAJAH, C MARCEL-DEKKER, PP.431-436. C --JOHNSON, KOTZ, AND KEMP (1992). "UNIVARIATE C DISCRETE DISTRIBUTIONS", SECOND EDITION, C WILEY, CHAPTER 6. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG< MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2006/5 C ORIGINAL VERSION--MAY 2006. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DX DOUBLE PRECISION DALPHA DOUBLE PRECISION DBETA DOUBLE PRECISION DPDF DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 DOUBLE PRECISION DTERM3 DOUBLE PRECISION DLBETA C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C PDF=0.0 C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(ALPHA.LE.0.0)THEN WRITE(ICOUT,11) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)ALPHA CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9999 ENDIF IF(BETA.LE.0.0)THEN WRITE(ICOUT,12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)BETA CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9999 ENDIF INTX=X+0.5 FINTX=INTX IF(INTX.LT.0)THEN WRITE(ICOUT,5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)INTX CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9999 ENDIF C 5 FORMAT('***** ERROR--THE FIRST INPUT ', 1'ARGUMENT TO THE BG2PDF SUBROUTINE IS NEGATIVE') 11 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO THE ', 1' BG2PDF SUBROUTINE IS NON-POSITIVE') 12 FORMAT('***** ERROR--THE THIRD INPUT ARGUMENT TO THE ', 1' BG2PDF SUBROUTINE IS NON-POSITIVE') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8) 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8) C DX=DBLE(FINTX) DALPHA=DBLE(ALPHA) DBETA=DBLE(BETA) C DTERM1=DLBETA(DALPHA+1.0D0,DX+DBETA) DTERM2=DLBETA(DALPHA,DBETA) DTERM3=DTERM1-DTERM2 DPDF=DEXP(DTERM3) PDF=REAL(DPDF) C 9999 CONTINUE RETURN END SUBROUTINE BGEPPF(P,ALPHA,BETA,PPF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT C FUNCTION VALUE AT THE SINGLE PRECISION VALUE P C FOR THE BETA-GEOMETRIC DISTRIBUTION C WITH SINGLE PRECISION SHAPE PARAMETERS ALPHA AND BETA. C THIS DISTRIBUTION IS DEFINED FOR 0 <= P < 1. C C THIS DISTRIBUTION HAS THE PROBABILITY FUNCTION C p(X;ALPHA,BETA) = B(ALPHA+1,X+BETA-1)/BETA(ALPHA,BETA) C WHERE B(A,B) IS THE BETA FUNCTION. C NOTE THAT HESSELAGER GIVES THIS AS C p(X;ALPHA,BETA) = B(X+ALPHA,BETA+1)/BETA(ALPHA,BETA) C (WE USE HESSELAGER'S RECCURENCE FORMUALAS FOR THE C CDF). C C HESSELAGER'S RECURRENCE FORMULA FOR THE CUMULATIVE C DISTRIBUTION FUNCTION IS: C C p(X;ALHA,BETA) - [(X+ALPHA-1)/(X+ALPHA+BETA)]* C p(X-1;ALPHA,BETA) C C CONVERTING THIS TO THE MORE COMMON PARAMETERIZATION C YIELDS C C p(X;ALHA,BETA) - [(X+BETA-2)/(X+ALPHA+BETA-1)]* C p(X-1;ALPHA,BETA) C C WE CURRENTLY COMPUTE THE PERCENT POINT FUNCTION C VIA BRUTE FORCE. THAT IS, WE COMPUTE THE C CUMULATIVE DISTRIBUTION FUNCTION UNTIL IT EXCEEDS C THE SPECIFIED VALUE OF P. C C INPUT ARGUMENTS--P = THE SINGLE PRECISION VALUE C AT WHICH THE PERCENT POINT C FUNCTION IS TO BE EVALUATED. C 0 <= P < 1. C --ALPHA = THE SINGLE PRECISION VALUE C OF THE FIRST SHAPE PARAMETER. C --BETA = THE SINGLE PRECISION VALUE C OF THE SECOND SHAPE PARAMETER. C OUTPUT ARGUMENTS--PPF = THE SINGLE PRECISION PERCENT POINT C FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION PERCENT POINT FUNCTION VALUE PPF C FOR THE BETA-GEOMETRIC DISTRIBUTION C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--0 <= P < 1 C --ALPHA AND BETA SHOULD BE POSITIVE C OTHER DATAPAC SUBROUTINES NEEDED--DLBETA. C FORTRAN LIBRARY SUBROUTINES NEEDED--DEXP C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--OLE HESSELAGER (1994). "A RECURSIVE PROCEDURE C FOR CALCULATIONS OF SOME COMPOUND DISTRIBUTIONS", C ASTIN BULLETIN, VOL. 24, NO. 1, PP. 19-32. C --SUDHIR R. PAUL (2004). "APPLICATIONS OF THE C BETA DISTRIBUTION" in "HANDBOOK OF THE BETA C DISTRIBUTION", EDITED BY GUPTA AND NADARAJAH, C MARCEL-DEKKER, PP.431-436. C --JOHNSON, KOTZ, AND KEMP (1992). "UNIVARIATE C DISCRETE DISTRIBUTIONS", SECOND EDITION, C WILEY, CHAPTER 6. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG< MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2006/5 C ORIGINAL VERSION--MAY 2006. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DX DOUBLE PRECISION DP DOUBLE PRECISION DALPHA DOUBLE PRECISION DBETA DOUBLE PRECISION DCDF DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 DOUBLE PRECISION DTERM3 DOUBLE PRECISION DLBETA DOUBLE PRECISION DSUM DOUBLE PRECISION DPDF DOUBLE PRECISION DPDFSV C INCLUDE 'DPCOMC.INC' C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT--------------------------------------------------- C PPF=0.0 C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(ALPHA.LE.0.0)THEN WRITE(ICOUT,11) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)ALPHA CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9999 ENDIF IF(BETA.LE.0.0)THEN WRITE(ICOUT,12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)BETA CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9999 ENDIF IF(P.LT.0.0.OR.P.GE.1.0)THEN WRITE(ICOUT,1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)P CALL DPWRST('XXX','BUG ') PPF=0.0 ENDIF C 1 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO THE ', 1' BGEPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1] INTERVAL') 11 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO THE ', 1' BGEPPF SUBROUTINE IS NON-POSITIVE') 12 FORMAT('***** ERROR--THE THIRD INPUT ARGUMENT TO THE ', 1' BGEPPF SUBROUTINE IS NON-POSITIVE') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8) 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8) C DALPHA=DBLE(ALPHA) DBETA=DBLE(BETA) DSUM=0.0D0 DP=DBLE(P) C C COMPUTE PDF FOR X = 1 C DTERM1=DLBETA(DALPHA+1.0D0,DBETA) DTERM2=DLBETA(DALPHA,DBETA) DTERM3=DTERM1-DTERM2 DPDFSV=DEXP(DTERM3) DSUM=DPDFSV IF(DSUM.GE.DP)THEN PPF=1.0 GOTO9999 ENDIF I=1 C 100 CONTINUE I=I+1 IF(DBLE(I).GE.DBLE(I1MACH(9)))THEN WRITE(ICOUT,55) 55 FORMAT('***** ERROR--THE COMPUTED PERCENT POINT VALUE ', 1 'EXCEEDS THE LARGEST MACHINE INTEGER.') CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9999 ENDIF CCCCC DPDF=DPDFSV*(DBLE(I)+DALPHA-1.0D0)/(DBLE(I)+DALPHA+DBETA) DPDF=DPDFSV*(DBLE(I)+DBETA-2.0D0)/ 1 (DBLE(I)+DALPHA+DBETA-1.0D0) DPDFSV=DPDF DSUM=DSUM + DPDF IF(DSUM.GE.DP)THEN PPF=REAL(I) GOTO9999 ENDIF GOTO100 C 9999 CONTINUE RETURN END SUBROUTINE BG2PPF(P,ALPHA,BETA,PPF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT C FUNCTION VALUE AT THE SINGLE PRECISION VALUE P C FOR THE BETA-GEOMETRIC DISTRIBUTION C WITH SINGLE PRECISION SHAPE PARAMETERS ALPHA AND BETA. C THIS DISTRIBUTION IS DEFINED FOR 0 <= P < 1. C C THIS DISTRIBUTION HAS THE PROBABILITY FUNCTION C p(X;ALPHA,BETA) = B(ALPHA+1,X+BETA-1)/BETA(ALPHA,BETA) C WHERE B(A,B) IS THE BETA FUNCTION. C NOTE THAT HESSELAGER GIVES THIS AS C p(X;ALPHA,BETA) = B(X+ALPHA,BETA+1)/BETA(ALPHA,BETA) C THAT IS, THE ALPHA AND BETA ARE REVERSED. C (WE USE HESSELAGER'S RECCURENCE FORMUALAS FOR THE C CDF). C C HESSELAGER'S RECURRENCE FORMULA FOR THE CUMULATIVE C DISTRIBUTION FUNCTION IS: C C p(X;ALHA,BETA) - [(X+ALPHA-1)/(X+ALPHA+BETA)]* C p(X-1;ALPHA,BETA) C C REVERSING THE ALPHA AND BETA YIELDS C C p(X;ALHA,BETA) - [(X+BETA-1)/(X+ALPHA+BETA)]* C p(X-1;ALPHA,BETA) C C WE CURRENTLY COMPUTE THE PERCENT POINT FUNCTION C VIA BRUTE FORCE. THAT IS, WE COMPUTE THE C CUMULATIVE DISTRIBUTION FUNCTION UNTIL IT EXCEEDS C THE SPECIFIED VALUE OF P. C C NOTE THAT THE BGEPPF ROUTINE IS THE BETA-GEOMETRIC C THAT STARTS WITH X = 1 WHEREAS THIS ROUTINE IS C SHIFTED TO START AT X = 0. C C INPUT ARGUMENTS--P = THE SINGLE PRECISION VALUE C AT WHICH THE PERCENT POINT C FUNCTION IS TO BE EVALUATED. C 0 <= P < 1. C --ALPHA = THE SINGLE PRECISION VALUE C OF THE FIRST SHAPE PARAMETER. C --BETA = THE SINGLE PRECISION VALUE C OF THE SECOND SHAPE PARAMETER. C OUTPUT ARGUMENTS--PPF = THE SINGLE PRECISION PERCENT POINT C FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION PERCENT POINT FUNCTION VALUE PPF C FOR THE BETA-GEOMETRIC DISTRIBUTION C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--0 <= P < 1 C --ALPHA AND BETA SHOULD BE POSITIVE C OTHER DATAPAC SUBROUTINES NEEDED--DLBETA. C FORTRAN LIBRARY SUBROUTINES NEEDED--DEXP C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--OLE HESSELAGER (1994). "A RECURSIVE PROCEDURE C FOR CALCULATIONS OF SOME COMPOUND DISTRIBUTIONS", C ASTIN BULLETIN, VOL. 24, NO. 1, PP. 19-32. C --SUDHIR R. PAUL (2004). "APPLICATIONS OF THE C BETA DISTRIBUTION" in "HANDBOOK OF THE BETA C DISTRIBUTION", EDITED BY GUPTA AND NADARAJAH, C MARCEL-DEKKER, PP.431-436. C --JOHNSON, KOTZ, AND KEMP (1992). "UNIVARIATE C DISCRETE DISTRIBUTIONS", SECOND EDITION, C WILEY, CHAPTER 6. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG< MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2006/5 C ORIGINAL VERSION--MAY 2006. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DX DOUBLE PRECISION DP DOUBLE PRECISION DALPHA DOUBLE PRECISION DBETA DOUBLE PRECISION DCDF DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 DOUBLE PRECISION DTERM3 DOUBLE PRECISION DLBETA DOUBLE PRECISION DSUM DOUBLE PRECISION DPDF DOUBLE PRECISION DPDFSV C INCLUDE 'DPCOMC.INC' C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT--------------------------------------------------- C PPF=0.0 C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(ALPHA.LE.0.0)THEN WRITE(ICOUT,11) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)ALPHA CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9999 ENDIF IF(BETA.LE.0.0)THEN WRITE(ICOUT,12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)BETA CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9999 ENDIF IF(P.LT.0.0.OR.P.GE.1.0)THEN WRITE(ICOUT,1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)P CALL DPWRST('XXX','BUG ') PPF=0.0 ENDIF C 1 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO THE ', 1' BG2PPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1] INTERVAL') 11 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO THE ', 1' BG2PPF SUBROUTINE IS NON-POSITIVE') 12 FORMAT('***** ERROR--THE THIRD INPUT ARGUMENT TO THE ', 1' BG2PPF SUBROUTINE IS NON-POSITIVE') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8) 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8) C DALPHA=DBLE(ALPHA) DBETA=DBLE(BETA) DSUM=0.0D0 DP=DBLE(P) C C COMPUTE PDF FOR X = 1 C DTERM1=DLBETA(DALPHA+1.0D0,DBETA) DTERM2=DLBETA(DALPHA,DBETA) DTERM3=DTERM1-DTERM2 DPDFSV=DEXP(DTERM3) DSUM=DPDFSV IF(DSUM.GE.DP)THEN PPF=0.0 GOTO9999 ENDIF I=0 C 100 CONTINUE I=I+1 IF(DBLE(I).GE.DBLE(I1MACH(9)))THEN WRITE(ICOUT,55) 55 FORMAT('***** ERROR--THE COMPUTED PERCENT POINT VALUE ', 1 'EXCEEDS THE LARGEST MACHINE INTEGER.') CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9999 ENDIF DPDF=DPDFSV*(DBLE(I)+DBETA-1.0D0)/ 1 (DBLE(I)+DALPHA+DBETA) DPDFSV=DPDF DSUM=DSUM + DPDF IF(DSUM.GE.DP)THEN PPF=REAL(I) GOTO9999 ENDIF GOTO100 C 9999 CONTINUE RETURN END SUBROUTINE BGERAN(ALPHA,BETA,N,ISEED,X,IBGEDF) C C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N C FROM THE BETA-GEOMETRIC DISTRIBUTION C WITH SINGLE PRECISION 'BERNOULLI PROBABILITY' C PARAMETER = P FOLLOWING A BETA DISTRIBUTION WITH C SHAPE PARAMETERS ALPHA AND BETA. C AND NPAR (INCLUSIVELY). C INPUT ARGUMENTS--N = THE DESIRED INTEGER NUMBER C OF RANDOM NUMBERS TO BE C GENERATED. C --ALPHA = THE SINGLE PRECISION VALUE C OF THE FIRST SHAPE PARAMETER OF THE C BETA DISTRIBUTION. C ALPHA > 0. C --BETA = THE SINGLE PRECISION VALUE C OF THE SECOND SHAPE PARAMETER OF THE C BETA DISTRIBUTION. C BETA > 0. C OUTPUT ARGUMENTS--X = A SINGLE PRECISION VECTOR C (OF DIMENSION AT LEAST N) C INTO WHICH THE GENERATED C RANDOM SAMPLE WILL BE PLACED. C OUTPUT--A RANDOM SAMPLE OF SIZE N C FROM THE BETA-GEOMETRIC DISTRIBUTION. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C --ALPHA, BETA > 0 C OTHER DATAPAC SUBROUTINES NEEDED--UNIRAN, GEORAN. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C COMMENT--NOTE THAT EVEN THOUGH THE OUTPUT C FROM THIS DISCRETE RANDOM NUMBER C GENERATOR MUST NECESSARILY BE A C SEQUENCE OF ***INTEGER*** VALUES, C THE OUTPUT VECTOR X IS SINGLE C PRECISION IN MODE. C X HAS BEEN SPECIFIED AS SINGLE C PRECISION SO AS TO CONFORM WITH THE DATAPAC C CONVENTION THAT ALL OUTPUT VECTORS FROM ALL C DATAPAC SUBROUTINES ARE SINGLE PRECISION. C THIS CONVENTION IS BASED ON THE BELIEF THAT C 1) A MIXTURE OF MODES (FLOATING POINT C VERSUS INTEGER) IS INCONSISTENT AND C AN UNNECESSARY COMPLICATION C IN A DATA ANALYSIS; AND C 2) FLOATING POINT MACHINE ARITHMETIC C (AS OPPOSED TO INTEGER ARITHMETIC) C IS THE MORE NATURAL MODE FOR DOING C DATA ANALYSIS. C REFERENCES--OLE HESSELAGER (1994). "A RECURSIVE PROCEDURE C FOR CALCULATIONS OF SOME COMPOUND DISTRIBUTIONS", C ASTIN BULLETIN, VOL. 24, NO. 1, PP. 19-32. C --SUDHIR R. PAUL (2004). "APPLICATIONS OF THE C BETA DISTRIBUTION" in "HANDBOOK OF THE BETA C DISTRIBUTION", EDITED BY GUPTA AND NADARAJAH, C MARCEL-DEKKER, PP.431-436. C --JOHNSON, KOTZ, AND KEMP (1992). "UNIVARIATE C DISCRETE DISTRIBUTIONS", SECOND EDITION, C WILEY, CHAPTER 6. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2006/5 C ORIGINAL VERSION--MAY 2006. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DIMENSION X(*) C DIMENSION XTEMP(1) C CHARACTER*4 IBGEDF C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(N.LT.1)THEN WRITE(ICOUT, 5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)N CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF IF(ALPHA.LE.0.0)THEN WRITE(ICOUT,11) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)ALPHA CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF IF(BETA.LE.0.0)THEN WRITE(ICOUT,12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)BETA CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF 5 FORMAT('***** ERROR--NUMBER OF BETA-GEOMETRIC RANDOM ', 1'NUMBERS REQUESTED < 1') 11 FORMAT('***** ERROR--THE ALPHA SHAPE PARAMETER ARGUMENT', 1' TO THE BGERAN SUBROUTINE IS <= 0') 12 FORMAT('***** ERROR--THE BETA SHAPE PARAMETER ARGUMENT', 1' TO THE BGERAN SUBROUTINE IS <= 0') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.8) 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8) C C FIRST, GENERATE N BETA RANDOM NUMBERS. C CALL BETRAN(N,ALPHA,BETA,ISEED,X) C NTEMP=1 DO100I=1,N C 110 CONTINUE P=X(I) IF(P.LE.0.0 .OR. P.GE.1.0)THEN CALL BETRAN(NTEMP,ALPHA,BETA,ISEED,X(I)) GOTO110 ENDIF CALL GE2RAN(NTEMP,P,ISEED,XTEMP) X(I)=XTEMP(1) IF(IBGEDF.EQ.'SHIF')X(I)=X(I)-1.0 C 100 CONTINUE C 9000 CONTINUE RETURN END SUBROUTINE BILINR(Z,Y,X,N,Y2,X2,N2,IWRITE,Z2, 1IBUGG3,ISUBRO,IERROR) C C PURPOSE--COMPUTE BI-LINEAR INTERPOLATION OF A VARIABLE C (GENERATE INTERPOLATED POINTS). C INPUT ARGUMENTS--Z = SINGLE PRECISION VARIABLE C CONTAINING THE ORIGINAL C Z AXIS DATA POINTS. C --Y = SINGLE PRECISION VARIABLE C CONTAINING THE ORIGINAL C VERTICAL AXIS DATA POINTS. C --X = SINGLE PRECISION VARIABLE C CONTAINING THE ORIGINAL C HORIZONTAL AXIS DATA POINTS. C --Y2 = SINGLE PRECISION VARIABLE C CONTAINING THE DESIRED C VERTICAL AXIS INTERPOLATION C --X2 = SINGLE PRECISION VARIABLE C CONTAINING THE DESIRED C HORIZONTAL AXIS INTERPOLATION C POINTS. C OUTPUT ARGUMENTS--Z2 = SINGLE PRECISION VARIABLE C CONTAINING THE COMPUTED C Z AXIS INTERPOLATION C POINTS. C NOTE--IT IS PROBABLY NOT PERMISSIBLE TO HAVE THE OUTPUT VECTOR C Y2(.) BEING IDENTICAL TO THE INPUT VECTOR Y(.) C NOTE--THIS SUBROUTINE DOES NOT ASSUME THAT THE INPUT C DATA IS ALREADY SORTED ACCORDING TO THE C HORIZONTAL AXIS VARIABLE. C SUCH SORTING IS DOEN HEREIN. C NOTE--IT DOES ASSUME THAT THE ORIGINAL (Y,X) POINTS FORM A C RECTANGULAR GRID (ALTHOUGH THE GRID DOES NOT HAVE TO BE C PRE-SORTED). C CAUTION--THE INPUT VECTORS Y AND X ARE SORTED HEREIN C AND SO MAY BE DIFFERENT UPON LEAVING THIS SUBROUTINE C THAN UPON ENTERING THIS SUBROUTINE. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--94/5 C ORIGINAL VERSION--MAY 1994. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IWRITE CHARACTER*4 IBUGG3 CHARACTER*4 ISUBRO CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C--------------------------------------------------------------------- C INCLUDE 'DPCOPA.INC' C DIMENSION Z(*) DIMENSION Y(*) DIMENSION X(*) DIMENSION X2(*) DIMENSION Y2(*) DIMENSION Z2(*) C DIMENSION YTEMP(MAXOBV) DIMENSION XTEMP(MAXOBV) DIMENSION YDIST(MAXOBV) DIMENSION XDIST(MAXOBV) DIMENSION ZDIST(MAXOBV) DIMENSION ZTEMP2(MAXOBV) DIMENSION ZTEMP(MAXOBV) C INCLUDE 'DPCOZZ.INC' INCLUDE 'DPCOZ2.INC' EQUIVALENCE (G2RBAG(IGAR11),YTEMP(1)) EQUIVALENCE (G2RBAG(IGAR12),YDIST(1)) EQUIVALENCE (G2RBAG(IGAR13),XDIST(1)) EQUIVALENCE (G2RBAG(IGAR14),ZDIST(1)) EQUIVALENCE (G2RBAG(IGAR15),ZTEMP2(1)) EQUIVALENCE (G2RBAG(IGAR16),ZTEMP(1)) EQUIVALENCE (G2RBAG(IGAR17),XTEMP(1)) CCCCC END CHANGE C C-----COMMON VARIABLES (GENERAL)-------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='BILI' ISUBN2='NR ' C IERROR='NO' C IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'LINR')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF BILINR--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)N 52 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') DO55I=1,N WRITE(ICOUT,56)I,Z(I),Y(I),X(I) 56 FORMAT('I,Z(I),Y(I),X(I) = ',I8,3E15.7) CALL DPWRST('XXX','BUG ') 55 CONTINUE WRITE(ICOUT,62)N2 62 FORMAT('N2 = ',I8) CALL DPWRST('XXX','BUG ') DO65I=1,N2 WRITE(ICOUT,66)I,Y2(I),X2(I) 66 FORMAT('I,Y2(I),X2(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 65 CONTINUE 90 CONTINUE C C **************************************** C ** STEP 11-- ** C ** SORT THE INPUT DATA ACCORDING ** C ** TO THE HORIZONTAL AXIS VARIABLE ** C **************************************** C ISTEPN='11' IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'LINR') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C DO1010,I=1,N XTEMP(I)=X(I) 1010 CONTINUE C CALL SORTC(X,Y,N,X,Y) CALL SORTC(XTEMP,Z,N,XTEMP,Z) C C ******************************************************* C ** STEP 12-- ** C ** DETERMINE THE NUMBER OF DISTINCT X VALUES ** C ******************************************************* C ISTEPN='12' IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'LINR') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NDISTX=0 DO1210I=1,N IF(NDISTX.EQ.0)GOTO1220 DO1215I2=1,NDISTX IF(X(I).EQ.XDIST(I2))GOTO1210 1215 CONTINUE 1220 CONTINUE NDISTX=NDISTX+1 XDIST(NDISTX)=X(I) 1210 CONTINUE C CALL SORT(XDIST,NDISTX,XDIST) C C ******************************************************* C ** STEP 13-- ** C ** DETERMINE THE NUMBER OF DISTINCT Y VALUES ** C ******************************************************* C ISTEPN='13' IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'LINR') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NDISTY=0 DO1310I=1,N IF(NDISTY.EQ.0)GOTO1320 DO1315I2=1,NDISTY IF(Y(I).EQ.YDIST(I2))GOTO1310 1315 CONTINUE 1320 CONTINUE NDISTY=NDISTY+1 YDIST(NDISTY)=Y(I) 1310 CONTINUE C CALL SORT(YDIST,NDISTY,YDIST) C C ******************************************************* C ** STEP 14-- ** C ** SORT Y ASSOCIATED WITH EACH DISTINCT X VALUE ** C ** CHECK FOR REPLICATION OF POINTS ** C ** IF ALL DISTINCT (THAT IS, NO REPLICATION), ** C ** (THAT IS, HAVE NO REPLICATION), ** C ** THEN COPY OVER Z VALUES. ** C ** IF NOT ALL DISTINCT ** C ** (THAT IS, HAVE SOME REPLICATION), ** C ** THEN COMPUTE A MEAN VALUE OVER THE REPLICATES ** C ** AND TREAT THAT AS THE COMMON VALUE. ** C ** THE CORE OF THE INTERPOLATION CODE ** C ** IS EXPECTING SORTED, DISTINCT X AND Y VALUES. ** C ** ALSO CHECK THAT X AND Y FORM A RECTANGULAR GRID.** C ******************************************************* C ISTEPN='14' IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'LINR') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NUMZ=0 ISTART=1 DO1410I=1,NDISTX XT=XDIST(I) ICOUNT=0 DO1420J=ISTART,N IF(X(J).EQ.XT)THEN IF(ICOUNT.EQ.0)IFRST=J ICOUNT=ICOUNT+1 YTEMP(ICOUNT)=Y(J) ZTEMP(ICOUNT)=Z(J) ILAST=J ELSEIF(X(J).GT.XT)THEN GOTO1421 ENDIF 1420 CONTINUE 1421 CONTINUE C ISTART=ILAST+1 CALL SORTC(YTEMP,ZTEMP,ICOUNT,YTEMP,ZTEMP) DO1471K=1,NDISTY TAG=YDIST(K) J=0 DO1472II=1,ICOUNT IF(YTEMP(II).EQ.TAG)THEN J=J+1 ZTEMP2(J)=ZTEMP(II) END IF 1472 CONTINUE NI=J IF(NI.EQ.1)THEN NUMZ=NUMZ+1 ZDIST(NUMZ)=ZTEMP2(1) ELSE IF(NI.GT.1)THEN CALL MEAN(ZTEMP2,NI,IWRITE,ZMEAN,IBUGG3,IERROR) NUMZ=NUMZ+1 ZDIST(NUMZ)=ZMEAN ELSE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1491) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1492) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ENDIF 1471 CONTINUE C 1410 CONTINUE C 1491 FORMAT('******* ERROR FROM BILINR. ORIGINAL X AND Y') 1492 FORMAT(' DATA DO NOT FORM A RECTANGULAR GRID. ******') C C ******************************************** C ** STEP 14-- ** C ** COMPUTE INTERPOLATED VALUES ** C ******************************************** C CALL BILIN2(ZDIST,YDIST,XDIST,NDISTX,NDISTY,Y2,X2,N2,Z2, 1IBUGG3,ISUBRO,IERROR) C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C 9000 CONTINUE IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'LINR')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF BILINR--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)N,N2 9012 FORMAT('N,N2 = ',2I8) CALL DPWRST('XXX','BUG ') DO9042I=1,N2 WRITE(ICOUT,9043)I,X2(I),Y2(I),Z2(I) 9043 FORMAT('I,X2(I),Y2(I),Z2(I) = ',I8,3E15.7) CALL DPWRST('XXX','BUG ') 9042 CONTINUE WRITE(ICOUT,9051)NDISTX,NDISTY 9051 FORMAT('NDISTX,NDISTY = ',2I8) CALL DPWRST('XXX','BUG ') DO9052I=1,NDISTX DO9054J=1,NDISTY WRITE(ICOUT,9053)I,J,XDIST(I),YDIST(J),ZDIST((I-1)*NDISTY+J) 9053 FORMAT('I,J,XDIST(I),YDIST(J),ZDIST = ',2I8,3E15.7) CALL DPWRST('XXX','BUG ') 9054 CONTINUE 9052 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE BILIN2(Z,Y,X,NX,NY,Y2,X2,N2,Z2,IBUGG3,ISUBRO,IERROR) C C PURPOSE--COMPUTE BI-LINEAR INTERPOLATION OF A VARIABLE C (GENERATE INTERPOLATED POINTS). C INPUT ARGUMENTS--Z = SINGLE PRECISION VARIABLE C CONTAINING THE ORIGINAL C Z AXIS DATA POINTS. C --Y = SINGLE PRECISION VARIABLE C CONTAINING THE ORIGINAL C VERTICAL AXIS DATA POINTS. C --X = SINGLE PRECISION VARIABLE C CONTAINING THE ORIGINAL C HORIZONTAL AXIS DATA POINTS. C --Y2 = SINGLE PRECISION VARIABLE C CONTAINING THE DESIRED C VERTICAL AXIS INTERPOLATION C --X2 = SINGLE PRECISION VARIABLE C CONTAINING THE DESIRED C HORIZONTAL AXIS INTERPOLATION C POINTS. C OUTPUT ARGUMENTS--Z2 = SINGLE PRECISION VARIABLE C CONTAINING THE COMPUTED C VERTICAL AXIS INTERPOLATION C POINTS. C NOTE--IT IS PROBABLY NOT PERMISSIBLE TO HAVE THE OUTPUT VECTOR C Z2(.) BEING IDENTICAL TO THE INPUT VECTOR Z(.) C NOTE--THE X AND Y POINTS ARE ASSUMED TO LIE ON A RECTANGULAR GRID C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--94/5 C ORIGINAL VERSION--MAY 1994. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IBUGG3 CHARACTER*4 ISUBRO CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C C DIMENSION Z(*) DIMENSION Y(*) DIMENSION X(*) DIMENSION Z2(*) DIMENSION Y2(*) DIMENSION X2(*) C C-----COMMON VARIABLES (GENERAL)-------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='BILI' ISUBN2='N2 ' C IERROR='NO' C DO10I=1,N2 Z2(I)=0.0 10 CONTINUE C IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'LIN2')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF BILIN2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)NX,NY 52 FORMAT('NX, NY = ',2I8) CALL DPWRST('XXX','BUG ') DO54I=1,NX DO55J=1,NY INDX=(I-1)*NY+J WRITE(ICOUT,53)I,J,X(I),Y(J),Z(INDX) CALL DPWRST('XXX','BUG ') 53 FORMAT('I,J,X(I),Y(J),Z = ',2I8,3E15.7) CALL DPWRST('XXX','BUG ') 55 CONTINUE 54 CONTINUE WRITE(ICOUT,62)N2 62 FORMAT('N2 = ',I8) CALL DPWRST('XXX','BUG ') DO65I=1,N2 WRITE(ICOUT,66)I,Y2(I),X2(I) 66 FORMAT('I,Y2(I),X2(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 65 CONTINUE 90 CONTINUE C C **************************************** C ** STEP 31-- C ** COMPUTE INTERPOLATION VALUES C **************************************** C DO3100J=1,N2 XT=X2(J) IF(X(1).GT.XT.OR.XT.GT.X(NX))GOTO3110 YT=Y2(J) IF(Y(1).GT.YT.OR.YT.GT.Y(NY))GOTO3120 GOTO3129 C 3110 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3111) 3111 FORMAT('***** ERROR IN BILIN2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3112) 3112 FORMAT(' AN ATTEMPT WAS MADE TO COMPUTE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3113) 3113 FORMAT(' A SMOOTHED VALUE BEYOND THE X RANGE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3114) 3114 FORMAT(' OF THE DATA--SUCH EXTRAPOLATION') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3115) 3115 FORMAT(' IS UNRELIABLE AND NOT PERMITTED.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3116)X(1) 3116 FORMAT(' SMALLEST DATA POINT X(1) = ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3117)X(NX) 3117 FORMAT(' LARGEST DATA POINT X(NX) = ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3118)XT 3118 FORMAT(' ATTEMPTED EXTRAPOLATION POINT = ',E15.7) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 3120 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3121) 3121 FORMAT('***** ERROR IN BILIN2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3122) 3122 FORMAT(' AN ATTEMPT WAS MADE TO COMPUTE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3123) 3123 FORMAT(' A SMOOTHED VALUE BEYOND THE Y RANGE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3124) 3124 FORMAT(' OF THE DATA--SUCH EXTRAPOLATION') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3125) 3125 FORMAT(' IS UNRELIABLE AND NOT PERMITTED.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3126)Y(1) 3126 FORMAT(' SMALLEST DATA POINT Y(1) = ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3127)Y(NY) 3127 FORMAT(' LARGEST DATA POINT Y(NY) = ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3128)YT 3128 FORMAT(' ATTEMPTED EXTRAPOLATION POINT = ',E15.7) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 3129 CONTINUE C DO3200I=1,NX-1 IF(XT.GE.X(I).AND.XT.LE.X(I+1))THEN IX1=I IX2=I+1 GOTO3209 ENDIF 3200 CONTINUE 3209 CONTINUE C DO3210I=1,NY-1 IF(YT.GE.Y(I).AND.YT.LE.Y(I+1))THEN IY1=I IY2=I+1 GOTO3219 ENDIF 3210 CONTINUE 3219 CONTINUE C A1=Z(NX*(IX1-1)+IY1) A2=Z(NX*(IX2-1)+IY1) A3=Z(NX*(IX2-1)+IY2) A4=Z(NX*(IX1-1)+IY2) T=XT-X(IX1)/(X(IX2)-X(IX1)) U=YT-Y(IY1)/(Y(IY2)-Y(IY1)) Z2(J)=(1.0-T)*(1.0-U)*A1 + T*(1.0-U)*A2 + T*U*A3 + (1.0-T)*U*A4 C 3100 CONTINUE C C **************************************** C ** STEP 41-- C ** IF CALLED FOR, C ** WRITE OUT INTERPOLATION VALUES C **************************************** C IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'LIN2')GOTO4190 DO4100J=1,N2 WRITE(ICOUT,4110)X2(J),Y2(J),Z2(J) CALL DPWRST('XXX','BUG ') 4110 FORMAT('X2(J),Y2(J),Z2(J) = ',3E15.7) 4100 CONTINUE 4190 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C 9000 CONTINUE IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'LIN2')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF BILIN2--') CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE BINCDF(X,P,N,CDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION C FUNCTION VALUE AT THE SINGLE PRECISION VALUE X C FOR THE BINOMIAL DISTRIBUTION C WITH SINGLE PRECISION 'BERNOULLI PROBABILITY' C PARAMETER = P, C AND INTEGER 'NUMBER OF BERNOULLI TRIALS' C PARAMETER = N. C THE BINOMIAL DISTRIBUTION USED C HEREIN HAS MEAN = N*P C AND STANDARD DEVIATION = SQRT(N*P*(1-P)). C THIS DISTRIBUTION IS DEFINED FOR ALL C DISCRETE INTEGER X BETWEEN 0 (INCLUSIVELY) C AND N (INCLUSIVELY). C THIS DISTRIBUTION HAS THE PROBABILITY FUNCTION C F(X) = C(N,X) * P**X * (1-P)**(N-X). C WHERE C(N,X) IS THE COMBINATORIAL FUNCTION C EQUALING THE NUMBER OF COMBINATIONS OF N ITEMS C TAKEN X AT A TIME. C THE BINOMIAL DISTRIBUTION IS THE C DISTRIBUTION OF THE NUMBER OF C SUCCESSES IN N BERNOULLI (0,1) C TRIALS WHERE THE PROBABILITY OF SUCCESS C IN A SINGLE TRIAL = P. C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE C AT WHICH THE CUMULATIVE DISTRIBUTION C FUNCTION IS TO BE EVALUATED. C X SHOULD BE INTEGRAL-VALUED, C AND BETWEEN 0.0 (INCLUSIVELY) C AND N (INCLUSIVELY). C --P = THE SINGLE PRECISION VALUE C OF THE 'BERNOULLI PROBABILITY' C PARAMETER FOR THE BINOMIAL C DISTRIBUTION. C P SHOULD BE BETWEEN C 0.0 (EXCLUSIVELY) AND C 1.0 (EXCLUSIVELY). C --N = THE INTEGER VALUE C OF THE 'NUMBER OF BERNOULLI TRIALS' C PARAMETER. C N SHOULD BE A POSITIVE INTEGER. C OUTPUT ARGUMENTS--CDF = THE SINGLE PRECISION CUMULATIVE C DISTRIBUTION FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION C FUNCTION VALUE CDF C FOR THE BINOMIAL DISTRIBUTION C WITH 'BERNOULLI PROBABILITY' PARAMETER = P C AND 'NUMBER OF BERNOULLI TRIALS' PARAMETER = N. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--X SHOULD BE INTEGRAL-VALUED, C AND BETWEEN 0.0 (INCLUSIVELY) C AND N (INCLUSIVELY). C --P SHOULD BE BETWEEN 0.0 (EXCLUSIVELY) C AND 1.0 (EXCLUSIVELY). C --N SHOULD BE A POSITIVE INTEGER. C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--DSQRT, DATAN. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C COMMENT--NOTE THAT EVEN THOUGH THE INPUT C TO THIS CUMULATIVE C DISTRIBUTION FUNCTION SUBROUTINE C FOR THIS DISCRETE DISTRIBUTION C SHOULD (UNDER NORMAL CIRCUMSTANCES) BE A C DISCRETE INTEGER VALUE, C THE INPUT VARIABLE X IS SINGLE C PRECISION IN MODE. C X HAS BEEN SPECIFIED AS SINGLE C PRECISION SO AS TO CONFORM WITH THE DATAPAC C CONVENTION THAT ALL INPUT ****DATA**** C (AS OPPOSED TO SAMPLE SIZE, FOR EXAMPLE) C VARIABLES TO ALL C DATAPAC SUBROUTINES ARE SINGLE PRECISION. C THIS CONVENTION IS BASED ON THE BELIEF THAT C 1) A MIXTURE OF MODES (FLOATING POINT C VERSUS INTEGER) IS INCONSISTENT AND C AN UNNECESSARY COMPLICATION C IN A DATA ANALYSIS; AND C 2) FLOATING POINT MACHINE ARITHMETIC C (AS OPPOSED TO INTEGER ARITHMETIC) C IS THE MORE NATURAL MODE FOR DOING C DATA ANALYSIS. C REFERENCES--HASTINGS AND PEACOCK, STATISTICAL C DISTRIBUTIONS--A HANDBOOK FOR C STUDENTS AND PRACTITIONERS, 1975, C PAGE 38. C --NATIONAL BUREAU OF STANDARDS APPLIED MATHEMATICS C SERIES 55, 1964, PAGE 945, FORMULAE 26.5.24 AND C 26.5.28, AND PAGE 929. C --JOHNSON AND KOTZ, DISCRETE C DISTRIBUTIONS, 1969, PAGES 50-86, C ESPECIALLY PAGES 63-64. C --FELLER, AN INTRODUCTION TO PROBABILITY C THEORY AND ITS APPLICATIONS, VOLUME 1, C EDITION 2, 1957, PAGES 135-142. C --KENDALL AND STUART, THE ADVANCED THEORY OF C STATISTICS, VOLUME 1, EDITION 2, 1963, PAGES 120-125. C --MOOD AND GRABLE, INTRODUCTION TO THE THEORY C OF STATISTICS, EDITION 2, 1963, PAGES 64-69. C --OWEN, HANDBOOK OF STATISTICAL C TABLES, 1962, PAGES 264-272. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-921-3651 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--82/7 C ORIGINAL VERSION--NOVEMBER 1975. C UPDATED --MAY 1977. C UPDATED --DECEMBER 1981. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DX,PI,ANU1,ANU2,Z,SUM,TERM,AI,COEF1,COEF2,ARG DOUBLE PRECISION COEF DOUBLE PRECISION THETA,SINTH,COSTH,A,B DOUBLE PRECISION DSQRT,DATAN C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----DATA STATEMENTS------------------------------------------------- C DATA PI/3.14159265358979D0/ C C-----START POINT----------------------------------------------------- C B=0.0 C C CHECK THE INPUT ARGUMENTS FOR ERRORS C AN=N IF(P.LT.0.0.OR.P.GT.1.0)GOTO50 IF(N.LT.1)GOTO55 IF(X.LT.0.0.OR.X.GT.AN)GOTO60 INTX=X+0.0001 FINTX=INTX DEL=X-FINTX IF(DEL.LT.0.0)DEL=-DEL IF(DEL.GT.0.001)GOTO65 GOTO90 50 WRITE(ICOUT,11) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)P CALL DPWRST('XXX','BUG ') CDF=0.0 RETURN 55 WRITE(ICOUT,25) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)N CALL DPWRST('XXX','BUG ') CDF=0.0 RETURN 60 WRITE(ICOUT,4)N CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') IF(X.LT.0.0)CDF=0.0 IF(X.GT.AN)CDF=1.0 RETURN 65 WRITE(ICOUT,5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') 90 CONTINUE 4 FORMAT('***** NON-FATAL DIAGNOSTIC--THE 1ST INPUT ', 1'ARGUMENT TO THE BINCDF SUBROUTINE IS OUTSIDE THE USUAL ', 1'(0,N) = (0,',I8,') INTERVAL') 5 FORMAT('***** NON-FATAL DIAGNOSTIC--THE 1ST INPUT ', 1'ARGUMENT TO THE BINCDF SUBROUTINE IS NON-INTEGRAL *****') 11 FORMAT('***** FATAL ERROR--THE 2ND INPUT ARGUMENT TO THE ', 1' BINCDF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL') 25 FORMAT('***** FATAL ERROR--THE 3RD INPUT ARGUMENT TO THE ', 1' BINCDF SUBROUTINE IS NON-POSITIVE *****') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****') C C TREAT IMMEDIATELY THE SPECIAL CASE OF X = N, C IN WHICH CASE CDF = 1.0. C ALSO TREAT IMMEDIATELY THE SPECIAL CASE OF P = 0.0 C IN WHICH CASE CDF = 1.0 FOR ALL X. C THIRDLY, TREAT THE SPECIAL CASE IN WHICH P = 1.0 C IN WHICH CASE CDF = 0.0 FOR ALL X SMALLER THAN N C AND CDF = 1.0 FOR ALL X EQUAL TO OR LARGER C THAN N. C INTX=X+0.0001 CDF=1.0 IF(INTX.EQ.N)RETURN IF(P.EQ.0.0)RETURN IF(P.EQ.1.0.AND.INTX.GE.N)RETURN IF(P.EQ.1.0.AND.INTX.LT.N)CDF=0.0 IF(P.EQ.1.0.AND.INTX.LT.N)RETURN C C EXPRESS THE BINOMIAL CUMULATIVE DISTRIBUTION C FUNCTION IN TERMS OF THE EQUIVALENT F C CUMULATIVE DISTRIBUTION FUNCTION, C AND THEN EVALUATE THE LATTER. C AN=N DX=(P/(1.0-P))*((AN-X)/(X+1.0)) NU1=2.0*(X+1.0)+0.1 NU2=2.0*(AN-X)+0.1 ANU1=NU1 ANU2=NU2 Z=ANU2/(ANU2+ANU1*DX) C C DETERMINE IF NU1 AND NU2 ARE EVEN OR ODD C IFLAG1=NU1-2*(NU1/2) IFLAG2=NU2-2*(NU2/2) IF(IFLAG1.EQ.0)GOTO120 IF(IFLAG2.EQ.0)GOTO150 GOTO250 C C DO THE NU1 EVEN AND NU2 EVEN OR ODD CASE C 120 SUM=0.0D0 TERM=1.0D0 IMAX=(NU1-2)/2 IF(IMAX.LE.0)GOTO110 DO100I=1,IMAX AI=I COEF1=2.0D0*(AI-1.0D0) COEF2=2.0D0*AI TERM=TERM*((ANU2+COEF1)/COEF2)*(1.0D0-Z) SUM=SUM+TERM 100 CONTINUE C 110 SUM=SUM+1.0D0 SUM=(Z**(ANU2/2.0D0))*SUM CDF=SUM RETURN C C DO THE NU1 ODD AND NU2 EVEN CASE C 150 SUM=0.0D0 TERM=1.0D0 IMAX=(NU2-2)/2 IF(IMAX.LE.0)GOTO210 DO200I=1,IMAX AI=I COEF1=2.0D0*(AI-1.0D0) COEF2=2.0D0*AI TERM=TERM*((ANU1+COEF1)/COEF2)*Z SUM=SUM+TERM 200 CONTINUE C 210 SUM=SUM+1.0D0 CDF=1.0D0-((1.0D0-Z)**(ANU1/2.0D0))*SUM RETURN C C DO THE NU1 ODD AND NU2 ODD CASE C 250 SUM=0.0D0 TERM=1.0D0 ARG=DSQRT((ANU1/ANU2)*DX) THETA=DATAN(ARG) SINTH=ARG/DSQRT(1.0D0+ARG*ARG) COSTH=1.0D0/DSQRT(1.0D0+ARG*ARG) IF(NU2.EQ.1)GOTO320 IF(NU2.EQ.3)GOTO310 IMAX=NU2-2 DO300I=3,IMAX,2 AI=I COEF1=AI-1.0D0 COEF2=AI TERM=TERM*(COEF1/COEF2)*(COSTH*COSTH) SUM=SUM+TERM 300 CONTINUE C 310 SUM=SUM+1.0D0 SUM=SUM*SINTH*COSTH C 320 A=(2.0D0/PI)*(THETA+SUM) SUM=0.0D0 TERM=1.0D0 IF(NU1.EQ.1)B=0.0D0 IF(NU1.EQ.1)GOTO450 IF(NU1.EQ.3)GOTO410 IMAX=NU1-3 DO400I=1,IMAX,2 AI=I COEF1=AI COEF2=AI+2.0D0 TERM=TERM*((ANU2+COEF1)/COEF2)*(SINTH*SINTH) SUM=SUM+TERM 400 CONTINUE C 410 SUM=SUM+1.0D0 SUM=SUM*SINTH*(COSTH**N) COEF=1.0D0 IEVODD=NU2-2*(NU2/2) IMIN=3 IF(IEVODD.EQ.0)IMIN=2 IF(IMIN.GT.NU2)GOTO420 DO430I=IMIN,NU2,2 AI=I COEF=((AI-1.0D0)/AI)*COEF 430 CONTINUE C 420 COEF=COEF*ANU2 IF(IEVODD.EQ.0)GOTO440 COEF=COEF*(2.0D0/PI) C 440 B=COEF*SUM C 450 CDF=1.0D0-(A-B) RETURN C END REAL FUNCTION BINFUN(P) C C PURPOSE--DPMLBI CALLS FZERO TO FIND A ROOT FOR ONE OF C THE FOLLOWING FUNCTIONS: C C BINCDF(X;P,N) - (1 - ALPHA/2) = 0 C BINCDF(X;P,N) - (ALPHA/2) = 0 C C WITH X, P, N, AND ALPHA DENOTING THE NUMBER OF C SUCCESSES, THE PROBABILITY OF SUCCESS PARAMETER, C THE NUMBER OF TRIALS, AND DESIRED SIGNIFICANCE C LEVEL RESPECTIVELY. DPMLBI IS TRYING TO DETERMINE C AN EXACT CONFIDENCE INTERVAL FOR P. THE VALUES C FOR X, N, AND (1 - ALPHA/2) (OR ALPHA/2) ARE PASSED C IN VIA A COMMON BLOCK. C C INPUT ARGUMENTS--P = THE SINGLE PRECISION VALUE AT C WHICH THE CUMULATIVE DISTRIBUTION C FUNCTION IS TO BE EVALUATED. C OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY C FUNCTION VALUE BINFUN. C PRINTING--NONE. C RESTRICTIONS--NONE. C OTHER DATAPAC SUBROUTINES NEEDED--BINCDF. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--KARL BURY (1999). "STATISTICAL DISTRIBUTIONS IN C ENGINEERING", CAMBRIDGE UNIVERSITY PRESS, P. 74. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATION INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2005.8 C ORIGINAL VERSION--AUGUST 2005. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C COMMON/BINCOM/N,X,CONST C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C CALL BINCDF(X,P,N,CDF) BINFUN=CDF - CONST C 9999 CONTINUE RETURN END FUNCTION BINOM(N,M) C***BEGIN PROLOGUE BINOM C***DATE WRITTEN 770701 (YYMMDD) C***REVISION DATE 820801 (YYMMDD) C***CATEGORY NO. C1 C***KEYWORDS BINOMIAL COEFFICIENTS,SPECIAL FUNCTION C***AUTHOR FULLERTON, W., (LANL) C***PURPOSE Computes the binomial coefficients. C***DESCRIPTION C C BINOM(N,M) calculates the binomial coefficient (N!)/((M!)*(N-M)!). C***REFERENCES (NONE) C***ROUTINES CALLED ALNREL,R1MACH,R9LGMC,XERROR C***END PROLOGUE BINOM DOUBLE PRECISION D9LGMC INCLUDE 'DPCOMC.INC' C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C DATA SQ2PIL / 0.9189385332 0467274E0 / DATA BILNMX, FINTMX / 0.0, 0.0 / C***FIRST EXECUTABLE STATEMENT BINOM IF (BILNMX.NE.0.0) GO TO 10 BILNMX = LOG (R1MACH(2)) FINTMX = 0.9/R1MACH(3) C 10 CONTINUE IF(N.LT.0)THEN WRITE(ICOUT,1) 1 FORMAT('***** ERROR: FIRST ARGUMENT TO BINOM IS NEGATIVE.') CALL DPWRST('XXX','BUG') GOTO9000 ENDIF IF(M.LT.0)THEN WRITE(ICOUT,2) 2 FORMAT('***** ERROR: SECOND ARGUMENT TO BINOM IS NEGATIVE.') CALL DPWRST('XXX','BUG') GOTO9000 ENDIF IF (N.LT.M) THEN WRITE(ICOUT,3) 3 FORMAT('***** ERROR: FIRST ARGUMENT TO BINOM IS LESS THAN ', 1 'SECOND ARGUMENT.') CALL DPWRST('XXX','BUG') GOTO9000 ENDIF C K = MIN0 (M, N-M) IF (K.GT.20) GO TO 30 IF (FLOAT(K)*LOG(AMAX0(N,1)).GT.BILNMX) GO TO 30 C BINOM = 1. IF (K.EQ.0) GOTO9000 C DO 20 I=1,K BINOM = BINOM * FLOAT(N-I+1)/FLOAT(I) 20 CONTINUE C IF (BINOM.LT.FINTMX) BINOM = AINT (BINOM+0.5) GOTO9000 C C IF K.LT.9, APPROX IS NOT VALID AND ANSWER IS CLOSE TO THE OVERFLOW LIM 30 CONTINUE IF (K.LT.9) THEN WRITE(ICOUT,31) 31 FORMAT('***** ERROR: BINOM OVERFLOWS BECAUSE ONE (OR BOTH) OF ', 1 'THE ARGUMENTS IS TOO LARGE.') CALL DPWRST('XXX','BUG') GOTO9000 ENDIF C XN = N + 1 XK = K + 1 XNK = N - K + 1 C CORR = SNGL(D9LGMC(DBLE(XN))) - SNGL(D9LGMC(DBLE(XK))) - 1 SNGL(D9LGMC(DBLE(XNK))) BINOM = XK*LOG(XNK/XK) - XN*ALNREL(-(XK-1.)/XN) 1 - 0.5*LOG(XN*XNK/XK) + 1.0 - SQ2PIL + CORR C IF (BINOM.GT.BILNMX) THEN C WRITE(ICOUT,41) 41 FORMAT('***** ERROR: BINOM OVERFLOWS BECAUSE ONE (OR BOTH) OF ', 1 'THE ARGUMENTS IS TOO LARGE.') CALL DPWRST('XXX','BUG') GOTO9000 ENDIF BINOM = EXP (BINOM) IF (BINOM.LT.FINTMX) BINOM = AINT (BINOM+0.5) C 9000 CONTINUE RETURN END SUBROUTINE BINPPF(P,PPAR,N,PPF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT C FUNCTION VALUE AT THE SINGLE PRECISION VALUE P C FOR THE BINOMIAL DISTRIBUTION C WITH SINGLE PRECISION 'BERNOULLI PROBABILITY' C PARAMETER = PPAR, C AND INTEGER 'NUMBER OF BERNOULLI TRIALS' C PARAMETER = N. C THE BINOMIAL DISTRIBUTION USED C HEREIN HAS MEAN = N*PPAR C AND STANDARD DEVIATION = SQRT(N*PPAR*(1-PPAR)). C THIS DISTRIBUTION IS DEFINED FOR ALL C DISCRETE INTEGER X BETWEEN 0 (INCLUSIVELY) C AND N (INCLUSIVELY). C THIS DISTRIBUTION HAS THE PROBABILITY FUNCTION C F(X) = C(N,X) * PPAR**X * (1-PPAR)**(N-X). C WHERE C(N,X) IS THE COMBINATORIAL FUNCTION C EQUALING THE NUMBER OF COMBINATIONS OF N ITEMS C TAKEN X AT A TIME. C THE BINOMIAL DISTRIBUTION IS THE C DISTRIBUTION OF THE NUMBER OF C SUCCESSES IN N BERNOULLI (0,1) C TRIALS WHERE THE PROBABILITY OF SUCCESS C IN A SINGLE TRIAL = PPAR. C NOTE THAT THE PERCENT POINT FUNCTION OF A DISTRIBUTION C IS IDENTICALLY THE SAME AS THE INVERSE CUMULATIVE C DISTRIBUTION FUNCTION OF THE DISTRIBUTION. C INPUT ARGUMENTS--P = THE SINGLE PRECISION VALUE C (BETWEEN 0.0 (INCLUSIVELY) C AND 1.0 (INCLUSIVELY)) C AT WHICH THE PERCENT POINT C FUNCTION IS TO BE EVALUATED. C --PPAR = THE SINGLE PRECISION VALUE C OF THE 'BERNOULLI PROBABILITY' C PARAMETER FOR THE BINOMIAL C DISTRIBUTION. C PPAR SHOULD BE BETWEEN C 0.0 (EXCLUSIVELY) AND C 1.0 (EXCLUSIVELY). C --N = THE INTEGER VALUE C OF THE 'NUMBER OF BERNOULLI TRIALS' C PARAMETER. C N SHOULD BE A POSITIVE INTEGER. C OUTPUT ARGUMENTS--PPF = THE SINGLE PRECISION PERCENT C POINT FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION PERCENT POINT . C FUNCTION VALUE PPF C FOR THE BINOMIAL DISTRIBUTION C WITH 'BERNOULLI PROBABILITY' PARAMETER = PPAR C AND 'NUMBER OF BERNOULLI TRIALS' PARAMETER = N. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--PPAR SHOULD BE BETWEEN 0.0 (EXCLUSIVELY) C AND 1.0 (EXCLUSIVELY). C --N SHOULD BE A POSITIVE INTEGER. C --P SHOULD BE BETWEEN 0.0 (INCLUSIVELY) C AND 1.0 (INCLUSIVELY). C OTHER DATAPAC SUBROUTINES NEEDED--NORPPF, BINCDF. C FORTRAN LIBRARY SUBROUTINES NEEDED--SQRT. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION AND DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C COMMENT--NOTE THAT EVEN THOUGH THE OUTPUT C FROM THIS DISCRETE DISTRIBUTION C PERCENT POINT FUNCTION C SUBROUTINE MUST NECESSARILY BE A C DISCRETE INTEGER VALUE, C THE OUTPUT VARIABLE PPF IS SINGLE C PRECISION IN MODE. C PPF HAS BEEN SPECIFIED AS SINGLE C PRECISION SO AS TO CONFORM WITH THE DATAPAC C CONVENTION THAT ALL OUTPUT VARIABLES FROM ALL C DATAPAC SUBROUTINES ARE SINGLE PRECISION. C THIS CONVENTION IS BASED ON THE BELIEF THAT C 1) A MIXTURE OF MODES (FLOATING POINT C VERSUS INTEGER) IS INCONSISTENT AND C AN UNNECESSARY COMPLICATION C IN A DATA ANALYSIS; AND C 2) FLOATING POINT MACHINE ARITHMETIC C (AS OPPOSED TO INTEGER ARITHMETIC) C IS THE MORE NATURAL MODE FOR DOING C DATA ANALYSIS. C REFERENCES--JOHNSON AND KOTZ, DISCRETE C DISTRIBUTIONS, 1969, PAGES 50-86, C ESPECIALLY PAGE 64, FORMULA 36. C --HASTINGS AND PEACOCK, STATISTICAL C DISTRIBUTIONS--A HANDBOOK FOR C STUDENTS AND PRACTITIONERS, 1975, C PAGES 36-41. C --NATIONAL BUREAU OF STANDARDS APPLIED MATHEMATICS C SERIES 55, 1964, PAGE 929. C --FELLER, AN INTRODUCTION TO PROBABILITY C THEORY AND ITS APPLICATIONS, VOLUME 1, C EDITION 2, 1957, PAGES 135-142. C --KENDALL AND STUART, THE ADVANCED THEORY OF C STATISTICS, VOLUME 1, EDITION 2, 1963, PAGES 120-125. C --MOOD AND GRABLE, INTRODUCTION TO THE THEORY C OF STATISTICS, EDITION 2, 1963, PAGES 64-69. C --OWEN, HANDBOOK OF STATISTICAL C TABLES, 1962, PAGES 264-272. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-921-3651 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--82/7 C ORIGINAL VERSION--NOVEMBER 1975. C UPDATED --OCTOBER 1978. C UPDATED --DECEMBER 1981. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DPPAR C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(P.LT.0.0.OR.P.GT.1.0)GOTO50 IF(PPAR.LE.0.0.OR.PPAR.GE.1.0)GOTO55 IF(N.LT.1)GOTO60 GOTO90 50 WRITE(ICOUT,1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)P CALL DPWRST('XXX','BUG ') PPF=0.0 RETURN 55 WRITE(ICOUT,11) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)PPAR CALL DPWRST('XXX','BUG ') PPF=0.0 RETURN 60 WRITE(ICOUT,25) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)N CALL DPWRST('XXX','BUG ') PPF=0.0 RETURN 90 CONTINUE 1 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ', 1' BINPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL') 11 FORMAT('***** FATAL ERROR--THE 2ND INPUT ARGUMENT TO THE ', 1' BINPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL') 25 FORMAT('***** FATAL ERROR--THE 3RD INPUT ARGUMENT TO THE ', 1' BINPPF SUBROUTINE IS NON-POSITIVE *****') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****') C AN=N DPPAR=PPAR PPF=0.0 IX0=0 IX1=0 IX2=0 P0=0.0 P1=0.0 P2=0.0 C C TREAT CERTAIN SPECIAL CASES IMMEDIATELY-- C 1) P = 0.0 OR 1.0 C 2) P = 0.5 AND PPAR = 0.5 C 3) PPF = 0 OR N C IF(P.EQ.0.0)GOTO110 IF(P.EQ.1.0)GOTO120 IF(P.EQ.0.5.AND.PPAR.EQ.0.5)GOTO130 PF0=(1.0D0-DPPAR)**N QFN=1.0D0-(DPPAR**N) IF(P.LE.PF0)GOTO110 IF(P.GT.QFN)GOTO120 GOTO190 110 PPF=0.0 RETURN 120 PPF=N RETURN 130 PPF=N/2 RETURN 190 CONTINUE C C DETERMINE AN INITIAL APPROXIMATION TO THE BINOMIAL C PERCENT POINT BY USE OF THE NORMAL APPROXIMATION C TO THE BINOMIAL. C (SEE JOHNSON AND KOTZ, DISCRETE DISTRIBUTIONS, C PAGE 64, FORMULA 36). C AMEAN=AN*PPAR SD=SQRT(AN*PPAR*(1.0-PPAR)) CALL NORPPF(P,ZPPF) X2=AMEAN-0.5+ZPPF*SD IX2=X2 C C CHECK AND MODIFY (IF NECESSARY) THIS INITIAL C ESTIMATE OF THE PERCENT POINT C TO ASSURE THAT IT BE IN THE CLOSED INTERVAL 0 TO N. C IF(IX2.LT.0)IX2=0 IF(IX2.GT.N)IX2=N C C DETERMINE UPPER AND LOWER BOUNDS ON THE DESIRED C PERCENT POINT BY ITERATING OUT (BOTH BELOW AND ABOVE) C FROM THE ORIGINAL APPROXIMATION AT STEPS C OF 1 STANDARD DEVIATION. C THE RESULTING BOUNDS WILL BE AT MOST C 1 STANDARD DEVIATION APART. C IX0=0 IX1=N ISD=SD+1.0 X2=IX2 CALL BINCDF(X2,PPAR,N,P2) C IF(P2.LT.P)GOTO210 GOTO250 C 210 CONTINUE IX0=IX2 I=1 215 CONTINUE IX2=IX0+ISD IF(IX2.GE.IX1)GOTO275 X2=IX2 CALL BINCDF(X2,PPAR,N,P2) IF(P2.GE.P)GOTO230 IX0=IX2 220 CONTINUE I=I+1 IF(I.LE.1000000)GOTO215 WRITE(ICOUT,249) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,222) CALL DPWRST('XXX','BUG ') GOTO950 230 IX1=IX2 GOTO275 C 250 CONTINUE IX1=IX2 I=1 255 CONTINUE IX2=IX1-ISD IF(IX2.LE.IX0)GOTO275 X2=IX2 CALL BINCDF(X2,PPAR,N,P2) IF(P2.LT.P)GOTO270 IX1=IX2 260 CONTINUE I=I+1 IF(I.LE.1000000)GOTO255 WRITE(ICOUT,249) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,262) CALL DPWRST('XXX','BUG ') GOTO950 270 IX0=IX2 C 275 IF(IX0.EQ.IX1)GOTO280 GOTO295 280 IF(IX0.EQ.0)GOTO285 IF(IX0.EQ.N)GOTO290 WRITE(ICOUT,249) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,282) CALL DPWRST('XXX','BUG ') GOTO950 285 IX1=IX1+1 GOTO295 290 IX0=IX0-1 295 CONTINUE C C COMPUTE BINOMIAL PROBABILITIES FOR THE C DERIVED LOWER AND UPPER BOUNDS. C X0=IX0 X1=IX1 CALL BINCDF(X0,PPAR,N,P0) CALL BINCDF(X1,PPAR,N,P1) C C CHECK THE PROBABILITIES FOR PROPER ORDERING C IF(P0.LT.P.AND.P.LE.P1)GOTO490 IF(P0.EQ.P)GOTO410 IF(P1.EQ.P)GOTO420 IF(P0.GT.P1)GOTO430 IF(P0.GT.P)GOTO440 IF(P1.LT.P)GOTO450 WRITE(ICOUT,249) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,401) CALL DPWRST('XXX','BUG ') GOTO950 410 PPF=IX0 RETURN 420 PPF=IX1 RETURN 430 WRITE(ICOUT,249) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,431) CALL DPWRST('XXX','BUG ') GOTO950 440 WRITE(ICOUT,249) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,441) CALL DPWRST('XXX','BUG ') GOTO950 450 WRITE(ICOUT,249) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,451) CALL DPWRST('XXX','BUG ') GOTO950 490 CONTINUE C C THE STOPPING CRITERION IS THAT THE LOWER BOUND C AND UPPER BOUND ARE EXACTLY 1 UNIT APART. C CHECK TO SEE IF IX1 = IX0 + 1; C IF SO, THE ITERATIONS ARE COMPLETE; C IF NOT, THEN BISECT, COMPUTE PROBABILIIES, C CHECK PROBABILITIES, AND CONTINUE ITERATING C UNTIL IX1 = IX0 + 1. C 300 IX0P1=IX0+1 IF(IX1.EQ.IX0P1)GOTO690 IX2=(IX0+IX1)/2 IF(IX2.EQ.IX0)GOTO610 IF(IX2.EQ.IX1)GOTO620 X2=IX2 CALL BINCDF(X2,PPAR,N,P2) IF(P0.LT.P2.AND.P2.LT.P1)GOTO630 IF(P2.LE.P0)GOTO640 IF(P2.GE.P1)GOTO650 610 WRITE(ICOUT,249) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,611) CALL DPWRST('XXX','BUG ') GOTO950 620 WRITE(ICOUT,249) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,611) CALL DPWRST('XXX','BUG ') GOTO950 630 IF(P2.LE.P)GOTO635 IX1=IX2 P1=P2 GOTO300 635 IX0=IX2 P0=P2 GOTO300 640 WRITE(ICOUT,249) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,641) CALL DPWRST('XXX','BUG ') GOTO950 650 WRITE(ICOUT,249) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,651) CALL DPWRST('XXX','BUG ') GOTO950 690 PPF=IX1 IF(P0.EQ.P)PPF=IX0 RETURN C 950 WRITE(ICOUT,240)IX0,P0 CALL DPWRST('XXX','BUG ') WRITE(ICOUT,241)IX1,P1 CALL DPWRST('XXX','BUG ') WRITE(ICOUT,242)IX2,P2 CALL DPWRST('XXX','BUG ') WRITE(ICOUT,244)P CALL DPWRST('XXX','BUG ') WRITE(ICOUT,245)PPAR,N CALL DPWRST('XXX','BUG ') RETURN C 222 FORMAT(43HNO UPPER BOUND FOUND AFTER 10**7 ITERATIONS) 240 FORMAT(7HIX0 = ,I8,10X,5HP0 = ,F14.7) 241 FORMAT(7HIX1 = ,I8,10X,5HP1 = ,F14.7) 242 FORMAT(7HIX2 = ,I8,10X,5HP2 = ,F14.7) 244 FORMAT(7HP = ,F14.7) 245 FORMAT(7HPPAR = ,F14.7,10X,5HN = ,I8) 249 FORMAT('***** INTERNAL ERROR IN BINPPF SUBROUTINE *****') 262 FORMAT(43HNO LOWER BOUND FOUND AFTER 10**7 ITERATIONS) 282 FORMAT(31HLOWER AND UPPER BOUND IDENTICAL) 401 FORMAT(39HIMPOSSIBLE BRANCH CONDITION ENCOUNTERED) 431 FORMAT(42HLOWER BOUND PROBABILITY (P0) GREATER THAN , 1 28HUPPER BOUND PROBABILITY (P1)) 441 FORMAT(42HLOWER BOUND PROBABILITY (P0) GREATER THAN , 1 21HINPUT PROBABILITY (P)) 451 FORMAT(42HUPPER BOUND PROBABILITY (P1) LESS THAN , 1 21HINPUT PROBABILITY (P)) 611 FORMAT(39HBISECTION VALUE (X2) = LOWER BOUND (X0)) 621 FORMAT(39HBISECTION VALUE (X2) = UPPER BOUND (X1)) 641 FORMAT(33HBISECTION VALUE PROBABILITY (P2) , 1 38HLESS THAN LOWER BOUND PROBABILITY (P0)) 651 FORMAT(33HBISECTION VALUE PROBABILITY (P2) , 1 41HGREATER THAN UPPER BOUND PROBABILITY (P1)) C END SUBROUTINE BINRAN(N,P,NPAR,ISEED,X) C C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N C FROM THE BINOMIAL DISTRIBUTION C WITH SINGLE PRECISION 'BERNOULLI PROBABILITY' C PARAMETER = P, C AND INTEGER 'NUMBER OF BERNOULLI TRIALS' C PARAMETER = NPAR. C THE BINOMIAL DISTRIBUTION USED C HEREIN HAS MEAN = NPAR*P C AND STANDARD DEVIATION = SQRT(NPAR*P*(1-P)). C THIS DISTRIBUTION IS DEFINED FOR ALL C DISCRETE INTEGER X BETWEEN 0 (INCLUSIVELY) C AND NPAR (INCLUSIVELY). C THIS DISTRIBUTION HAS THE PROBABILITY FUNCTION C F(X) = C(NPAR,X) * P**X * (1-P)**(NPAR-X). C WHERE C(NPAR,X) IS THE COMBINATORIAL FUNCTION C EQUALING THE NUMBER OF COMBINATIONS OF NPAR ITEMS C TAKEN X AT A TIME. C THE BINOMIAL DISTRIBUTION IS THE C DISTRIBUTION OF THE NUMBER OF C SUCCESSES IN NPAR BERNOULLI (0,1) C TRIALS WHERE THE PROBABILITY OF SUCCESS C IN A SINGLE TRIAL = P. C INPUT ARGUMENTS--N = THE DESIRED INTEGER NUMBER C OF RANDOM NUMBERS TO BE C GENERATED. C --P = THE SINGLE PRECISION VALUE C OF THE 'BERNOULLI PROBABILITY' C PARAMETER FOR THE BINOMIAL C DISTRIBUTION. C P SHOULD BE BETWEEN C 0.0 (EXCLUSIVELY) AND C 1.0 (EXCLUSIVELY). C --NPAR = THE INTEGER VALUE C OF THE 'NUMBER OF BERNOULLI TRIALS' C PARAMETER. C NPAR SHOULD BE A POSITIVE INTEGER. C OUTPUT ARGUMENTS--X = A SINGLE PRECISION VECTOR C (OF DIMENSION AT LEAST N) C INTO WHICH THE GENERATED C RANDOM SAMPLE WILL BE PLACED. C OUTPUT--A RANDOM SAMPLE OF SIZE N C FROM THE BINOMIAL DISTRIBUTION C WITH 'BERNOULLI PROBABILITY' PARAMETER = P C AND 'NUMBER OF BERNOULLI TRIALS' PARAMETER = NPAR. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C --P SHOULD BE BETWEEN 0.0 (EXCLUSIVELY) C AND 1.0 (EXCLUSIVELY). C --NPAR SHOULD BE A POSITIVE INTEGER. C OTHER DATAPAC SUBROUTINES NEEDED--UNIRAN, GEORAN. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C COMMENT--NOTE THAT EVEN THOUGH THE OUTPUT C FROM THIS DISCRETE RANDOM NUMBER C GENERATOR MUST NECESSARILY BE A C SEQUENCE OF ***INTEGER*** VALUES, C THE OUTPUT VECTOR X IS SINGLE C PRECISION IN MODE. C X HAS BEEN SPECIFIED AS SINGLE C PRECISION SO AS TO CONFORM WITH THE DATAPAC C CONVENTION THAT ALL OUTPUT VECTORS FROM ALL C DATAPAC SUBROUTINES ARE SINGLE PRECISION. C THIS CONVENTION IS BASED ON THE BELIEF THAT C 1) A MIXTURE OF MODES (FLOATING POINT C VERSUS INTEGER) IS INCONSISTENT AND C AN UNNECESSARY COMPLICATION C IN A DATA ANALYSIS; AND C 2) FLOATING POINT MACHINE ARITHMETIC C (AS OPPOSED TO INTEGER ARITHMETIC) C IS THE MORE NATURAL MODE FOR DOING C DATA ANALYSIS. C REFERENCES--JOHNSON AND KOTZ, DISCRETE C DISTRIBUTIONS, 1969, PAGES 50-86. C --HASTINGS AND PEACOCK, STATISTICAL C DISTRIBUTIONS--A HANDBOOK FOR C STUDENTS AND PRACTITIONERS, 1975, C PAGE 41. C --FELLER, AN INTRODUCTION TO PROBABILITY C THEORY AND ITS APPLICATIONS, VOLUME 1, C EDITION 2, 1957, PAGES 135-142. C --NATIONAL BUREAU OF STANDARDS APPLIED MATHEMATICS C SERIES 55, 1964, PAGE 929. C --KENDALL AND STUART, THE ADVANCED THEORY OF C STATISTICS, VOLUME 1, EDITION 2, 1963, PAGES 120-125. C --MOOD AND GRABLE, INTRODUCTION TO THE THEORY C OF STATISTICS, EDITION 2, 1963, PAGES 64-69. C --TOCHER, THE ART OF SIMULATION, C 1963, PAGES 39-40. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-921-3651 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--82/7 C ORIGINAL VERSION--NOVEMBER 1975. C UPDATED --DECEMBER 1981. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DIMENSION X(*) C DIMENSION U(2) DIMENSION G(2) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(N.LT.1)GOTO50 IF(P.LE.0.0.OR.P.GE.1.0)GOTO55 IF(NPAR.LT.1)GOTO60 GOTO90 50 WRITE(ICOUT, 5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)N CALL DPWRST('XXX','BUG ') RETURN 55 WRITE(ICOUT,11) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)P CALL DPWRST('XXX','BUG ') RETURN 60 WRITE(ICOUT,25) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)NPAR CALL DPWRST('XXX','BUG ') RETURN 90 CONTINUE 5 FORMAT('***** FATAL ERROR--THE FIRST INPUT ARGUMENT TO THE ', 1' BINRAN SUBROUTINE IS NON-POSITIVE *****') 11 FORMAT('***** FATAL ERROR--THE 2ND INPUT ARGUMENT TO THE ', 1' BINRAN SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL') 25 FORMAT('***** FATAL ERROR--THE 3RD INPUT ARGUMENT TO THE ', 1' BINRAN SUBROUTINE IS NON-POSITIVE *****') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****') C C CHECK ON THE MAGNITUDE OF P, C AND BRANCH TO THE FASTER C GENERATION METHOD ACCORDINGLY. C IF(P.LT.0.1)GOTO450 C C IF P IS MODERATE OR LARGE, C GENERATE N BINOMIAL RANDOM NUMBERS C USING THE REJECTION METHOD. C DO100I=1,N ISUM=0 DO200J=1,NPAR CALL UNIRAN(1,ISEED,U) IF(U(1).LE.P)ISUM=ISUM+1 200 CONTINUE X(I)=ISUM 100 CONTINUE RETURN C C IF P IS SMALL, C GENERATE N BINOMIAL NUMBERS C USING THE FACT THAT THE C WAITING TIME FOR 1 SUCCESS IN C BERNOULLI TRIALS HAS A C GEOMETRIC DISTRIBUTION. C 450 DO500I=1,N ISUM=0 J=1 550 CALL GEORAN(1,P,ISEED,G) IG=G(1)+0.5 ISUM=ISUM+IG+1 IF(ISUM.GT.NPAR)GOTO650 J=J+1 GOTO550 650 X(I)=J-1 500 CONTINUE RETURN C END SUBROUTINE BINTK(X,Y,T,N,K,BCOEF,Q,WORK) C***BEGIN PROLOGUE BINTK C***DATE WRITTEN 800901 (YYMMDD) C***REVISION DATE 820801 (YYMMDD) C***CATEGORY NO. E1A C***KEYWORDS B-SPLINE,DATA FITTING,INTERPOLATION,SPLINE C***AUTHOR AMOS, D. E., (SNLA) C***PURPOSE Produces the B-spline coefficients, BCOEF, of the C B-spline of order K with knots T(I), I=1,...,N+K, which C takes on the value Y(I) at X(I), I=1,...,N. C***DESCRIPTION C C Written by Carl de Boor and modified by D. E. Amos C C References C C A Practical Guide to Splines by C. de Boor, Applied C Mathematics Series 27, Springer, 1979. C C Abstract C C BINTK is the SPLINT routine of the reference. C C BINTK produces the B-spline coefficients, BCOEF, of the C B-spline of order K with knots T(I), I=1,...,N+K, which C takes on the value Y(I) at X(I), I=1,...,N. The spline or C any of its derivatives can be evaluated by calls to BVALU. C The I-th equation of the linear system A*BCOEF = B for the C coefficients of the interpolant enforces interpolation at C X(I)), I=1,...,N. Hence, B(I) = Y(I), all I, and A is C a band matrix with 2K-1 bands if A is invertible. The matrix C A is generated row by row and stored, diagonal by diagonal, C in the rows of Q, with the main diagonal going into row K. C The banded system is then solved by a call to BNFAC (which C constructs the triangular factorization for A and stores it C again in Q), followed by a call to BNSLV (which then C obtains the solution BCOEF by substitution). BNFAC does no C pivoting, since the total positivity of the matrix A makes C this unnecessary. The linear system to be solved is C (theoretically) invertible if and only if C T(I) .LT. X(I)) .LT. T(I+K), all I. C Equality is permitted on the left for I=1 and on the right C for I=N when K knots are used at X(1) or X(N). Otherwise, C violation of this condition is certain to lead to an error. C C BINTK calls BSPVN, BNFAC, BNSLV, XERROR C C Description of Arguments C Input C X - vector of length N containing data point abscissa C in strictly increasing order. C Y - corresponding vector of length N containing data C point ordinates. C T - knot vector of length N+K C since T(1),..,T(K) .LE. X(1) and T(N+1),..,T(N+K) C .GE. X(N), this leaves only N-K knots (not nec- C essarily X(I)) values) interior to (X(1),X(N)) C N - number of data points, N .GE. K C K - order of the spline, K .GE. 1 C C Output C BCOEF - a vector of length N containing the B-spline C coefficients C Q - a work vector of length (2*K-1)*N, containing C the triangular factorization of the coefficient C matrix of the linear system being solved. The C coefficients for the interpolant of an C additional data set (X(I)),YY(I)), I=1,...,N C with the same abscissa can be obtained by loading C YY into BCOEF and then executing C call BNSLV(Q,2K-1,N,K-1,K-1,BCOEF) C WORK - work vector of length 2*K C C Error Conditions C Improper input is a fatal error C Singular system of equations is a fatal error C***REFERENCES D.E. AMOS, *COMPUTATION WITH SPLINES AND B-SPLINES*, C SAND78-1968,SANDIA LABORATORIES,MARCH,1979. C C. DE BOOR, *PACKAGE FOR CALCULATING WITH B-SPLINES*, C SIAM JOURNAL ON NUMERICAL ANALYSIS, VOLUME 14, NO. 3, C JUNE 1977, PP. 441-472. C C. DE BOOR, *A PRACTICAL GUIDE TO SPLINES*, APPLIED C MATHEMATICS SERIES 27, SPRINGER, 1979. C***ROUTINES CALLED BNFAC,BNSLV,BSPVN,XERROR C***END PROLOGUE BINTK C C INTEGER IFLAG, IWORK, K, N, I, ILP1MX, J, JJ, KM1, KPKM2, LEFT, 1 LENQ, NP1 REAL BCOEF(N), Y(N), Q(1), T(1), X(N), XI, WORK(1) C DIMENSION Q(2*K-1,N), T(N+K) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C***FIRST EXECUTABLE STATEMENT BINTK IF(K.LT.1) GO TO 100 IF(N.LT.K) GO TO 105 JJ = N - 1 IF(JJ.EQ.0) GO TO 6 DO 5 I=1,JJ IF(X(I).GE.X(I+1)) GO TO 110 5 CONTINUE 6 CONTINUE NP1 = N + 1 KM1 = K - 1 KPKM2 = 2*KM1 LEFT = K C ZERO OUT ALL ENTRIES OF Q LENQ = N*(K+KM1) DO 10 I=1,LENQ Q(I) = 0.0E0 10 CONTINUE C C *** LOOP OVER I TO CONSTRUCT THE N INTERPOLATION EQUATIONS DO 50 I=1,N XI = X(I) ILP1MX = MIN0(I+K,NP1) C *** FIND LEFT IN THE CLOSED INTERVAL (I,I+K-1) SUCH THAT C T(LEFT) .LE. X(I) .LT. T(LEFT+1) C MATRIX IS SINGULAR IF THIS IS NOT POSSIBLE LEFT = MAX0(LEFT,I) IF (XI.LT.T(LEFT)) GO TO 80 20 IF (XI.LT.T(LEFT+1)) GO TO 30 LEFT = LEFT + 1 IF (LEFT.LT.ILP1MX) GO TO 20 LEFT = LEFT - 1 IF (XI.GT.T(LEFT+1)) GO TO 80 C *** THE I-TH EQUATION ENFORCES INTERPOLATION AT XI, HENCE C A(I,J) = B(J,K,T)(XI), ALL J. ONLY THE K ENTRIES WITH J = C LEFT-K+1,...,LEFT ACTUALLY MIGHT BE NONZERO. THESE K NUMBERS C ARE RETURNED, IN BCOEF (USED FOR TEMP.STORAGE HERE), BY THE C FOLLOWING 30 CALL BSPVN(T, K, K, 1, XI, LEFT, BCOEF, WORK, IWORK) C WE THEREFORE WANT BCOEF(J) = B(LEFT-K+J)(XI) TO GO INTO C A(I,LEFT-K+J), I.E., INTO Q(I-(LEFT+J)+2*K,(LEFT+J)-K) SINCE C A(I+J,J) IS TO GO INTO Q(I+K,J), ALL I,J, IF WE CONSIDER Q C AS A TWO-DIM. ARRAY , WITH 2*K-1 ROWS (SEE COMMENTS IN C BNFAC). IN THE PRESENT PROGRAM, WE TREAT Q AS AN EQUIVALENT C ONE-DIMENSIONAL ARRAY (BECAUSE OF FORTRAN RESTRICTIONS ON C DIMENSION STATEMENTS) . WE THEREFORE WANT BCOEF(J) TO GO INTO C ENTRY C I -(LEFT+J) + 2*K + ((LEFT+J) - K-1)*(2*K-1) C = I-LEFT+1 + (LEFT -K)*(2*K-1) + (2*K-2)*J C OF Q . JJ = I - LEFT + 1 + (LEFT-K)*(K+KM1) DO 40 J=1,K JJ = JJ + KPKM2 Q(JJ) = BCOEF(J) 40 CONTINUE 50 CONTINUE C C ***OBTAIN FACTORIZATION OF A , STORED AGAIN IN Q. CALL BNFAC(Q, K+KM1, N, KM1, KM1, IFLAG) GO TO (60, 90), IFLAG C *** SOLVE A*BCOEF = Y BY BACKSUBSTITUTION 60 DO 70 I=1,N BCOEF(I) = Y(I) 70 CONTINUE CALL BNSLV(Q, K+KM1, N, KM1, KM1, BCOEF) RETURN C C 80 CONTINUE WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,81) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,82) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,83) CALL DPWRST('XXX','BUG ') 81 FORMAT('***** FROM BINTK, SOME ABSCISSA WAS NOT IN THE SUPPORT') 82 FORMAT(' OF THE CORRESPONDING BASIS FUNCTION AND THE') 83 FORMAT(' SYSTEM IS SINGULAR. *****') RETURN 90 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,91) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,92) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,93) CALL DPWRST('XXX','BUG ') 91 FORMAT('***** FROM BINTK, THE SYSTEM OF SOLVER DETECTS A') 92 FORMAT(' SINGULAR SYSTEM ALTHOUGH THE THEORETICAL') 93 FORMAT(' CONDITIONS FOR A SOLUTION WERE SATISFIED. *****') RETURN 100 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,101) CALL DPWRST('XXX','BUG ') 101 FORMAT('***** FROM BINTK, K DOES NOT SATISFY K.GE.1 *****') RETURN 105 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,106) CALL DPWRST('XXX','BUG ') 106 FORMAT('***** FROM BINTK, N DOES NOT SATISFY N.GE.K *****') RETURN 110 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,111) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,112) CALL DPWRST('XXX','BUG ') 111 FORMAT('***** FROM BINTK, X(I) DOES NOT SATISFY ') 112 FORMAT(' X(I).LT.X(I+1) FOR SOME I *****') RETURN END DOUBLE PRECISION FUNCTION BIRINT(XVALUE) C C DESCRIPTION: C This function calculates the integral of the Airy function Bi, defined C C BIRINT(x) = integral{0 to x} Bi(t) dt C C The program uses Chebyshev expansions, the coefficients of which C are given to 20 decimal places. C C C ERROR RETURNS: C C If the function is too large and positive the correct C value would overflow. An error message is printed and the C program returns the value XMAX. C C If the argument is too large and negative, it is impossible C to accurately compute the necessary SIN and COS functions, C for the asymptotic expansion. C An error message is printed, and the program returns the C value 0 (the value at -infinity). C C C MACHINE-DEPENDENT CONSTANTS: C C NTERM1 - INTEGER - The no. of terms to be used from the array C ABINT1. The recommended value is such that C ABS(ABINT1(NTERM1)) < EPS/100, C subject to 1 <= NTERM1 <= 36. C C NTERM2 - INTEGER - The no. of terms to be used from the array C ABINT2. The recommended value is such that C ABS(ABINT2(NTERM2)) < EPS/100, C subject to 1 <= NTERM2 <= 37. C C NTERM3 - INTEGER - The no. of terms to be used from the array C ABINT3. The recommended value is such that C ABS(ABINT3(NTERM3)) < EPS/100, C subject to 1 <= NTERM3 <= 37. C C NTERM4 - INTEGER - The no. of terms to be used from the array C ABINT4. The recommended value is such that C ABS(ABINT4(NTERM4)) < EPS/100, C subject to 1 <= NTERM4 <= 20. C C NTERM5 - INTEGER - The no. of terms to be used from the array C ABINT5. The recommended value is such that C ABS(ABINT5(NTERM5)) < EPS/100, C subject to 1 <= NTERM5 <= 20. C C XLOW1 - DOUBLE PRECISION - The value such that, if |x| < XLOW1, C BIRINT(x) = x * Bi(0) C to machine precision. The recommended value is C 2 * EPSNEG. C C XHIGH1 - DOUBLE PRECISION - The value such that, if x > XHIGH1, C the function value would overflow. C The recommended value is computed as C z = ln(XMAX) + 0.5ln(ln(XMAX)), C XHIGH1 = (3z/2)^(2/3) C C XNEG1 - DOUBLE PRECISION - The value such that, if x < XNEG1, C the trigonometric functions in the asymptotic C expansion cannot be calculated accurately. C The recommended value is C -(1/((EPS)**2/3)) C C XMAX - DOUBLE PRECISION - The value of the largest positive floating-pt C number. Used in giving a value to the function C if x > XHIGH1. C C For values of EPS, EPSNEG, and XMAX see the file MACHCON.TXT. C C C The machine-dependent constants are computed internally by C using the D1MACH subroutine. C C C INTRINSIC FUNCTIONS USED: C COS, EXP, LOG, SIN, SQRT C C C OTHER MISCFUN SUBROUTINES USED: C C CHEVAL , ERRPRN, D1MACH C C C AUTHOR: Dr. Allan J. MacLeod, C Dept. of Mathematics and Statistics, C Univ. of Paisley, C High St., C Paisley, C SCOTLAND. C PA1 2BE C C (e-mail: macl_ms0@paisley.ac.uk ) C C C LATEST REVISION: 23 January, 1996 C INTEGER NTERM1,NTERM2,NTERM3,NTERM4,NTERM5 DOUBLE PRECISION ABINT1(0:36),ABINT2(0:37),ABINT3(0:37), 1 ABINT4(0:20),ABINT5(0:20), 2 ARG,BIRZER,CHEVAL,EIGHT,FOUR,F1,F2,NINE,NINHUN, 3 ONE,ONEHUN,ONEPT5,PIBY4,RT2B3P,SIXTEN,SEVEN,T,TEMP, 4 THREE,THR644,X,XLOW1,XHIGH1,XMAX,XNEG1,XVALUE, 5 Z,ZERO CCCCC CHARACTER FNNAME*6,ERMSG1*31,ERMSG2*31 CCCCC DATA FNNAME/'BIRINT'/ CCCCC DATA ERMSG1/'ARGUMENT TOO LARGE AND POSITIVE'/ CCCCC DATA ERMSG2/'ARGUMENT TOO LARGE AND NEGATIVE'/ C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOMC.INC' CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C DATA ABINT1(0)/ 0.38683 35244 50385 43350 D 0/ DATA ABINT1(1)/ -0.88232 13550 88890 8821 D -1/ DATA ABINT1(2)/ 0.21463 93744 03554 29239 D 0/ DATA ABINT1(3)/ -0.42053 47375 89131 5126 D -1/ DATA ABINT1(4)/ 0.59324 22547 49608 6771 D -1/ DATA ABINT1(5)/ -0.84078 70811 24270 210 D -2/ DATA ABINT1(6)/ 0.87182 47727 78487 955 D -2/ DATA ABINT1(7)/ -0.12191 60019 96134 55 D -3/ DATA ABINT1(8)/ 0.44024 82178 60232 34 D -3/ DATA ABINT1(9)/ 0.27894 68666 63866 78 D -3/ DATA ABINT1(10)/-0.70528 04689 78553 7 D -4/ DATA ABINT1(11)/ 0.59010 80066 77010 0 D -4/ DATA ABINT1(12)/-0.13708 62587 98214 2 D -4/ DATA ABINT1(13)/ 0.50596 25737 49073 D -5/ DATA ABINT1(14)/-0.51598 83776 6735 D -6/ DATA ABINT1(15)/ 0.39751 13123 49 D -8/ DATA ABINT1(16)/ 0.95249 85978 055 D -7/ DATA ABINT1(17)/-0.36814 35887 321 D -7/ DATA ABINT1(18)/ 0.12483 91688 136 D -7/ DATA ABINT1(19)/-0.24909 76191 37 D -8/ DATA ABINT1(20)/ 0.31775 24555 1 D -9/ DATA ABINT1(21)/ 0.54343 65270 D -10/ DATA ABINT1(22)/-0.40245 66915 D -10/ DATA ABINT1(23)/ 0.13938 55527 D -10/ DATA ABINT1(24)/-0.30381 7509 D -11/ DATA ABINT1(25)/ 0.40809 511 D -12/ DATA ABINT1(26)/ 0.16341 16 D -13/ DATA ABINT1(27)/-0.26838 09 D -13/ DATA ABINT1(28)/ 0.89664 1 D -14/ DATA ABINT1(29)/-0.18308 9 D -14/ DATA ABINT1(30)/ 0.21333 D -15/ DATA ABINT1(31)/ 0.1108 D -16/ DATA ABINT1(32)/-0.1276 D -16/ DATA ABINT1(33)/ 0.363 D -17/ DATA ABINT1(34)/-0.62 D -18/ DATA ABINT1(35)/ 0.5 D -19/ DATA ABINT1(36)/ 0.1 D -19/ DATA ABINT2(0)/ 2.04122 07860 25161 35181 D 0/ DATA ABINT2(1)/ 0.21241 33918 62122 1230 D -1/ DATA ABINT2(2)/ 0.66617 59976 67062 76 D -3/ DATA ABINT2(3)/ 0.38420 47982 80825 4 D -4/ DATA ABINT2(4)/ 0.36231 03660 20439 D -5/ DATA ABINT2(5)/ 0.50351 99011 5074 D -6/ DATA ABINT2(6)/ 0.79616 48702 253 D -7/ DATA ABINT2(7)/ 0.71780 84423 36 D -8/ DATA ABINT2(8)/ -0.26777 01591 04 D -8/ DATA ABINT2(9)/ -0.16848 95146 99 D -8/ DATA ABINT2(10)/-0.36811 75725 5 D -9/ DATA ABINT2(11)/ 0.47571 28727 D -10/ DATA ABINT2(12)/ 0.52636 21945 D -10/ DATA ABINT2(13)/ 0.77897 3500 D -11/ DATA ABINT2(14)/-0.46054 6143 D -11/ DATA ABINT2(15)/-0.18343 3736 D -11/ DATA ABINT2(16)/ 0.32191 249 D -12/ DATA ABINT2(17)/ 0.29352 060 D -12/ DATA ABINT2(18)/-0.16579 35 D -13/ DATA ABINT2(19)/-0.44838 08 D -13/ DATA ABINT2(20)/ 0.27907 D -15/ DATA ABINT2(21)/ 0.71192 1 D -14/ DATA ABINT2(22)/-0.1042 D -16/ DATA ABINT2(23)/-0.11959 1 D -14/ DATA ABINT2(24)/ 0.4606 D -16/ DATA ABINT2(25)/ 0.20884 D -15/ DATA ABINT2(26)/-0.2416 D -16/ DATA ABINT2(27)/-0.3638 D -16/ DATA ABINT2(28)/ 0.863 D -17/ DATA ABINT2(29)/ 0.591 D -17/ DATA ABINT2(30)/-0.256 D -17/ DATA ABINT2(31)/-0.77 D -18/ DATA ABINT2(32)/ 0.66 D -18/ DATA ABINT2(33)/ 0.3 D -19/ DATA ABINT2(34)/-0.15 D -18/ DATA ABINT2(35)/ 0.2 D -19/ DATA ABINT2(36)/ 0.3 D -19/ DATA ABINT2(37)/-0.1 D -19/ DATA ABINT3(0)/ 0.31076 96159 86403 49251 D 0/ DATA ABINT3(1)/ -0.27528 84588 74525 42718 D 0/ DATA ABINT3(2)/ 0.17355 96570 61365 43928 D 0/ DATA ABINT3(3)/ -0.55440 17909 49284 3130 D -1/ DATA ABINT3(4)/ -0.22512 65478 29595 0941 D -1/ DATA ABINT3(5)/ 0.41073 47447 81252 1894 D -1/ DATA ABINT3(6)/ 0.98476 12754 64262 480 D -2/ DATA ABINT3(7)/ -0.15556 18141 66604 1932 D -1/ DATA ABINT3(8)/ -0.56087 18707 30279 234 D -2/ DATA ABINT3(9)/ 0.24601 77833 22230 475 D -2/ DATA ABINT3(10)/ 0.16574 03922 92336 978 D -2/ DATA ABINT3(11)/-0.32775 87501 43540 2 D -4/ DATA ABINT3(12)/-0.24434 68086 05149 25 D -3/ DATA ABINT3(13)/-0.50353 05196 15232 1 D -4/ DATA ABINT3(14)/ 0.16302 64722 24785 4 D -4/ DATA ABINT3(15)/ 0.85191 40577 80934 D -5/ DATA ABINT3(16)/ 0.29790 36300 4664 D -6/ DATA ABINT3(17)/-0.64389 70789 6401 D -6/ DATA ABINT3(18)/-0.15046 98814 5803 D -6/ DATA ABINT3(19)/ 0.15870 13535 823 D -7/ DATA ABINT3(20)/ 0.12767 66299 622 D -7/ DATA ABINT3(21)/ 0.14057 85341 99 D -8/ DATA ABINT3(22)/-0.46564 73974 1 D -9/ DATA ABINT3(23)/-0.15682 74879 1 D -9/ DATA ABINT3(24)/-0.40389 3560 D -11/ DATA ABINT3(25)/ 0.66670 8192 D -11/ DATA ABINT3(26)/ 0.12886 9380 D -11/ DATA ABINT3(27)/-0.69686 63 D -13/ DATA ABINT3(28)/-0.62543 19 D -13/ DATA ABINT3(29)/-0.71839 2 D -14/ DATA ABINT3(30)/ 0.11529 6 D -14/ DATA ABINT3(31)/ 0.42276 D -15/ DATA ABINT3(32)/ 0.2493 D -16/ DATA ABINT3(33)/-0.971 D -17/ DATA ABINT3(34)/-0.216 D -17/ DATA ABINT3(35)/-0.2 D -19/ DATA ABINT3(36)/ 0.6 D -19/ DATA ABINT3(37)/ 0.1 D -19/ DATA ABINT4(0)/ 1.99507 95931 33520 47614 D 0/ DATA ABINT4(1)/ -0.27373 63759 70692 738 D -2/ DATA ABINT4(2)/ -0.30897 11308 12858 50 D -3/ DATA ABINT4(3)/ -0.35501 01982 79857 7 D -4/ DATA ABINT4(4)/ -0.41217 92715 20133 D -5/ DATA ABINT4(5)/ -0.48235 89231 6833 D -6/ DATA ABINT4(6)/ -0.56787 30727 927 D -7/ DATA ABINT4(7)/ -0.67187 48103 65 D -8/ DATA ABINT4(8)/ -0.79811 64985 7 D -9/ DATA ABINT4(9)/ -0.95142 71478 D -10/ DATA ABINT4(10)/-0.11374 68966 D -10/ DATA ABINT4(11)/-0.13635 9969 D -11/ DATA ABINT4(12)/-0.16381 418 D -12/ DATA ABINT4(13)/-0.19725 75 D -13/ DATA ABINT4(14)/-0.23784 4 D -14/ DATA ABINT4(15)/-0.28752 D -15/ DATA ABINT4(16)/-0.3475 D -16/ DATA ABINT4(17)/-0.422 D -17/ DATA ABINT4(18)/-0.51 D -18/ DATA ABINT4(19)/-0.6 D -19/ DATA ABINT4(20)/-0.1 D -19/ DATA ABINT5(0)/ 1.12672 08196 17825 66017 D 0/ DATA ABINT5(1)/ -0.67140 55675 25561 198 D -2/ DATA ABINT5(2)/ -0.69812 91801 78329 69 D -3/ DATA ABINT5(3)/ -0.75616 89886 42527 6 D -4/ DATA ABINT5(4)/ -0.83498 55745 10207 D -5/ DATA ABINT5(5)/ -0.93630 29823 2480 D -6/ DATA ABINT5(6)/ -0.10608 55629 6250 D -6/ DATA ABINT5(7)/ -0.12131 28916 741 D -7/ DATA ABINT5(8)/ -0.13963 11297 65 D -8/ DATA ABINT5(9)/ -0.16178 91805 4 D -9/ DATA ABINT5(10)/-0.18823 07907 D -10/ DATA ABINT5(11)/-0.22027 2985 D -11/ DATA ABINT5(12)/-0.25816 189 D -12/ DATA ABINT5(13)/-0.30479 64 D -13/ DATA ABINT5(14)/-0.35837 0 D -14/ DATA ABINT5(15)/-0.42831 D -15/ DATA ABINT5(16)/-0.4993 D -16/ DATA ABINT5(17)/-0.617 D -17/ DATA ABINT5(18)/-0.68 D -18/ DATA ABINT5(19)/-0.10 D -18/ DATA ABINT5(20)/-0.1 D -19/ DATA ZERO,ONE,ONEPT5/ 0.0 D 0 , 1.0 D 0 , 1.5 D 0 / DATA THREE,FOUR,SEVEN/ 3.0 D 0 , 4.0 D 0 , 7.0 D 0 / DATA EIGHT,NINE,SIXTEN/ 8.0 D 0 , 9.0 D 0 , 16.0 D 0 / DATA ONEHUN,NINHUN,THR644/100.0 D 0 , 900.0 D 0 , 3644.0 D 0 / DATA PIBY4/0.78539 81633 97448 30962 D 0/ DATA RT2B3P/0.46065 88659 61780 63902 D 0/ DATA BIRZER/0.61492 66274 46000 73515 D 0/ C C Start computation C X = XVALUE C C Compute the machine-dependent constants. C T = D1MACH(3) F2 = ONE + ONE XNEG1 = -ONE/(T**(F2/THREE)) XMAX = D1MACH(2) F1 = LOG(XMAX) TEMP = F1 + LOG(F1)/F2 XHIGH1 = (THREE*TEMP/F2)**(F2/THREE) C C Error test C IF ( X .GT. XHIGH1 ) THEN CCCCC CALL ERRPRN(FNNAME,ERMSG1) WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,101)X CALL DPWRST('XXX','BUG ') BIRINT = XMAX RETURN ENDIF 999 FORMAT(1X) 101 FORMAT('***** ERROR FROM BIRINT--ARGUMENT TOO LARGE AND ', 1 'POSITIVE, ARGUMENT = ',G15.7) IF ( X .LT. XNEG1 ) THEN CCCCc CALL ERRPRN(FNNAME,ERMSG2) WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,201)X CALL DPWRST('XXX','BUG ') BIRINT = ZERO RETURN ENDIF 201 FORMAT('***** ERROR FROM BIRINT--ARGUMENT TOO LARGE AND ', 1 'NEGATIVE, ARGUMENT = ',G15.7) CCCCC DATA ERMSG2/'ARGUMENT TOO LARGE AND NEGATIVE'/ C C continue with machine-dependent constants C XLOW1 = F2 * T T = T / ONEHUN IF ( X .GE. ZERO ) THEN DO 10 NTERM1 = 36 , 0 , -1 IF ( ABS(ABINT1(NTERM1)) .GT. T ) GOTO 19 10 CONTINUE 19 DO 20 NTERM2 = 37 , 0 , -1 IF ( ABS(ABINT2(NTERM2)) .GT. T ) GOTO 29 20 CONTINUE 29 CONTINUE ELSE DO 30 NTERM3 = 37 , 0 , -1 IF ( ABS(ABINT3(NTERM3)) .GT. T ) GOTO 39 30 CONTINUE 39 DO 40 NTERM4 = 20 , 0 , -1 IF ( ABS(ABINT4(NTERM4)) .GT. T ) GOTO 49 40 CONTINUE 49 DO 50 NTERM5 = 20 , 0 , -1 IF ( ABS(ABINT5(NTERM5)) .GT. T ) GOTO 59 50 CONTINUE 59 ENDIF C C Code for x >= 0.0 C IF ( X .GE. ZERO ) THEN IF ( X .LT. XLOW1 ) THEN BIRINT = BIRZER * X ELSE IF ( X .LE. EIGHT ) THEN T = X / FOUR - ONE BIRINT = X * EXP(ONEPT5*X) * CHEVAL(NTERM1,ABINT1,T) ELSE T = SIXTEN * SQRT(EIGHT/X) / X - ONE Z = ( X + X ) * SQRT(X) / THREE TEMP = RT2B3P * CHEVAL(NTERM2,ABINT2,T) / SQRT(Z) TEMP = Z + LOG(TEMP) BIRINT = EXP(TEMP) ENDIF ENDIF ELSE C C Code for x < 0.0 C IF ( X .GE. -SEVEN ) THEN IF ( X .GT. -XLOW1 ) THEN BIRINT = BIRZER * X ELSE T = - ( X + X ) / SEVEN - ONE BIRINT = X * CHEVAL(NTERM3,ABINT3,T) ENDIF ELSE Z = - ( X + X ) * SQRT(-X) / THREE ARG = Z + PIBY4 TEMP = NINE * Z * Z T = (THR644 - TEMP ) / ( NINHUN + TEMP ) F1 = CHEVAL(NTERM4,ABINT4,T) * SIN(ARG) F2 = CHEVAL(NTERM5,ABINT5,T) * COS(ARG) / Z BIRINT = ( F2 - F1 ) * RT2B3P / SQRT(Z) ENDIF ENDIF RETURN END SUBROUTINE BIVAR(Z,Y,X,N,Y2,X2,N2,IWRITE,Z2, 1IBUGG3,ISUBRO,IERROR) C C PURPOSE--COMPUTE BI-VARIATE INTERPOLATION OF A VARIABLE C (GENERATE INTERPOLATED POINTS). THIS ROUTINE USES THE C B2INK AND B@VAL ROUTINES FROM CMLIB WRITTEN BY C RON BOISVERT OF NIST. C INPUT ARGUMENTS--Z = SINGLE PRECISION VARIABLE C CONTAINING THE ORIGINAL C Z AXIS DATA POINTS. C --Y = SINGLE PRECISION VARIABLE C CONTAINING THE ORIGINAL C VERTICAL AXIS DATA POINTS. C --X = SINGLE PRECISION VARIABLE C CONTAINING THE ORIGINAL C HORIZONTAL AXIS DATA POINTS. C --Y2 = SINGLE PRECISION VARIABLE C CONTAINING THE DESIRED C VERTICAL AXIS INTERPOLATION C --X2 = SINGLE PRECISION VARIABLE C CONTAINING THE DESIRED C HORIZONTAL AXIS INTERPOLATION C POINTS. C OUTPUT ARGUMENTS--Z2 = SINGLE PRECISION VARIABLE C CONTAINING THE COMPUTED C Z AXIS INTERPOLATION C POINTS. C NOTE--IT IS PROBABLY NOT PERMISSIBLE TO HAVE THE OUTPUT VECTOR C Y2(.) BEING IDENTICAL TO THE INPUT VECTOR Y(.) C NOTE--THIS SUBROUTINE DOES NOT ASSUME THAT THE INPUT C DATA IS ALREADY SORTED ACCORDING TO THE C HORIZONTAL AXIS VARIABLE. C SUCH SORTING IS DOEN HEREIN. C NOTE--IT DOES ASSUME THAT THE ORIGINAL (Y,X) POINTS FORM A C RECTANGULAR GRID (ALTHOUGH THE GRID DOES NOT HAVE TO BE C PRE-SORTED). C CAUTION--THE INPUT VECTORS Y AND X ARE SORTED HEREIN C AND SO MAY BE DIFFERENT UPON LEAVING THIS SUBROUTINE C THAN UPON ENTERING THIS SUBROUTINE. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--94/5 C ORIGINAL VERSION--MAY 1994. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IWRITE CHARACTER*4 IBUGG3 CHARACTER*4 ISUBRO CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C CHARACTER*4 IHP CHARACTER*4 IHP2 CHARACTER*4 IHWUSE CHARACTER*4 MESSAG C C--------------------------------------------------------------------- C INCLUDE 'DPCOPA.INC' C DIMENSION Z(*) DIMENSION Y(*) DIMENSION X(*) DIMENSION X2(*) DIMENSION Y2(*) DIMENSION Z2(*) C DIMENSION YTEMP(MAXOBV) DIMENSION XTEMP(MAXOBV) DIMENSION YDIST(MAXOBV) DIMENSION XDIST(MAXOBV) DIMENSION ZDIST(MAXOBV) DIMENSION ZTEMP2(MAXOBV) DIMENSION ZTEMP(MAXOBV) DIMENSION TX(MAXOBV) DIMENSION TY(MAXOBV) DIMENSION WORK(10*MAXOBV) C INCLUDE 'DPCOZZ.INC' INCLUDE 'DPCOZ2.INC' EQUIVALENCE (G2RBAG(IGAR11),YTEMP(1)) EQUIVALENCE (G2RBAG(IGAR12),YDIST(1)) EQUIVALENCE (G2RBAG(IGAR13),XDIST(1)) EQUIVALENCE (G2RBAG(IGAR14),ZDIST(1)) EQUIVALENCE (G2RBAG(IGAR15),ZTEMP2(1)) EQUIVALENCE (G2RBAG(IGAR16),ZTEMP(1)) EQUIVALENCE (G2RBAG(IGAR17),XTEMP(1)) EQUIVALENCE (G2RBAG(IGAR18),TX(1)) EQUIVALENCE (G2RBAG(IGAR19),TY(1)) EQUIVALENCE (G2RBAG(IGAR20),WORK(1)) CCCCC END CHANGE C C-----COMMON VARIABLES (GENERAL)-------------------------------------- C INCLUDE 'DPCOHK.INC' C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='BIVA' ISUBN2='R ' C IERROR='NO' C IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'IVAR')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF BIVAR--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)N 52 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') DO55I=1,N WRITE(ICOUT,56)I,Z(I),Y(I),X(I) 56 FORMAT('I,Z(I),Y(I),X(I) = ',I8,3E15.7) CALL DPWRST('XXX','BUG ') 55 CONTINUE WRITE(ICOUT,62)N2 62 FORMAT('N2 = ',I8) CALL DPWRST('XXX','BUG ') DO65I=1,N2 WRITE(ICOUT,66)I,Y2(I),X2(I) 66 FORMAT('I,Y2(I),X2(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 65 CONTINUE 90 CONTINUE C C **************************************** C ** STEP 11-- ** C ** SORT THE INPUT DATA ACCORDING ** C ** TO THE HORIZONTAL AXIS VARIABLE ** C **************************************** C ISTEPN='11' IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'IVAR') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C DO1010,I=1,N XTEMP(I)=X(I) 1010 CONTINUE C CALL SORTC(X,Y,N,X,Y) CALL SORTC(XTEMP,Z,N,XTEMP,Z) C C ******************************************************* C ** STEP 12-- ** C ** DETERMINE THE NUMBER OF DISTINCT X VALUES ** C ******************************************************* C ISTEPN='12' IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'IVAR') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NDISTX=0 DO1210I=1,N IF(NDISTX.EQ.0)GOTO1220 DO1215I2=1,NDISTX IF(X(I).EQ.XDIST(I2))GOTO1210 1215 CONTINUE 1220 CONTINUE NDISTX=NDISTX+1 XDIST(NDISTX)=X(I) 1210 CONTINUE C CALL SORT(XDIST,NDISTX,XDIST) C C ******************************************************* C ** STEP 13-- ** C ** DETERMINE THE NUMBER OF DISTINCT Y VALUES ** C ******************************************************* C ISTEPN='13' IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'IVAR') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NDISTY=0 DO1310I=1,N IF(NDISTY.EQ.0)GOTO1320 DO1315I2=1,NDISTY IF(Y(I).EQ.YDIST(I2))GOTO1310 1315 CONTINUE 1320 CONTINUE NDISTY=NDISTY+1 YDIST(NDISTY)=Y(I) 1310 CONTINUE C CALL SORT(YDIST,NDISTY,YDIST) C C ******************************************************* C ** STEP 14-- ** C ** SORT Y ASSOCIATED WITH EACH DISTINCT X VALUE ** C ** CHECK FOR REPLICATION OF POINTS ** C ** IF ALL DISTINCT (THAT IS, NO REPLICATION), ** C ** (THAT IS, HAVE NO REPLICATION), ** C ** THEN COPY OVER Z VALUES. ** C ** IF NOT ALL DISTINCT ** C ** (THAT IS, HAVE SOME REPLICATION), ** C ** THEN COMPUTE A MEAN VALUE OVER THE REPLICATES ** C ** AND TREAT THAT AS THE COMMON VALUE. ** C ** THE CORE OF THE INTERPOLATION CODE ** C ** IS EXPECTING SORTED, DISTINCT X AND Y VALUES. ** C ** ALSO CHECK THAT X AND Y FORM A RECTANGULAR GRID.** C ******************************************************* C ISTEPN='14' IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'IVAR') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NUMZ=0 ISTART=1 DO1410I=1,NDISTX XT=XDIST(I) ICOUNT=0 DO1420J=ISTART,N IF(X(J).EQ.XT)THEN IF(ICOUNT.EQ.0)IFRST=J ICOUNT=ICOUNT+1 YTEMP(ICOUNT)=Y(J) ZTEMP(ICOUNT)=Z(J) ILAST=J ELSEIF(X(J).GT.XT)THEN GOTO1421 ENDIF 1420 CONTINUE 1421 CONTINUE C ISTART=ILAST+1 CALL SORTC(YTEMP,ZTEMP,ICOUNT,YTEMP,ZTEMP) DO1471K=1,NDISTY TAG=YDIST(K) J=0 DO1472II=1,ICOUNT IF(YTEMP(II).EQ.TAG)THEN J=J+1 ZTEMP2(J)=ZTEMP(II) END IF 1472 CONTINUE NI=J IF(NI.EQ.1)THEN NUMZ=NUMZ+1 ZDIST(NUMZ)=ZTEMP2(1) ELSE IF(NI.GT.1)THEN CALL MEAN(ZTEMP2,NI,IWRITE,ZMEAN,IBUGG3,IERROR) NUMZ=NUMZ+1 ZDIST(NUMZ)=ZMEAN ELSE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1491) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1492) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ENDIF 1471 CONTINUE C 1410 CONTINUE C 1491 FORMAT('******* ERROR FROM BIVAR. ORIGINAL X AND Y') 1492 FORMAT(' DATA DO NOT FORM A RECTANGULAR GRID. ******') C C ******************************************** C ** STEP 15-- ** C ** CHECK FOR USER PARAMETERS XDEGREE AND ** C ** YDEGREE FOR ORDER OF POLYNOMIALS ** C ******************************************** C 1500 CONTINUE IXDEG=4 IYDEG=4 C XDEG=3.0 IHP='XDEG' IHP2='REE ' IHWUSE='P' MESSAG='NO' CALL CHECKN(IHP,IHP2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR) IF(IERROR.EQ.'YES')GOTO1510 XDEG=VALUE(ILOCP) 1510 CONTINUE C IXDEG=INT(XDEG+0.5) IF(IXDEG.GE.1.AND.IXDEG.LE.3)GOTO1519 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1511) 1511 FORMAT('***** ERROR IN BIVAR--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1512) 1512 FORMAT(' THE POLYNOMIAL DEGREE FOR THE B-SPLINE IN THE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1514) 1514 FORMAT(' X DIRECTION MUST BE BETWEEN 1 AND 3 INCLUSIVE;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1515) 1515 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1516)XDEG 1516 FORMAT(' THE CURRENT VALUE OF XDEGREE IS ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1517) 1517 FORMAT(' A VALUE OF 3.0 WILL BE USED') CALL DPWRST('XXX','BUG ') IXDEG=3 1519 CONTINUE IXDEG=IXDEG+1 C YDEG=3.0 IHP='YDEG' IHP2='REE ' IHWUSE='P' MESSAG='NO' CALL CHECKN(IHP,IHP2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR) IF(IERROR.EQ.'YES')GOTO1610 YDEG=VALUE(ILOCP) 1610 CONTINUE C IYDEG=INT(YDEG+0.5) IF(IYDEG.GE.1.AND.IYDEG.LE.3)GOTO1619 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1611) 1611 FORMAT('***** ERROR IN BIVAR--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1612) 1612 FORMAT(' THE POLYNOMIAL DEGREE FOR THE B-SPLINE IN THE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1614) 1614 FORMAT(' Y DIRECTION MUST BE BETWEEN 1 AND 3 INCLUSIVE;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1615) 1615 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1616)YDEG 1616 FORMAT(' THE CURRENT VALUE OF YDEGREE IS ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1617) 1617 FORMAT(' A VALUE OF 3.0 WILL BE USED') CALL DPWRST('XXX','BUG ') IYDEG=3 1619 CONTINUE IYDEG=IYDEG+1 C C C ******************************************** C ** STEP 15-- ** C ** COMPUTE INTERPOLATED VALUES ** C ******************************************** C CALL BIVAR2(ZDIST,YDIST,XDIST,NDISTX,NDISTY,Y2,X2,N2,Z2, 1IXDEG,IYDEG, 1TX,TY,WORK, 1IBUGG3,ISUBRO,IERROR) C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C 9000 CONTINUE IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'IVAR')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF BIVAR--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)N,N2 9012 FORMAT('N,N2 = ',2I8) CALL DPWRST('XXX','BUG ') DO9042I=1,N2 WRITE(ICOUT,9043)I,X2(I),Y2(I),Z2(I) 9043 FORMAT('I,X2(I),Y2(I),Z2(I) = ',I8,3E15.7) CALL DPWRST('XXX','BUG ') 9042 CONTINUE WRITE(ICOUT,9051)NDISTX,NDISTY 9051 FORMAT('NDISTX,NDISTY = ',2I8) CALL DPWRST('XXX','BUG ') DO9052I=1,NDISTX DO9054J=1,NDISTY WRITE(ICOUT,9053)I,J,XDIST(I),YDIST(J),ZDIST((I-1)*NDISTY+J) 9053 FORMAT('I,J,XDIST(I),YDIST(J),ZDIST = ',2I8,3E15.7) CALL DPWRST('XXX','BUG ') 9054 CONTINUE 9052 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE BIVAR2(Z,Y,X,NX,NY,Y2,X2,N2,Z2, 1IXDEG,IYDEG, 1TX,TY,WORK, 1IBUGG3,ISUBRO,IERROR) C C PURPOSE--COMPUTE BI-LINEAR INTERPOLATION OF A VARIABLE C (GENERATE INTERPOLATED POINTS). THIS ROUTINE USES THE C B2INK AND B2VAL ROUTINES FROM CMLIB WRITTEN BY C RON BOISVERT OF NIST. C INPUT ARGUMENTS--Z = SINGLE PRECISION VARIABLE C CONTAINING THE ORIGINAL C Z AXIS DATA POINTS. C --Y = SINGLE PRECISION VARIABLE C CONTAINING THE ORIGINAL C VERTICAL AXIS DATA POINTS. C --X = SINGLE PRECISION VARIABLE C CONTAINING THE ORIGINAL C HORIZONTAL AXIS DATA POINTS. C --Y2 = SINGLE PRECISION VARIABLE C CONTAINING THE DESIRED C VERTICAL AXIS INTERPOLATION C --X2 = SINGLE PRECISION VARIABLE C CONTAINING THE DESIRED C HORIZONTAL AXIS INTERPOLATION C POINTS. C OUTPUT ARGUMENTS--Z2 = SINGLE PRECISION VARIABLE C CONTAINING THE COMPUTED C VERTICAL AXIS INTERPOLATION C POINTS. C NOTE--IT IS PROBABLY NOT PERMISSIBLE TO HAVE THE OUTPUT VECTOR C Z2(.) BEING IDENTICAL TO THE INPUT VECTOR Z(.) C NOTE--THE X AND Y POINTS ARE ASSUMED TO LIE ON A RECTANGULAR GRID C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--94/5 C ORIGINAL VERSION--MAY 1994. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IBUGG3 CHARACTER*4 ISUBRO CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C C DIMENSION Z(*) DIMENSION Y(*) DIMENSION X(*) DIMENSION Z2(*) DIMENSION Y2(*) DIMENSION X2(*) DIMENSION TX(*) DIMENSION TY(*) DIMENSION WORK(*) C C-----COMMON VARIABLES (GENERAL)-------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='BILI' ISUBN2='N2 ' C IERROR='NO' C DO10I=1,N2 Z2(I)=0.0 10 CONTINUE C IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'VAR2')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF BIVAR2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)NX,NY 52 FORMAT('NX, NY = ',2I8) CALL DPWRST('XXX','BUG ') DO54I=1,NX DO55J=1,NY INDX=(I-1)*NY+J WRITE(ICOUT,53)I,J,X(I),Y(J),Z(INDX) CALL DPWRST('XXX','BUG ') 53 FORMAT('I,J,X(I),Y(J),Z = ',2I8,3E15.7) CALL DPWRST('XXX','BUG ') 55 CONTINUE 54 CONTINUE WRITE(ICOUT,62)N2 62 FORMAT('N2 = ',I8) CALL DPWRST('XXX','BUG ') DO65I=1,N2 WRITE(ICOUT,66)I,Y2(I),X2(I) 66 FORMAT('I,Y2(I),X2(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 65 CONTINUE 90 CONTINUE C C **************************************** C ** STEP 31-- C ** COMPUTE INTERPOLATION VALUES C **************************************** C DO3100J=1,N2 XT=X2(J) IF(X(1).GT.XT.OR.XT.GT.X(NX))GOTO3110 YT=Y2(J) IF(Y(1).GT.YT.OR.YT.GT.Y(NY))GOTO3120 GOTO3129 C 3110 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3111) 3111 FORMAT('***** ERROR IN BIVAR2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3112) 3112 FORMAT(' AN ATTEMPT WAS MADE TO COMPUTE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3113) 3113 FORMAT(' A SMOOTHED VALUE BEYOND THE X RANGE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3114) 3114 FORMAT(' OF THE DATA--SUCH EXTRAPOLATION') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3115) 3115 FORMAT(' IS UNRELIABLE AND NOT PERMITTED.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3116)X(1) 3116 FORMAT(' SMALLEST DATA POINT X(1) = ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3117)X(NX) 3117 FORMAT(' LARGEST DATA POINT X(NX) = ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3118)XT 3118 FORMAT(' ATTEMPTED EXTRAPOLATION POINT = ',E15.7) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 3120 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3121) 3121 FORMAT('***** ERROR IN BIVAR2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3122) 3122 FORMAT(' AN ATTEMPT WAS MADE TO COMPUTE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3123) 3123 FORMAT(' A SMOOTHED VALUE BEYOND THE Y RANGE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3124) 3124 FORMAT(' OF THE DATA--SUCH EXTRAPOLATION') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3125) 3125 FORMAT(' IS UNRELIABLE AND NOT PERMITTED.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3126)Y(1) 3126 FORMAT(' SMALLEST DATA POINT Y(1) = ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3127)Y(NY) 3127 FORMAT(' LARGEST DATA POINT Y(NY) = ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3128)YT 3128 FORMAT(' ATTEMPTED EXTRAPOLATION POINT = ',E15.7) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 3129 CONTINUE 3100 CONTINUE C IFLAG=0 CALL B2INK(X,NX,Y,NY,Z,NX,IXDEG,IYDEG,TX,TY,Z,WORK,IFLAG) IF(IFLAG.EQ.1)GOTO3199 IERROR='YES' WRITE(ICOUT,3130)IFLAG CALL DPWRST('XXX','BUG ') 3130 FORMAT('***** B2INK RETURNED ERROR CODE ',I2) WRITE(ICOUT,3131) CALL DPWRST('XXX','BUG ') 3131 FORMAT(' NO INTERPOLATION PERFORMED. *****') GOTO9000 C 3199 CONTINUE C IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'VAR2')GOTO3190 DO3191J=1,NX+IXDEG WRITE(ICOUT,3192)J,TX(J) CALL DPWRST('XXX','BUG ') 3192 FORMAT('J,TX(J) = ',I5,1X,E15.7) 3191 CONTINUE DO3193J=1,NY+IYDEG WRITE(ICOUT,3194)J,TY(J) CALL DPWRST('XXX','BUG ') 3194 FORMAT('J,TY(J) = ',I5,1X,E15.7) 3193 CONTINUE 3190 CONTINUE C IDX=0 IDY=0 DO3200I=1,N2 XVAL=X2(I) YVAL=Y2(I) Z2(I)=B2VAL(XVAL,YVAL,IDX,IDY,TX,TY,NX,NY,IXDEG,IYDEG, 1 Z,WORK) 3200 CONTINUE C C **************************************** C ** STEP 41-- C ** IF CALLED FOR, C ** WRITE OUT INTERPOLATION VALUES C **************************************** C IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'VAR2')GOTO4190 DO4100J=1,N2 WRITE(ICOUT,4110)X2(J),Y2(J),Z2(J) CALL DPWRST('XXX','BUG ') 4110 FORMAT('X2(J),Y2(J),Z2(J) = ',3E15.7) 4100 CONTINUE 4190 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C 9000 CONTINUE IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'VAR2')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF BIVAR2--') CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE BIWMCV(X,Y,N,IWRITE,XTEMP,XTEMP2,MAXNXT,XBWCOV, 1IBUGA3,IERROR) C C PURPOSE--THIS SUBROUTINE COMPUTES THE C SAMPLE BIWEIGHT MID-COVARIANCE ESTIMATOR C OF THE DATA IN THE INPUT VECTOR X. C THE SAMPLE BIWEIGHT MID-COVARIANCE ESTIMATE IS DEFINED AS: C s(bxy)**2 = SUM'[{a(i)*(x-x')**2*(1-u**2)**2}* C {b(i)*(y-y')**2*(1-v**2)**2}]/ C {SUM'[a(i)*(1-u**2)*(1-5*u**2)]* C SUM'[b(i)*(1-v**2)*(1-5*v**2)]} C WHERE C y' = MEDIAN OF Y C x' = MEDIAN OF X C MAD = MEDIAN ABSOLUTE DEVIATION C u(i) = (X(i) - x')/(9*MAD) C v(i) = (Y(i) - y')/(9*MAD) C a(i) = 1 if |u(i)| <= 1, 0 otherwise C b(i) = 1 if |v(i)| <= 1, 0 otherwise C SUM' means the summation is for u**2 < 1 or v**2 < 1 C INPUT ARGUMENTS--X = THE SINGLE PRECISION VECTOR OF C (UNSORTED OR SORTED) OBSERVATIONS. C --Y = THE SINGLE PRECISION VECTOR OF C (UNSORTED OR SORTED) OBSERVATIONS. C --N = THE INTEGER NUMBER OF OBSERVATIONS C IN THE VECTORS X AND Y. C OUTPUT ARGUMENTS--XBWCOV = THE SINGLE PRECISION VALUE OF THE C COMPUTED SAMPLE BIWEIGHT MID-COVARIANCE C ESTIMATE. C OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE C SAMPLE BIWEIGHT LOCATION ESTIMATE. C OTHER DATAPLOT SUBROUTINES NEEDED--MEDIAN, MAD C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--MOSTELLER AND TUKEY, 'DATA ANALYSIS AND REGRESSION' C ADDISON AND WESLEY, 1977, PP. 204-206. C REFERENCES--RAND R. WILCOX, 'INTORIDUCTION TO ROBUST ESTIMATION C AND HYPOTHESIS TESTING' C ACADEMIC PRESS, 1997. PP. 196-197. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2002/7 C ORIGINAL VERSION--JULY 2002. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IWRITE CHARACTER*4 IBUGA3 CHARACTER*4 IERROR C CHARACTER*4 IWRIT2 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C C DOUBLE PRECISION DSUM1 DOUBLE PRECISION DSUM2 DOUBLE PRECISION DSUM3 DOUBLE PRECISION DUI DOUBLE PRECISION DSBI C DIMENSION X(*) DIMENSION Y(*) DIMENSION XTEMP(*) DIMENSION XTEMP2(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='BIWM' ISUBN2='CV ' XBWCOV=0.0 C IERROR='NO' C IF(IBUGA3.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF BIWMCV--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA3 52 FORMAT('IBUGA3 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)N 53 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') DO55I=1,N WRITE(ICOUT,56)I,X(I) 56 FORMAT('I,X(I) = ',I8,E15.7) CALL DPWRST('XXX','BUG ') 55 CONTINUE 90 CONTINUE C C ******************************************** C ** COMPUTE BIWEIGHT MID-COVARIANCE ESTIMATE ** C ******************************************** C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C AN=N C IF(N.GT.1)GOTO119 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,111) 111 FORMAT('***** ERROR IN BIWMCV--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,112) 112 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,113) 113 FORMAT(' IN THE VARIABLE FOR WHICH') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,114) 114 FORMAT(' THE BIWEIGHT MID-COVARIANCE ESTIMATE IS TO BE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,115) 115 FORMAT(' COMPUTED, MUST BE 2 OR LARGER.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,116) 116 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,117)N 117 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8, 1'.') CALL DPWRST('XXX','BUG ') GOTO9000 119 CONTINUE C HOLD=X(1) DO135I=2,N IF(X(I).NE.HOLD)GOTO139 135 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,136)HOLD 136 FORMAT('***** NON-FATAL DIAGNOSTIC IN BIWMCV--', 1'THE FIRST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7) CALL DPWRST('XXX','BUG ') XBWCOV=0.0 GOTO9000 139 CONTINUE C 190 CONTINUE C C ****************************************************** C ** STEP 2-- ** C ** COMPUTE THE BIWEIGHT MID-COVARIANCE ESTIMATE. ** C ****************************************************** C IWRIT2='OFF' CALL MEDIAN(X,N,IWRIT2,XTEMP,MAXNXT,XMED,IBUGA3,IERROR) DO205I=1,N XTEMP2(I)=X(I) 205 CONTINUE CALL MAD(X,N,IWRIT2,XTEMP,MAXNXT,XMAD,IBUGA3,IERROR) DO215I=1,N X(I)=XTEMP2(I) 215 CONTINUE C IWRIT2='OFF' CALL MEDIAN(Y,N,IWRIT2,XTEMP,MAXNXT,YMED,IBUGA3,IERROR) DO225I=1,N XTEMP2(I)=Y(I) 225 CONTINUE CALL MAD(Y,N,IWRIT2,XTEMP,MAXNXT,YMAD,IBUGA3,IERROR) DO235I=1,N Y(I)=XTEMP2(I) 235 CONTINUE C DSUM1=0.0D0 DSUM2=0.0D0 DSUM3=0.0D0 DO300I=1,N DUI=DBLE((X(I) - XMED)/(9.0*XMAD)) DVI=DBLE((Y(I) - YMED)/(9.0*YMAD)) IF(DUI*DUI.LE.1.0D0)THEN DTERM1=DBLE(X(I)-XMED)*(1.0D0 - DUI**2)**2 DSUM2=DSUM2 + (1.0D0 - DUI**2)*(1.0D0 - 5.0D0*DUI**2) ELSE DTERM1=0.0D0 ENDIF IF(DVI*DVI.LE.1.0D0)THEN DTERM2=DBLE(Y(I)-YMED)*(1.0D0 - DVI**2)**2 DSUM3=DSUM3 + (1.0D0 - DVI**2)*(1.0D0 - 5.0D0*DVI**2) ELSE DTERM2=0.0D0 ENDIF DSUM1=DSUM1 + DTERM1*DTERM2 300 CONTINUE DSBI=DBLE(N)*DSUM1/(DSUM2*DSUM3) XBWCOV=REAL(DSBI) C C ******************************* C ** STEP 3-- ** C ** WRITE OUT A LINE ** C ** OF SUMMARY INFORMATION. ** C ******************************* C IF(IFEEDB.EQ.'OFF')GOTO890 IF(IWRITE.EQ.'OFF')GOTO890 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,811)N,XBWCOV 811 FORMAT('THE BIWEIGHT MID-COVARIANCE ESTIMATE OF THE ',I8, 1' OBSERVATIONS = ',E15.7) CALL DPWRST('XXX','BUG ') 890 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C 9000 CONTINUE IF(IBUGA3.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF BIWMCV--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGA3,IERROR 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)N 9013 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)XBWCOV 9015 FORMAT('XBWCOV = ',E15.7) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE BIWEIG(RES,N,IWRITE,WEIGHT,IBUGA3,IERROR) C PURPOSE--DETERMINE THE N VERTICAL (ROBUST) WEIGHTS WEIGHT(.) C BASED ON A BIWEIGHT WEIGHTING SCHEME OF C THE RESIDUALS IN RES(.). C NOTE--IF ALL INPUT RESIDUALS ARE ZERO, THIS SUBROUTINE C WILL OUTPUT ALL WEIGHTS AS UNITY. C REFERENCE--CHAMBERS, ET AL. GRAPHICAL METHODS FOR DATA ANALYSIS. C WADSWORTH, 11013, PAGES 98-101, 122-123. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-921-3651 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--88/2 C ORIGINAL VERSION--FEBRUARY 1988 C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IWRITE CHARACTER*4 IBUGA3 CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C DIMENSION RES(*) DIMENSION WEIGHT(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='BIWE' ISUBN2='IG ' C IERROR='NO' C IF(IBUGA3.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF BIWEIG--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA3,IERROR 52 FORMAT('IBUGA3,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)N 53 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') IF(N.LE.0)GOTO63 DO61I=1,N WRITE(ICOUT,62)I,RES(I) 62 FORMAT('I,RES(I) = ',I8,E15.7) CALL DPWRST('XXX','BUG ') 61 CONTINUE 63 CONTINUE 90 CONTINUE C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C IF(N.GE.1)GOTO119 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,111) 111 FORMAT('***** ERROR IN BIWEIG--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,112) 112 FORMAT(' THE INPUT FULL SAMPLE SIZE,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,113) 113 FORMAT(' FOR WHICH BIWEIGHT WEIGHTS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,114) 114 FORMAT(' ARE TO BE COMPUTED, MUST BE 1 OR LARGER.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,115) 115 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,116)N 116 FORMAT(' THE FULL SAMPLE SIZE N = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 119 CONTINUE C C *********************************************** C ** STEP 11-- ** C ** COMPUTE THE BIWEIGHT WEIGHTING ** C ** 1) COMPUTE ABSOLUTE VALUE OF RESIDUALS C ** 2) COMPUTE MEDIAN ABSOLUTE VALUE RESIDUAL C ** 3) COMPUTE CUTOFF = +-6*M.A.R. C ** 4) ASSIGN 0 WEIGHTS OUTSIDE OF REGION C ** 5) ASSIGN BIWEIGHTS INSIDE OF REGION C *********************************************** C DO1100I=1,N WEIGHT(I)=ABS(RES(I)) 1100 CONTINUE C CALL SORT(WEIGHT,N,WEIGHT) IEVODD=N-(N/2)*2 NMID=N/2 NMIDP1=NMID+1 IF(IEVODD.EQ.0)XMEDAR=(WEIGHT(NMID)+WEIGHT(NMIDP1))/2.0 IF(IEVODD.EQ.1)XMEDAR=WEIGHT(NMIDP1) C IF(XMEDAR.EQ.0.0)GOTO1110 GOTO1120 C 1110 CONTINUE CONST=(-999.0) DO1111I=1,N WEIGHT(I)=1.0 1111 CONTINUE GOTO1190 C 1120 CONTINUE CONST=6.0*XMEDAR DO1121I=1,N U=RES(I)/CONST WEIGHT(I)=0.0 IF(-1.0.LE.U.AND.U.LE.1.0)WEIGHT(I)=(1.0-U**2)**2 1121 CONTINUE GOTO1190 C 1190 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGA3.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF BIWEIG--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGA3,IERROR 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)N 9013 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)XMEDAR 9014 FORMAT('XMEDAR = ',E15.7) CALL DPWRST('XXX','BUG ') IF(N.LE.0)GOTO9023 DO9021I=1,N WRITE(ICOUT,9022)I,RES(I),WEIGHT(I) 9022 FORMAT('I,RES(I),WEIGHT(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 9021 CONTINUE 9023 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE BIWMDV(X,N,IWRITE,XTEMP,XTEMP2,MAXNXT,XBWMDV, 1IBUGA3,IERROR) C C PURPOSE--THIS SUBROUTINE COMPUTES THE C SAMPLE BIWEIGHT MIDVARIANCE ESTIMATOR C OF THE DATA IN THE INPUT VECTOR X. C THE SAMPLE BIWEIGHT MIDVARIANCE ESTIMATE IS DEFINED AS: C s(bi)**2 = SUM'[(y-y')**2*(1-u**2)**4]/ C {SUM'[1-u**2)*(1-5*u**2)]**2} C WHERE C y' = MEDIAN OF Y C MAD = MEDIAN ABSOLUTE DEVIATION C u(i) = (Y(i) - y')/(9*MAD) C SUM' means the summation is for u**2 <= 1 C NOTE THAT THIS IS A SLIGHT VARIATION OF THE C BIWEIGHT SCALE ESTIMATE. C INPUT ARGUMENTS--X = THE SINGLE PRECISION VECTOR OF C (UNSORTED OR SORTED) OBSERVATIONS. C --N = THE INTEGER NUMBER OF OBSERVATIONS C IN THE VECTOR X. C OUTPUT ARGUMENTS--XBWMDV = THE SINGLE PRECISION VALUE OF THE C COMPUTED SAMPLE BIWEIGHT MIDVARIANCE C ESTIMATE. C OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE C SAMPLE BIWEIGHT LOCATION ESTIMATE. C OTHER DATAPLOT SUBROUTINES NEEDED--MEAN, MAD C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--MOSTELLER AND TUKEY, 'DATA ANALYSIS AND REGRESSION' C ADDISON AND WESLEY, 1977, PP. 204-206. C REFERENCES--RAND R. WILCOX, 'INTORIDUCTION TO ROBUST ESTIMATION C AND HYPOTHESIS TESTING' C ACADEMIC PRESS, 1997. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2002/7 C ORIGINAL VERSION--JULY 2002. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IWRITE CHARACTER*4 IBUGA3 CHARACTER*4 IERROR C CHARACTER*4 IWRIT2 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C C DOUBLE PRECISION DSUM1 DOUBLE PRECISION DSUM2 DOUBLE PRECISION DUI DOUBLE PRECISION DSBI C DIMENSION X(*) DIMENSION XTEMP(*) DIMENSION XTEMP2(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='BIWM' ISUBN2='DV ' XBWMDV=0.0 C IERROR='NO' C IF(IBUGA3.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF BIWMDV--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA3 52 FORMAT('IBUGA3 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)N 53 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') DO55I=1,N WRITE(ICOUT,56)I,X(I) 56 FORMAT('I,X(I) = ',I8,E15.7) CALL DPWRST('XXX','BUG ') 55 CONTINUE 90 CONTINUE C C ******************************************** C ** COMPUTE BIWEIGHT MIDVARIANCE ESTIMATE ** C ******************************************** C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C AN=N C IF(N.GT.1)GOTO119 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,111) 111 FORMAT('***** ERROR IN BIWMDV--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,112) 112 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,113) 113 FORMAT(' IN THE VARIABLE FOR WHICH') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,114) 114 FORMAT(' THE BIWEIGHT MIDVARIANCE ESTIMATE IS TO BE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,115) 115 FORMAT(' COMPUTED, MUST BE 2 OR LARGER.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,116) 116 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,117)N 117 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8, 1'.') CALL DPWRST('XXX','BUG ') GOTO9000 119 CONTINUE C HOLD=X(1) DO135I=2,N IF(X(I).NE.HOLD)GOTO139 135 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,136)HOLD 136 FORMAT('***** NON-FATAL DIAGNOSTIC IN BIWMDV--', 1'THE FIRST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7) CALL DPWRST('XXX','BUG ') XBWMDV=0.0 GOTO9000 139 CONTINUE C 190 CONTINUE C C *************************************************** C ** STEP 2-- ** C ** COMPUTE THE BIWEIGHT MIDVARIANCE ESTIMATE. ** C *************************************************** C IWRIT2='OFF' CALL MEDIAN(X,N,IWRIT2,XTEMP,MAXNXT,XMED,IBUGA3,IERROR) DO205I=1,N XTEMP2(I)=X(I) 205 CONTINUE CALL MAD(X,N,IWRIT2,XTEMP,MAXNXT,XMAD,IBUGA3,IERROR) DO215I=1,N X(I)=XTEMP2(I) 215 CONTINUE C DSUM1=0.0D0 DSUM2=0.0D0 DO300I=1,N DUI=DBLE((X(I) - XMED)/(9.0*XMAD)) IF(DUI*DUI.LT.1.0D0)THEN DSUM1=DSUM1 + (DBLE(X(I)-XMED)**2)*(1.0D0 - DUI**2)**4 DSUM2=DSUM2 + (1.0D0 - DUI**2)*(1.0D0 - 5.0D0*DUI**2) ENDIF 300 CONTINUE DSBI=DBLE(N)*DSUM1/(DSUM2*DSUM2) XBWMDV=REAL(DSBI) C C ******************************* C ** STEP 3-- ** C ** WRITE OUT A LINE ** C ** OF SUMMARY INFORMATION. ** C ******************************* C IF(IFEEDB.EQ.'OFF')GOTO890 IF(IWRITE.EQ.'OFF')GOTO890 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,811)N,XBWMDV 811 FORMAT('THE BIWEIGHT MIDVARIANCE ESTIMATE OF THE ',I8, 1' OBSERVATIONS = ',E15.7) CALL DPWRST('XXX','BUG ') 890 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C 9000 CONTINUE IF(IBUGA3.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF BIWMDV--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGA3,IERROR 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)N 9013 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)XBWMDV 9015 FORMAT('XBWMDV = ',E15.7) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE BIWLOC(X,N,IWRITE,XTEMP,XTEMP2,MAXNXT,XBW, 1IBUGA3,IERROR) C C PURPOSE--THIS SUBROUTINE COMPUTES THE C SAMPLE BIWEIGHT LOCATION ESTIMATOR C OF THE DATA IN THE INPUT VECTOR X. C THE SAMPLE BIWEIGHT LOCATION ESTIMATE IS DEFINED AS: C y* = SUM[w(i)*y(i)]/SUM[w(i)] C WHERE C w(i) = (1 - ((y(i) - y*)/(6*MAD))**2)**2 C if (y(i) - y*)/(6*MAD))**2 < 1 C = 0 otherwise C WHERE MAD IS THE BIWEIGHT LOCATION ESTIMATE C INPUT ARGUMENTS--X = THE SINGLE PRECISION VECTOR OF C (UNSORTED OR SORTED) OBSERVATIONS. C --N = THE INTEGER NUMBER OF OBSERVATIONS C IN THE VECTOR X. C OUTPUT ARGUMENTS--XBW = THE SINGLE PRECISION VALUE OF THE C COMPUTED SAMPLE BIWEIGHT LOCATION C ESTIMATE. C OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE C SAMPLE BIWEIGHT LOCATION ESTIMATE. C OTHER DATAPLOT SUBROUTINES NEEDED--MEAN, MAD C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--MOSTELLER AND TUKEY, 'DATA ANALYSIS AND REGRESSION' C ADDISON AND WESLEY, 1977, PP. 204-206. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2001/11 C ORIGINAL VERSION--NOVEMBER 2001. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IWRITE CHARACTER*4 IBUGA3 CHARACTER*4 IERROR C CHARACTER*4 IWRIT2 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C C DOUBLE PRECISION DSUM1 DOUBLE PRECISION DSUM2 DOUBLE PRECISION DWT C DIMENSION X(*) DIMENSION XTEMP(*) DIMENSION XTEMP2(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='BIWL' ISUBN2='OC ' XBW=0.0 C IERROR='NO' C IF(IBUGA3.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF BIWLOC--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA3 52 FORMAT('IBUGA3 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)N 53 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') DO55I=1,N WRITE(ICOUT,56)I,X(I) 56 FORMAT('I,X(I) = ',I8,E15.7) CALL DPWRST('XXX','BUG ') 55 CONTINUE 90 CONTINUE C C ****************************************** C ** COMPUTE BIWEIGHT LOCATION ESTIMATE ** C ****************************************** C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C AN=N C IF(N.GT.1)GOTO119 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,111) 111 FORMAT('***** ERROR IN BIWLOC--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,112) 112 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,113) 113 FORMAT(' IN THE VARIABLE FOR WHICH') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,114) 114 FORMAT(' THE BIWEIGHT LOCATION ESTIMATE IS TO BE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,115) 115 FORMAT(' COMPUTED, MUST BE 2 OR LARGER.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,116) 116 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,117)N 117 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8, 1'.') CALL DPWRST('XXX','BUG ') GOTO9000 119 CONTINUE C HOLD=X(1) DO135I=2,N IF(X(I).NE.HOLD)GOTO139 135 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,136)HOLD 136 FORMAT('***** NON-FATAL DIAGNOSTIC IN BIWLOC--', 1'THE FIRST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7) CALL DPWRST('XXX','BUG ') XBW=HOLD GOTO9000 139 CONTINUE C 190 CONTINUE C C *********************************************** C ** STEP 2-- ** C ** COMPUTE THE BIWEIGHT LOCATION ESTIMATE. ** C *********************************************** C IWRIT2='OFF' C DO195I=1,N XTEMP2(I)=X(I) 195 CONTINUE C CALL MEAN(X,N,IWRIT2,XMEAN,IBUGA3,IERROR) CCCCC CALL MAD(X,N,IWRIT2,XTEMP,MAXNXT,XMAD,IBUGA3,IERROR) ITER=0 C DO198I=1,N X(I)=XTEMP2(I) 198 CONTINUE C 200 CONTINUE C DO205I=1,N XTEMP2(I)=ABS(X(I)-XMEAN) 205 CONTINUE CALL MEDIAN(XTEMP2,N,IWRIT2,XTEMP,MAXNXT,XMAD,IBUGA3,IERROR) C XMEANO=XMEAN DSUM1=0.0D0 DSUM2=0.0D0 DO300I=1,N XTEMP(I)=((X(I) - XMEAN)/(6.0*XMAD))**2 IF(XTEMP(I).LT.1.0)THEN DWT=DBLE(XTEMP(I)) DWT=(1.0D0 - DWT)**2 DSUM1=DSUM1 + DWT*DBLE(X(I)) DSUM2=DSUM2 + DWT ENDIF 300 CONTINUE IF(DSUM2.NE.0.0D0)THEN XMEAN=REAL(DSUM1/DSUM2) ELSE XMEAN=0.0 ENDIF ITER=ITER+1 IF(ABS(XMEAN-XMEANO).GT.0.00001 .AND. ITER.LE.10)GOTO200 XBW=XMEAN C C ******************************* C ** STEP 3-- ** C ** WRITE OUT A LINE ** C ** OF SUMMARY INFORMATION. ** C ******************************* C IF(IFEEDB.EQ.'OFF')GOTO890 IF(IWRITE.EQ.'OFF')GOTO890 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,811)N,XBW 811 FORMAT('THE BIWEIGHT LOCATION ESTIMATE OF THE ',I8, 1' OBSERVATIONS = ',E15.7) CALL DPWRST('XXX','BUG ') 890 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C 9000 CONTINUE IF(IBUGA3.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF BIWLOC--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGA3,IERROR 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)N 9013 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)XBW 9015 FORMAT('XBW = ',E15.7) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE BIWSCA(X,N,IWRITE,XTEMP,XTEMP2,MAXNXT,XBS, 1IBUGA3,IERROR) C C PURPOSE--THIS SUBROUTINE COMPUTES THE C SAMPLE BIWEIGHT SCALE ESTIMATOR C OF THE DATA IN THE INPUT VECTOR X. C THE SAMPLE BIWEIGHT LOCATION ESTIMATE IS DEFINED AS: C s(bi)**2= SUM'[(y-y')**2*(1-u**2)**4]/ C {SUM'[1-u**2)*(1-5*u**2)]* C [-1 + SUM'[(1-u**2)*(1-5*u**2)]} C WHERE C y' = MEDIAN OF Y C MAD = MEDIAN ABSOLUTE DEVIATION C u(i) = (Y(i) - y')/(9*MAD) C SUM' means the summation is for u**2 <= 1 C INPUT ARGUMENTS--X = THE SINGLE PRECISION VECTOR OF C (UNSORTED OR SORTED) OBSERVATIONS. C --N = THE INTEGER NUMBER OF OBSERVATIONS C IN THE VECTOR X. C OUTPUT ARGUMENTS--XBS = THE SINGLE PRECISION VALUE OF THE C COMPUTED SAMPLE BIWEIGHT LOCATION C ESTIMATE. C OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE C SAMPLE BIWEIGHT LOCATION ESTIMATE. C OTHER DATAPLOT SUBROUTINES NEEDED--MEAN, MAD C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--MOSTELLER AND TUKEY, 'DATA ANALYSIS AND REGRESSION' C ADDISON AND WESLEY, 1977, PP. 204-206. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2001/11 C ORIGINAL VERSION--NOVEMBER 2001. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IWRITE CHARACTER*4 IBUGA3 CHARACTER*4 IERROR C CHARACTER*4 IWRIT2 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C C DOUBLE PRECISION DSUM1 DOUBLE PRECISION DSUM2 DOUBLE PRECISION DUI DOUBLE PRECISION DSBI C DIMENSION X(*) DIMENSION XTEMP(*) DIMENSION XTEMP2(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='BIWL' ISUBN2='OC ' XBS=0.0 C IERROR='NO' C IF(IBUGA3.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF BIWSCA--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA3 52 FORMAT('IBUGA3 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)N 53 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') DO55I=1,N WRITE(ICOUT,56)I,X(I) 56 FORMAT('I,X(I) = ',I8,E15.7) CALL DPWRST('XXX','BUG ') 55 CONTINUE 90 CONTINUE C C ****************************************** C ** COMPUTE BIWEIGHT SCALE ESTIMATE ** C ****************************************** C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C AN=N C IF(N.GT.1)GOTO119 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,111) 111 FORMAT('***** ERROR IN BIWSCA--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,112) 112 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,113) 113 FORMAT(' IN THE VARIABLE FOR WHICH') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,114) 114 FORMAT(' THE BIWEIGHT SCALE ESTIMATE IS TO BE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,115) 115 FORMAT(' COMPUTED, MUST BE 2 OR LARGER.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,116) 116 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,117)N 117 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8, 1'.') CALL DPWRST('XXX','BUG ') GOTO9000 119 CONTINUE C HOLD=X(1) DO135I=2,N IF(X(I).NE.HOLD)GOTO139 135 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,136)HOLD 136 FORMAT('***** NON-FATAL DIAGNOSTIC IN BIWSCA--', 1'THE FIRST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7) CALL DPWRST('XXX','BUG ') XBS=0.0 GOTO9000 139 CONTINUE C 190 CONTINUE C C *********************************************** C ** STEP 2-- ** C ** COMPUTE THE BIWEIGHT SCALE ESTIMATE. ** C *********************************************** C IWRIT2='OFF' CALL BIWLOC(X,N,IWRIT2,XTEMP,XTEMP2,MAXNXT,XBW,IBUGA3,IERROR) DO205I=1,N XTEMP2(I)=X(I) 205 CONTINUE CALL MAD(X,N,IWRIT2,XTEMP,MAXNXT,XMAD,IBUGA3,IERROR) DO215I=1,N X(I)=XTEMP2(I) 215 CONTINUE C DSUM1=0.0D0 DSUM2=0.0D0 DO300I=1,N DUI=DBLE((X(I) - XBW)/(9.0*XMAD)) IF(DUI*DUI.LE.1.0D0)THEN DSUM1=DSUM1 + (DBLE(X(I)-XBW)**2)*(1.0D0 - DUI**2)**4 DSUM2=DSUM2 + (1.0D0 - DUI**2)*(1.0D0 - 5.0D0*DUI**2) ENDIF 300 CONTINUE DSBI=DBLE(N)*DSUM1/(DSUM2*(-1.0D0 + DSUM2)) XBS=REAL(DSBI) C C ******************************* C ** STEP 3-- ** C ** WRITE OUT A LINE ** C ** OF SUMMARY INFORMATION. ** C ******************************* C IF(IFEEDB.EQ.'OFF')GOTO890 IF(IWRITE.EQ.'OFF')GOTO890 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,811)N,XBS 811 FORMAT('THE BIWEIGHT SCALE ESTIMATE OF THE ',I8, 1' OBSERVATIONS = ',E15.7) CALL DPWRST('XXX','BUG ') 890 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C 9000 CONTINUE IF(IBUGA3.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF BIWSCA--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGA3,IERROR 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)N 9013 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)XBS 9015 FORMAT('XBS = ',E15.7) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE BKNOT(X,N,K,T) C***BEGIN PROLOGUE BKNOT C***REFER TO B2INK,B3INK C***ROUTINES CALLED (NONE) C***END PROLOGUE BKNOT C C -------------------------------------------------------------------- C BKNOT CHOOSES A KNOT SEQUENCE FOR INTERPOLATION OF ORDER K AT THE C DATA POINTS X(I), I=1,..,N. THE N+K KNOTS ARE PLACED IN THE ARRAY C T. K KNOTS ARE PLACED AT EACH ENDPOINT AND NOT-A-KNOT END C CONDITIONS ARE USED. THE REMAINING KNOTS ARE PLACED AT DATA POINTS C IF N IS EVEN AND BETWEEN DATA POINTS IF N IS ODD. THE RIGHTMOST C KNOT IS SHIFTED SLIGHTLY TO THE RIGHT TO INSURE PROPER INTERPOLATION C AT X(N) (SEE PAGE 350 OF THE REFERENCE). C -------------------------------------------------------------------- C C ------------ C DECLARATIONS C ------------ C C PARAMETERS C INTEGER * N, K REAL * X(N), T(*) C C LOCAL VARIABLES C INTEGER * I, J, IPJ, NPJ, IP1 REAL * RNOT C C C ---------------------------- C PUT K KNOTS AT EACH ENDPOINT C ---------------------------- C C (SHIFT RIGHT ENPOINTS SLIGHTLY -- SEE PG 350 OF REFERENCE) RNOT = X(N) + 0.10E0*( X(N)-X(N-1) ) DO 110 J=1,K T(J) = X(1) NPJ = N + J T(NPJ) = RNOT 110 CONTINUE C C -------------------------- C DISTRIBUTE REMAINING KNOTS C -------------------------- C IF (MOD(K,2) .EQ. 1) GO TO 150 C C CASE OF EVEN K -- KNOTS AT DATA POINTS C I = (K/2) - K JSTRT = K+1 DO 120 J=JSTRT,N IPJ = I + J T(J) = X(IPJ) 120 CONTINUE GO TO 200 C C CASE OF ODD K -- KNOTS BETWEEN DATA POINTS C 150 CONTINUE I = (K-1)/2 - K IP1 = I + 1 JSTRT = K + 1 DO 160 J=JSTRT,N IPJ = I + J T(J) = 0.50E0*( X(IPJ) + X(IPJ+1) ) 160 CONTINUE 200 CONTINUE C RETURN END SUBROUTINE BNDRY(A,BOX,IMX,JMX,IB,JB,NB) C C PURPOSE--XX C C WRITTEN BY--DAVID W. BEHRINGER NOAA/AOML (MIAMI). C AS PART OF NOAA'S CONCX V.3 MARCH 1988. C ORIGINAL VERSION (IN DATAPLOT)--AUGUST 1988. C UPDATED --JANUARY 1989. MORE CHANGES TO STANDARD FORTRAN 77-- C BYTE TO CHARACTER*1, C DO WHILE/END DO (ALAN HECKERT). C UPDATED --JULY 1990. 999.999 TO ANINE C UPDATED --JULY 1990. ( ) AROUND ALL EXPR. ANINE C UPDATED --JULY 1990. MAJOR CHANGES C UPDATED --APRIL 1992. JO TO J0 (ALAN) C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOCP.INC' C C--------------------------------------------------------------------- C CCCCC BYTE BOX(4,MAXIMX,MAXJMX),SBOX AUGUST 1988 CCCCC DIMENSION A(IMX,JMX),IB(*),JB(*) AUGUST 1988 C CCCCC BYTE BOX JANUARY 1989 CCCCC BYTE SBOX JANUARY 1989 CHARACTER*1 BOX CCCCC CHARACTER*1 SBOX C DIMENSION A(MAXIMX,MAXJMX) DIMENSION BOX(4,MAXIMX,MAXJMX) DIMENSION IB(*) DIMENSION JB(*) C C-----START POINT----------------------------------------------------- C CCCCC THE FOLLOWING LINE WAS ADDED JULY 1990 CCCCC AND ALL SUBSEQUENT OCCURRANCES OF 999.999 JULY 1990 CCCCC WERE CHANGED TO ANINE JULY 1990 ANINE=999.999 C DO100I=1,IMX DO110J=1,JMX DO120L=1,4 BOX(L,I,J)='0' 120 CONTINUE 110 CONTINUE 100 CONTINUE DO200I=1,IMX BOX(4,I,1)='2' BOX(2,I,JMX-1)='2' DO210L=1,4 BOX(L,I,JMX)='2' 210 CONTINUE 200 CONTINUE DO300J=1,JMX BOX(1,1,J)='2' BOX(3,IMX-1,J)='2' DO310L=1,4 BOX(L,IMX,J)='2' 310 CONTINUE 300 CONTINUE DO400I=1,IMX DO410J=1,JMX IF (A(I,J).EQ.ANINE) THEN DO420N=1,4 II=MAX0(1,I-N/3) JJ=MAX0(1,J-MOD(N/2,2)) DO430L=1,4 BOX(L,II,JJ)='2' 430 CONTINUE III=MIN0(IMX,MAX0(1,II+1-2*(N/3))) JJJ=MIN0(JMX,MAX0(1,JJ+MAX0(3-2*N,2*N-7))) L=1+2*(N/3) BOX(L,III,JJ)='2' L=MAX0(6-2*N,2*N-4) BOX(L,II,JJJ)='2' 420 CONTINUE END IF 410 CONTINUE 400 CONTINUE I0=0 J0=0 I=0 CCCCC DO WHILE (I0.EQ.0.AND.I.LT.IMX) JANUARY 1989 500 CONTINUE IF(I0.NE.0.OR.I.GE.IMX)GOTO599 I=I+1 J=0 CCCCC DO WHILE (J0.EQ.0.AND.J.LT.JMX) JANUARY 1989 600 CONTINUE CCCCC THE FOLLOWING LINE WAS FIXED APRIL 1992 (ALAN) CCCCC IF(JO.NE.0.OR.J.GE.JMX)GOTO699 IF(J0.NE.0.OR.J.GE.JMX)GOTO699 J=J+1 IF (BOX(3,I,J).EQ.'0') THEN I0=I J0=J END IF GOTO600 699 CONTINUE GOTO500 599 CONTINUE I=I0 J=J0 NB=1 IB(NB)=I JB(NB)=J IFLG=0 IJD=1 CCCCC DO WHILE (IFLG.EQ.0) JANUARY 1989 700 CONTINUE IF(IFLG.NE.0)GOTO799 C IF (IJD.EQ.1) THEN AMM=ANINE AM0=ANINE AMP=ANINE A0M=ANINE A00=ANINE A0P=ANINE APM=ANINE AP0=ANINE APP=ANINE IF(I.GT.1.AND.J.GT.1)AMM=A(I-1,J-1) IF(I.GT.1.AND.J.GT.0)AM0=A(I-1,J) IF(I.GT.1.AND.J.LT.JMX)AMP=A(I-1,J+1) IF(I.GT.0.AND.J.GT.1)A0M=A(I,J-1) IF(I.GT.0.AND.J.GT.0)A00=A(I,J) IF(I.GT.0.AND.J.LT.JMX)A0P=A(I,J+1) IF(I.LT.IMX.AND.J.GT.1)APM=A(I+1,J-1) IF(I.LT.IMX.AND.J.GT.0)AP0=A(I+1,J) IF(I.LT.IMX.AND.J.LT.JMX)APP=A(I+1,J+1) IF ((AM0.NE.ANINE).AND. 1 (((AMM.NE.ANINE)).OR. 2 ((AMP.NE.ANINE)))) THEN I=I-1 IJD=4 ELSE IF ((A0P.NE.ANINE).AND. 1 (((AMP.NE.ANINE)).OR. 2 ((APP.NE.ANINE)))) THEN J=J+1 IJD=1 ELSE IF ((AP0.NE.ANINE).AND. 1 (((APM.NE.ANINE)).OR. 2 ((APM.NE.ANINE)))) THEN I=I+1 IJD=2 END IF C ELSE IF (IJD.EQ.2) THEN AMM=ANINE AM0=ANINE AMP=ANINE A0M=ANINE A00=ANINE A0P=ANINE APM=ANINE AP0=ANINE APP=ANINE IF(I.GT.1.AND.J.GT.1)AMM=A(I-1,J-1) IF(I.GT.1.AND.J.GT.0)AM0=A(I-1,J) IF(I.GT.1.AND.J.LT.JMX)AMP=A(I-1,J+1) IF(I.GT.0.AND.J.GT.1)A0M=A(I,J-1) IF(I.GT.0.AND.J.GT.0)A00=A(I,J) IF(I.GT.0.AND.J.LT.JMX)A0P=A(I,J+1) IF(I.LT.IMX.AND.J.GT.1)APM=A(I+1,J-1) IF(I.LT.IMX.AND.J.GT.0)AP0=A(I+1,J) IF(I.LT.IMX.AND.J.LT.JMX)APP=A(I+1,J+1) IF ((A0P.NE.ANINE).AND. 1 (((AMP.NE.ANINE)).OR. 2 ((APP.NE.ANINE)))) THEN J=J+1 IJD=1 ELSE IF ((AP0.NE.ANINE).AND. 1 (((APM.NE.ANINE)).OR. 2 ((APM.NE.ANINE)))) THEN I=I+1 IJD=2 ELSE IF ((A0M.NE.ANINE).AND. 1 (((AMM.NE.ANINE)).OR. 2 ((APM.NE.ANINE)))) THEN J=J-1 IJD=3 END IF C ELSE IF (IJD.EQ.3) THEN AMM=ANINE AM0=ANINE AMP=ANINE A0M=ANINE A00=ANINE A0P=ANINE APM=ANINE AP0=ANINE APP=ANINE IF(I.GT.1.AND.J.GT.1)AMM=A(I-1,J-1) IF(I.GT.1.AND.J.GT.0)AM0=A(I-1,J) IF(I.GT.1.AND.J.LT.JMX)AMP=A(I-1,J+1) IF(I.GT.0.AND.J.GT.1)A0M=A(I,J-1) IF(I.GT.0.AND.J.GT.0)A00=A(I,J) IF(I.GT.0.AND.J.LT.JMX)A0P=A(I,J+1) IF(I.LT.IMX.AND.J.GT.1)APM=A(I+1,J-1) IF(I.LT.IMX.AND.J.GT.0)AP0=A(I+1,J) IF(I.LT.IMX.AND.J.LT.JMX)APP=A(I+1,J+1) IF ((AP0.NE.ANINE).AND. 1 (((APM.NE.ANINE)).OR. 2 ((APM.NE.ANINE)))) THEN I=I+1 IJD=2 ELSE IF ((A0M.NE.ANINE).AND. 1 (((AMM.NE.ANINE)).OR. 2 ((APM.NE.ANINE)))) THEN J=J-1 IJD=3 ELSE IF ((AM0.NE.ANINE).AND. 1 (((AMM.NE.ANINE)).OR. 2 ((AMP.NE.ANINE)))) THEN I=I-1 IJD=4 END IF C ELSE IF (IJD.EQ.4) THEN AMM=ANINE AM0=ANINE AMP=ANINE A0M=ANINE A00=ANINE A0P=ANINE APM=ANINE AP0=ANINE APP=ANINE IF(I.GT.1.AND.J.GT.1)AMM=A(I-1,J-1) IF(I.GT.1.AND.J.GT.0)AM0=A(I-1,J) IF(I.GT.1.AND.J.LT.JMX)AMP=A(I-1,J+1) IF(I.GT.0.AND.J.GT.1)A0M=A(I,J-1) IF(I.GT.0.AND.J.GT.0)A00=A(I,J) IF(I.GT.0.AND.J.LT.JMX)A0P=A(I,J+1) IF(I.LT.IMX.AND.J.GT.1)APM=A(I+1,J-1) IF(I.LT.IMX.AND.J.GT.0)AP0=A(I+1,J) IF(I.LT.IMX.AND.J.LT.JMX)APP=A(I+1,J+1) IF ((A0M.NE.ANINE).AND. 1 (((AMM.NE.ANINE)).OR. 2 ((APM.NE.ANINE)))) THEN J=J-1 IJD=3 ELSE IF ((AM0.NE.ANINE).AND. 1 (((AMM.NE.ANINE)).OR. 2 ((AMP.NE.ANINE)))) THEN I=I-1 IJD=4 ELSE IF ((A0P.NE.ANINE).AND. 1 (((AMP.NE.ANINE)).OR. 2 ((APP.NE.ANINE)))) THEN J=J+1 IJD=1 END IF C END IF IBNB=I JBNB=J IF (NB.GT.1) THEN IF (IBNB.NE.IB(NB-1).AND.JBNB.NE.JB(NB-1)) NB=NB+1 ELSE NB=NB+1 END IF IB(NB)=I JB(NB)=J IF (IB(NB).EQ.IB(1).AND.JB(NB).EQ.JB(1)) IFLG=1 GOTO700 799 CONTINUE RETURN END SUBROUTINE BNFAC(W,NROWW,NROW,NBANDL,NBANDU,IFLAG) C***BEGIN PROLOGUE BNFAC C***REFER TO BINT4,BINTK C C BNFAC is the BANFAC routine from C * A Practical Guide to Splines * by C. de Boor C C Returns in W the lu-factorization (without pivoting) of the banded C matrix A of order NROW with (NBANDL + 1 + NBANDU) bands or diag- C onals in the work array W . C C ***** I N P U T ****** C W.....Work array of size (NROWW,NROW) containing the interesting C part of a banded matrix A , with the diagonals or bands of A C stored in the rows of W , while columns of A correspond to C columns of W . This is the storage mode used in LINPACK and C results in efficient innermost loops. C Explicitly, A has NBANDL bands below the diagonal C + 1 (main) diagonal C + NBANDU bands above the diagonal C and thus, with MIDDLE = NBANDU + 1, C A(I+J,J) is in W(I+MIDDLE,J) for I=-NBANDU,...,NBANDL C J=1,...,NROW . C For example, the interesting entries of A (1,2)-banded matrix C of order 9 would appear in the first 1+1+2 = 4 rows of W C as follows. C 13 24 35 46 57 68 79 C 12 23 34 45 56 67 78 89 C 11 22 33 44 55 66 77 88 99 C 21 32 43 54 65 76 87 98 C C All other entries of W not identified in this way with an en- C try of A are never referenced . C NROWW.....Row dimension of the work array W . C must be .GE. NBANDL + 1 + NBANDU . C NBANDL.....Number of bands of A below the main diagonal C NBANDU.....Number of bands of A above the main diagonal . C C ***** O U T P U T ****** C IFLAG.....Integer indicating success( = 1) or failure ( = 2) . C If IFLAG = 1, then C W.....contains the LU-factorization of A into a unit lower triangu- C lar matrix L and an upper triangular matrix U (both banded) C and stored in customary fashion over the corresponding entries C of A . This makes it possible to solve any particular linear C system A*X = B for X by A C CALL BNSLV ( W, NROWW, NROW, NBANDL, NBANDU, B ) C with the solution X contained in B on return . C If IFLAG = 2, then C one of NROW-1, NBANDL,NBANDU failed to be nonnegative, or else C one of the potential pivots was found to be zero indicating C that A does not have an LU-factorization. This implies that C A is singular in case it is totally positive . C C ***** M E T H O D ****** C Gauss elimination W I T H O U T pivoting is used. The routine is C intended for use with matrices A which do not require row inter- C changes during factorization, especially for the T O T A L L Y C P O S I T I V E matrices which occur in spline calculations. C The routine should not be used for an arbitrary banded matrix. C***ROUTINES CALLED (NONE) C***END PROLOGUE BNFAC C INTEGER IFLAG, NBANDL, NBANDU, NROW, NROWW, I, IPK, J, JMAX, K, 1 KMAX, MIDDLE, MIDMK, NROWM1 REAL W(NROWW,NROW), FACTOR, PIVOT C C***FIRST EXECUTABLE STATEMENT BNFAC IFLAG = 1 MIDDLE = NBANDU + 1 C W(MIDDLE,.) CONTAINS THE MAIN DIAGONAL OF A . NROWM1 = NROW - 1 IF (NROWM1) 120, 110, 10 10 IF (NBANDL.GT.0) GO TO 30 C A IS UPPER TRIANGULAR. CHECK THAT DIAGONAL IS NONZERO . DO 20 I=1,NROWM1 IF (W(MIDDLE,I).EQ.0.0E0) GO TO 120 20 CONTINUE GO TO 110 30 IF (NBANDU.GT.0) GO TO 60 C A IS LOWER TRIANGULAR. CHECK THAT DIAGONAL IS NONZERO AND C DIVIDE EACH COLUMN BY ITS DIAGONAL . DO 50 I=1,NROWM1 PIVOT = W(MIDDLE,I) IF (PIVOT.EQ.0.0E0) GO TO 120 JMAX = MIN0(NBANDL,NROW-I) DO 40 J=1,JMAX W(MIDDLE+J,I) = W(MIDDLE+J,I)/PIVOT 40 CONTINUE 50 CONTINUE RETURN C C A IS NOT JUST A TRIANGULAR MATRIX. CONSTRUCT LU FACTORIZATION 60 DO 100 I=1,NROWM1 C W(MIDDLE,I) IS PIVOT FOR I-TH STEP . PIVOT = W(MIDDLE,I) IF (PIVOT.EQ.0.0E0) GO TO 120 C JMAX IS THE NUMBER OF (NONZERO) ENTRIES IN COLUMN I C BELOW THE DIAGONAL . JMAX = MIN0(NBANDL,NROW-I) C DIVIDE EACH ENTRY IN COLUMN I BELOW DIAGONAL BY PIVOT . DO 70 J=1,JMAX W(MIDDLE+J,I) = W(MIDDLE+J,I)/PIVOT 70 CONTINUE C KMAX IS THE NUMBER OF (NONZERO) ENTRIES IN ROW I TO C THE RIGHT OF THE DIAGONAL . KMAX = MIN0(NBANDU,NROW-I) C SUBTRACT A(I,I+K)*(I-TH COLUMN) FROM (I+K)-TH COLUMN C (BELOW ROW I ) . DO 90 K=1,KMAX IPK = I + K MIDMK = MIDDLE - K FACTOR = W(MIDMK,IPK) DO 80 J=1,JMAX W(MIDMK+J,IPK) = W(MIDMK+J,IPK) - W(MIDDLE+J,I)*FACTOR 80 CONTINUE 90 CONTINUE 100 CONTINUE C CHECK THE LAST DIAGONAL ENTRY . 110 IF (W(MIDDLE,NROW).NE.0.0E0) RETURN 120 IFLAG = 2 RETURN END SUBROUTINE BNOCDF(DX,DALPHA,DBETA,DCDF) C C PURPOSE --COMPUTE THE BETA-NORMAL CDF FUNCTION C THIS CDF FUNCTION IS DEFINED AS: C F(X;A,B) = (1/BETA(A,B)*INTERGRAL[0 TO G(X)] C [W**(A-1)*(1-W)**(B-1)dw C A, B > 0 C WITH G(X) DENOTING A FUNCTION. IN THIS CASE, C WE TAKE G(X) TO BE THE NORMAL CDF FUNCTION. C THAT IS, THIS IS ESSENTIALLY A BETA CDF, BUT C WITH THE UPPER LIMIT OF INTEGRATION REPLACED WITH C THE NORMAL CDF VALUE OF X. C REFERENCE --"HANDBOOK OF BETA DISTRIBUTION AND ITS APPLICATIONS", C EDITED BY ARJUN GUPTA AND SARALEES NADARAJAH, C MARCEL DEKKER INC., 2004, PP. 146-152. C --"BETA-NORMAL DISTRIBUTION AND ITS APPLICATIONS", C EUGENE, LEE, AND FAMOYE. COMMUNICATIONS IN C STATISTICS-THEORY AND METHODS, 2002, 31, PP. 497-512. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2006/3 C ORIGINAL VERSION--MARCH 2006. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C DOUBLE PRECISION DCDF DOUBLE PRECISION DNOCDF DOUBLE PRECISION DALPHA DOUBLE PRECISION DBETA DOUBLE PRECISION DX DOUBLE PRECISION DBETAI C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IF(DALPHA.LE.0.0D0)THEN WRITE(ICOUT,101) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,103)DALPHA CALL DPWRST('XXX','BUG ') GOTO9999 ELSEIF(DBETA.LE.0.0D0)THEN WRITE(ICOUT,102) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,103)DBETA CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF 101 FORMAT('***** ERROR--FOR BNOCDF, THE ALPHA SHAPE PARAMETER IS ', 1 'NON-POSITIVE.') 102 FORMAT('***** ERROR--FOR BNOCDF, THE BETA SHAPE PARAMETER IS ', 1 'NON-POSITIVE.') 103 FORMAT('***** THE VALUE IS ',G15.7) C CALL NODCDF(DX,DNOCDF) DCDF=DBETAI(DNOCDF,DALPHA,DBETA) C 9999 CONTINUE RETURN END DOUBLE PRECISION FUNCTION BNOFU2(DX) C C PURPOSE--BNOPPF CALLS DFZERO TO FIND A ROOT FOR THE PERCENT C POINT FUNCTION. BNOFU2 IS THE FUNCTION FOR WHICH C THE ZERO IS FOUND. IT IS: C P - BNOCDF(X,ALPHA,BETA) C WHERE P IS THE DESIRED PERCENT POINT. C INPUT ARGUMENTS--X = THE DOUBLE PRECISION VALUE AT C WHICH THE CUMULATIVE DISTRIBUTION C FUNCTION IS TO BE EVALUATED. C OUTPUT--THE DOUBLE PRECISION CUMULATIVE DISTRIBUTION C FUNCTION VALUE BNOFU2. C PRINTING--NONE. C RESTRICTIONS--NONE. C OTHER DATAPAC SUBROUTINES NEEDED--BNOCDF. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCE --"HANDBOOK OF BETA DISTRIBUTION AND ITS APPLICATIONS", C EDITED BY ARJUN GUPTA AND SARALEES NADARAJAH, C MARCEL DEKKER INC., 2004, PP. 146-152. C --"BETA-NORMAL DISTRIBUTION AND ITS APPLICATIONS", C EUGENE, LEE, AND FAMOYE. COMMUNICATIONS IN C STATISTICS-THEORY AND METHODS, 2002, 31, PP. 497-512. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATION INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2006.3 C ORIGINAL VERSION--MARCH 2006. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DX DOUBLE PRECISION DCDF C DOUBLE PRECISION DP DOUBLE PRECISION DALPHA DOUBLE PRECISION DBETA COMMON/BNOCOM/DP,DALPHA,DBETA C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C CALL BNOCDF(DX,DALPHA,DBETA,DCDF) BNOFU2=DP - DCDF C RETURN END SUBROUTINE BNOPDF(DX,DALPHA,DBETA,DPDF) C C PURPOSE --COMPUTE THE BETA-NORMAL PDF FUNCTION C THIS PDF FUNCTION IS DEFINED AS: C f(X;A,B) = (1/BETA(A,B)*NORCDF(X)**(A-1)* C (1-NORCDF(X))**(B-1)*NORPDF(X) C A, B > 0 C WITH A, B, AND BETA DENOTING THE SHAPE PARAMETERS C ALPHA AND BETA AND THE BETA FUNCTION, RESPECTIVELY. C REFERENCE --"HANDBOOK OF BETA DISTRIBUTION AND ITS APPLICATIONS", C EDITED BY ARJUN GUPTA AND SARALEES NADARAJAH, C MARCEL DEKKER INC., 2004, PP. 146-152. C --"BETA-NORMAL DISTRIBUTION AND ITS APPLICATIONS", C EUGENE, LEE, AND FAMOYE. COMMUNICATIONS IN C STATISTICS-THEORY AND METHODS, 2002, 31, PP. 497-512. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2006/3 C ORIGINAL VERSION--MARCH 2006. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C DOUBLE PRECISION DX DOUBLE PRECISION DPDF DOUBLE PRECISION DNOCDF DOUBLE PRECISION DNOCD2 DOUBLE PRECISION DNOPDF DOUBLE PRECISION DALPHA DOUBLE PRECISION DBETA DOUBLE PRECISION DLBETA DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 DOUBLE PRECISION DTERM3 DOUBLE PRECISION DTERM4 DOUBLE PRECISION DEPS C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C DATA DEPS/0.1D-12/ C C-----START POINT----------------------------------------------------- C IF(DALPHA.LE.0.0D0)THEN WRITE(ICOUT,101) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,103)DALPHA CALL DPWRST('XXX','BUG ') GOTO9999 ELSEIF(DBETA.LE.0.0D0)THEN WRITE(ICOUT,102) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,103)DBETA CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF 101 FORMAT('***** ERROR--FOR BNOPDF, THE ALPHA SHAPE PARAMETER IS ', 1 'NON-POSITIVE.') 102 FORMAT('***** ERROR--FOR BNOPDF, THE BETA SHAPE PARAMETER IS ', 1 'NON-POSITIVE.') 103 FORMAT('***** THE VALUE IS ',G15.7) C CALL NODPDF(DX,DNOPDF) CALL NODCDF(DX,DNOCDF) CALL NODCDF(-DX,DNOCD2) C C NOTE: PDF EFFECTIVELY ZERO IMPLIES BNOPDF ALSO EFFECTIVELY ZERO. C ALSO NEED TO CHECK FOR CDF = 0 OR 1 (CDF=1 PRESENTS THE C MORE SERIOUS PROBLEM IN PRACTICE SINCE NODCDF SINCE THE C ROUNDING TO 1 OCCURS AT A MUCH SMALLER ABSOLUTE VALUE THAN C DOES ROUNDING TO 0). SOLUTION IS TO COMPUTE THE LOG OF A C VERY SMALL VALUE (SET BY DPES) FOR THAT TERM. C IF(DNOPDF.LE.0.0D0)THEN DPDF=0.0D0 ELSEIF(DNOCDF.LE.0.0D0)THEN DTERM1=DLBETA(DALPHA,DBETA) DTERM2=(DALPHA-1.0D0)*DLOG(DEPS) DTERM3=0.0D0 DPDF=DTERM2 + DTERM3 + DLOG(DNOPDF) - DTERM1 IF(DPDF.LE.-500.0D0)THEN DPDF=0.0D0 ELSE DPDF=DEXP(DPDF) ENDIF ELSEIF(DNOCDF.GE.1.0D0)THEN DTERM1=DLBETA(DALPHA,DBETA) DTERM2=(DALPHA-1.0D0)*DLOG(DNOCDF) DTERM3=(DBETA-1.0D0)*DLOG(DNOCD2) DPDF=DTERM2 + DTERM3 + DLOG(DNOPDF) - DTERM1 IF(DPDF.LE.-500.0D0)THEN DPDF=0.0D0 ELSE DPDF=DEXP(DPDF) ENDIF ELSE DTERM1=DLBETA(DALPHA,DBETA) DTERM2=(DALPHA-1.0D0)*DLOG(DNOCDF) DTERM3=(DBETA-1.0D0)*DLOG(DNOCD2) DPDF=DTERM2 + DTERM3 + DLOG(DNOPDF) - DTERM1 IF(DPDF.LE.-500.0D0)THEN DPDF=0.0D0 ELSE DPDF=DEXP(DPDF) ENDIF ENDIF C 9999 CONTINUE RETURN END SUBROUTINE BNOPPF(DP,DALPHA,DBETA,DPPF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT C FUNCTION VALUE FOR THE BETA-NORMAL DISTRIBUTION C WITH SHAPE PARAMETERS ALPHA AND BETA. C THIS DISTRIBUTION IS DEFINED FOR REAL X AND THE C PERCENT POINT FUNCTION IS COMPUTED BY C NUMERICALLY INVERTING THE CDF FUNCTION. C INPUT ARGUMENTS--DP = THE DOUBLE PRECISION VALUE AT C WHICH THE PERCENT POINT C FUNCTION IS TO BE EVALUATED. C --DALPHA = THE FIRST SHAPE PARAMETER C --DBETA = THE SECOND SHAPE PARAMETER C OUTPUT ARGUMENTS--DPPF = THE DOUBLE PRECISION CUMULATIVE C DISTRIBUTION FUNCTION VALUE. C OUTPUT--THE DOUBLE PRECISION PERCENT POINT FUNCTION VALUE DPPF. C PRINTING--NONE. C RESTRICTIONS--NONE. C OTHER DATAPAC SUBROUTINES NEEDED--DFZERO. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCE --"HANDBOOK OF BETA DISTRIBUTION AND ITS APPLICATIONS", C EDITED BY ARJUN GUPTA AND SARALEES NADARAJAH, C MARCEL DEKKER INC., 2004, PP. 146-152. C --"BETA-NORMAL DISTRIBUTION AND ITS APPLICATIONS", C EUGENE, LEE, AND FAMOYE. COMMUNICATIONS IN C STATISTICS-THEORY AND METHODS, 2002, 31, PP. 497-512. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATION INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C ORIGINAL VERSION--MARCH 2006. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DP DOUBLE PRECISION DALPHA DOUBLE PRECISION DBETA DOUBLE PRECISION DPPF C DOUBLE PRECISION BNOFU2 EXTERNAL BNOFU2 C DOUBLE PRECISION DP2 DOUBLE PRECISION DALPH2 DOUBLE PRECISION DBETA2 COMMON/BNOCOM/DP2,DALPH2,DBETA2 C DOUBLE PRECISION XLOW DOUBLE PRECISION XLOW2 DOUBLE PRECISION XUP DOUBLE PRECISION XUP2 DOUBLE PRECISION PTEMPL DOUBLE PRECISION PTEMPU DOUBLE PRECISION AE DOUBLE PRECISION RE C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,ALPHAMBPC,ALPHAMCPW,ALPHAMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C DPPF=0.0D0 IF(DALPHA.LE.0.0D0)THEN WRITE(ICOUT,101) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,102) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,104)DALPHA CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF IF(DBETA.LE.0.0D0)THEN WRITE(ICOUT,103) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,102) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,104)DBETA CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF 101 FORMAT('***** ERROR--THE FIRST SHAPE PARAMETER, ALPHA, TO THE') 102 FORMAT(' BNOPPF ROUTINE IS NON-POSITIVE.') 103 FORMAT('***** ERROR--THE SECOND SHAPE PARAMETER, BETA, TO THE') 104 FORMAT(' THE VALUE OF THE ARGUMENT IS ',E15.7,' ******') C IF(DP.LE.0.0D0.OR.DP.GE.1.0D0)THEN WRITE(ICOUT,61) 61 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT ', 1 'TO THE BNOPPF SUBROUTINE ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,62) 62 FORMAT(' IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,63)DP 63 FORMAT(' VALUE OF ARGUMENT = ',G15.7) CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF C C STEP 1: FIND BRACKETING INTERVAL. START WITH (-5,5) AND C INCREMENT UNITL A BRACKETING INTERVAL IS FOUND. C MAXIT=1000 XLOW2=-5.0D0 XUP2=5.0D0 200 CONTINUE CALL BNOCDF(XLOW2,DALPHA,DBETA,PTEMPL) CALL BNOCDF(XUP2,DALPHA,DBETA,PTEMPU) IF(PTEMPL.LT.DP .AND. PTEMPU.GT.DP)THEN XUP=XUP2 XLOW=XLOW2 GOTO300 ELSEIF(PTEMPL.LT.DP .AND. PTEMPU.LT.DP)THEN MAXIT=MAXIT+1 XUP2=2.0D0*XUP2 IF(MAXIT.LE.MAXIT)GOTO200 ELSEIF(PTEMPL.GT.DP .AND. PTEMPU.GT.DP)THEN MAXIT=MAXIT+1 XLOW2=2.0D0*XLOW2 IF(MAXIT.LE.MAXIT)GOTO200 ENDIF C WRITE(ICOUT,201) 201 FORMAT('***** ERROR FROM BNOPPF--UNABLE TO FIND A ', 1 'BRACKETING INTERVAL') CALL DPWRST('XXX','BUG ') GOTO9000 C 300 CONTINUE AE=1.0D-8 RE=1.0D-8 DP2=DP DALPH2=DALPHA DBETA2=DBETA CALL DFZERO(BNOFU2,XLOW,XUP,XUP,RE,AE,IFLAG) C DPPF=XLOW C IF(IFLAG.EQ.2)THEN C C NOTE: SUPPRESS THIS MESSAGE FOR NOW. CCCCC WRITE(ICOUT,999) 999 FORMAT(1X) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,121) CC111 FORMAT('***** WARNING FROM BNOPPF--') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,113) CC113 FORMAT(' PPF VALUE MAY NOT BE COMPUTED TO DESIRED ', CCCCC1 'TOLERANCE.') CCCCC CALL DPWRST('XXX','BUG ') ELSEIF(IFLAG.EQ.3)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,121) 121 FORMAT('***** WARNING FROM BNOPPF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,123) 123 FORMAT(' PPF VALUE MAY BE NEAR A SINGULAR POINT.') CALL DPWRST('XXX','BUG ') ELSEIF(IFLAG.EQ.4)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,131) 131 FORMAT('***** ERROR FROM BNOPPF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,133) 133 FORMAT(' APPROPRIATE BRACKETING INTERVAL NOT FOUND.') CALL DPWRST('XXX','BUG ') ELSEIF(IFLAG.EQ.5)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,121) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,143) 143 FORMAT(' MAXIMUM ITERATIONS EXCEEDED.') CALL DPWRST('XXX','BUG ') ENDIF C 9000 CONTINUE RETURN END SUBROUTINE BNORAN(N,ALPHA,BETA,ISEED,X) C C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N C FROM THE BETA-NORMAL DISTRIBUTION WITH SHAPE C PARAMETERS ALPHA AND BETA. THIS DISTRIBUTION IS C DEFINED FOR ALL X AND HAS THE PROBABILITY DENSITY C FUNCTION C f(X;A,B) = (1/BETA(A,B)*NORCDF(X)**(A-1)* C (1-NORCDF(X))**(B-1)*NORPDF(X) C A, B > 0 C WITH A, B, AND BETA DENOTING THE SHAPE PARAMETERS C ALPHA AND BETA AND THE BETA FUNCTION, RESPECTIVELY. C C INPUT ARGUMENTS--N = THE DESIRED INTEGER NUMBER C OF RANDOM NUMBERS TO BE C GENERATED. C --ALPHA = THE FIRST SHAPE PARAMETER FOR THE C BETA-NORMAL DISTRIBUTION C --BETA = THE SECOND SHAPE PARAMETER FOR THE C BETA-NORMAL DISTRIBUTION C OUTPUT ARGUMENTS--X = A SINGLE PRECISION VECTOR C (OF DIMENSION AT LEAST N) C INTO WHICH THE GENERATED C RANDOM SAMPLE WILL BE PLACED. C OUTPUT--A RANDOM SAMPLE OF SIZE N FROM THE BETA-NORMAL C DISTRIBUTION WITH SHAPE PARAMETERS ALPHA AND BETA. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C OTHER DATAPAC SUBROUTINES NEEDED--UNIRAN, NBOPPF. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCE --"HANDBOOK OF BETA DISTRIBUTION AND ITS APPLICATIONS", C EDITED BY ARJUN GUPTA AND SARALEES NADARAJAH, C MARCEL DEKKER INC., 2004, PP. 146-152. C --"BETA-NORMAL DISTRIBUTION AND ITS APPLICATIONS", C EUGENE, LEE, AND FAMOYE. COMMUNICATIONS IN C STATISTICS-THEORY AND METHODS, 2002, 31, PP. 497-512. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATION INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2006.3 C ORIGINAL VERSION--MARCH 2006. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DPPF DIMENSION X(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----DATA STATEMENTS------------------------------------------------- C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(N.LT.1)THEN WRITE(ICOUT,5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,6) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)N CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF C 5 FORMAT('***** ERROR--FOR THE BETA-NORMAL DISTRIBUTION, ', 1 'THE REQUESTED') 6 FORMAT(' NUMBER OF RANDOM NUMBERS WAS NON-POSITIVE.') 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,'.') IF(ALPHA.LE.0.0)THEN WRITE(ICOUT,7) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,17) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,48)ALPHA CALL DPWRST('XXX','WRIT') GOTO9000 ENDIF 7 FORMAT('***** ERROR: VALUE OF FIRST SHAPE PARAMETER (ALPHA)', 1 ' FOR BETA-NORMAL') 17 FORMAT(' RANDOM NUMBERS IS NON-POSITIVE.') IF(BETA.LE.0.0)THEN WRITE(ICOUT,8) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,18) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,48)BETA CALL DPWRST('XXX','WRIT') GOTO9000 ENDIF 8 FORMAT('***** ERROR: VALUE OF SECOND SHAPE PARAMETER (BETA)', 1 ' FOR BETA-NORMAL') 18 FORMAT(' RANDOM NUMBERS IS NON-POSITIVE.') 48 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7,'.') C C COMPUTE THE BETA-NORMAL RANDOM NUMBERS USING THE C PERCENT POINT TRANSFORMATION OF UNIFORM RANDOM NUMBERS. C CALL UNIRAN(N,ISEED,X) NTEMP=1 DO100I=1,N ATEMP=X(I) CALL BNOPPF(DBLE(ATEMP),DBLE(ALPHA),DBLE(BETA),DPPF) X(I)=REAL(DPPF) 100 CONTINUE C 9000 CONTINUE RETURN END SUBROUTINE BNSLV(W,NROWW,NROW,NBANDL,NBANDU,B) C***BEGIN PROLOGUE BNSLV C***REFER TO BINT4,BINTK C C BNSLV is the BANSLV routine from C * A Practical Guide to Splines * by C. de Boor C C Companion routine to BNFAC . It returns the solution X of the C linear system A*X = B in place of B , given the LU-factorization C for A in the work array W from BNFAC. C C ***** I N P U T ****** C W, NROWW,NROW,NBANDL,NBANDU.....describe the LU-factorization of a C banded matrix A of order NROW as constructed in BNFAC . C For details, see BNFAC . C B.....Right side of the system to be solved . C C ***** O U T P U T ****** C B.....Contains the solution X , of order NROW . C C ***** M E T H O D ****** C (With A = L*U, as stored in W,) the unit lower triangular system C L(U*X) = B is solved for Y = U*X, and Y stored in B . Then the C upper triangular system U*X = Y is solved for X . The calcul- C ations are so arranged that the innermost loops stay within columns. C***ROUTINES CALLED (NONE) C***END PROLOGUE BNSLV C INTEGER NBANDL, NBANDU, NROW, NROWW, I, J, JMAX, MIDDLE, NROWM1 REAL W(NROWW,NROW), B(NROW) C***FIRST EXECUTABLE STATEMENT BNSLV MIDDLE = NBANDU + 1 IF (NROW.EQ.1) GO TO 80 NROWM1 = NROW - 1 IF (NBANDL.EQ.0) GO TO 30 C FORWARD PASS C FOR I=1,2,...,NROW-1, SUBTRACT RIGHT SIDE(I)*(I-TH COLUMN C OF L ) FROM RIGHT SIDE (BELOW I-TH ROW) . DO 20 I=1,NROWM1 JMAX = MIN0(NBANDL,NROW-I) DO 10 J=1,JMAX B(I+J) = B(I+J) - B(I)*W(MIDDLE+J,I) 10 CONTINUE 20 CONTINUE C BACKWARD PASS C FOR I=NROW,NROW-1,...,1, DIVIDE RIGHT SIDE(I) BY I-TH DIAG- C ONAL ENTRY OF U, THEN SUBTRACT RIGHT SIDE(I)*(I-TH COLUMN C OF U) FROM RIGHT SIDE (ABOVE I-TH ROW). 30 IF (NBANDU.GT.0) GO TO 50 C A IS LOWER TRIANGULAR . DO 40 I=1,NROW B(I) = B(I)/W(1,I) 40 CONTINUE RETURN 50 I = NROW 60 B(I) = B(I)/W(MIDDLE,I) JMAX = MIN0(NBANDU,I-1) DO 70 J=1,JMAX B(I-J) = B(I-J) - B(I)*W(MIDDLE-J,I) 70 CONTINUE I = I - 1 IF (I.GT.1) GO TO 60 80 B(1) = B(1)/W(MIDDLE,1) RETURN END SUBROUTINE BOOTSS(Y1,Y2,N1,IWRITE, 1Y3,N3,IBUGA3,ISUBRO,IERROR) C C PURPOSE--CONSTRUCT A BOOTSTRAP SAMPLE C OF THE DATA IN Y1(.) BASED ON THE INDICES IN Y2(.). C C INPUT ARGUMENTS--Y1 = ORIGINAL SAMPLE C --Y2 = BOOTSTRAP INDEX C OUTPUT ARGUMENTS--Y3 = BOOTSTRAP SAMPLE C C NOTE--IT IS PERMISSIBLE TO HAVE THE OUTPUT VECTOR Y3(.) C BEING IDENTICAL TO EITHER OF THE INPUT VECTORS Y1(.) OR Y2(.) C NOTE--IF AN ELEMENT OF THE INPUT INDEX (Y2) IS SMALLER THAN 1 C OR LARGER THAN N1, THEN THIS WILL BE INTERPRETED AS C A NON-OPERATION--THIS WILL ALLOW ONE TO FORM JACKNIFE C SAMPLES BY SIMPLY SETTING SOME INDEX ELEMENT TO, SAY, 0. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-921-3651 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--89/2 C ORIGINAL VERSION--JANUARY 1987. C UPDATED --JUNE 1990. TEMPORARY ARRAYS TO GARBAGE COMMON C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IWRITE CHARACTER*4 IBUGA3 CHARACTER*4 ISUBRO CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C INCLUDE 'DPCOPA.INC' C DIMENSION Y1(*) DIMENSION Y2(*) DIMENSION Y3(*) C DIMENSION TEMPY1(MAXOBV) DIMENSION TEMPY2(MAXOBV) CCCCC FOLLOWING LINES ADDED JUNE, 1990 INCLUDE 'DPCOZ2.INC' EQUIVALENCE (G2RBAG(IGAR44),TEMPY1(1)) EQUIVALENCE (G2RBAG(IGAR45),TEMPY2(1)) CCCCC END CHANGE C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='BOOT' ISUBN2='SS ' C IERROR='NO' C IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'OTSS')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF BOOTSS--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA3,ISUBRO,IWRITE 52 FORMAT('IBUGA3,ISUBRO,IWRITE = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)N1 53 FORMAT('N1 = ',I8) CALL DPWRST('XXX','BUG ') DO55I=1,N1 WRITE(ICOUT,56)I,Y1(I),Y2(I) 56 FORMAT('I,Y1(I),Y2(I) = ',I8,2E13.5) CALL DPWRST('XXX','BUG ') 55 CONTINUE 90 CONTINUE C C ************************************* C ** CONSTRUCT A BOOTSTRAP SAMPLE ** C ************************************* C C ******************************************** C ** STEP 11-- ** C ** CHECK NUMBER OF INPUT OBSERVATIONS. ** C ******************************************** C IF(N1.LT.1)GOTO1100 GOTO1190 C 1100 CONTINUE IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1151) 1151 FORMAT('***** ERROR IN BOOTSS--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1152) 1152 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1153) 1153 FORMAT(' IN THE VARIABLE FOR WHICH') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1154) 1154 FORMAT(' THE BOOTSTRAP SAMPLE IS TO BE ', 1'CONSTUCTED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1155) 1155 FORMAT(' MUST BE 1 OR LARGER.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1156) 1156 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1157)N1 1157 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8, 1'.') CALL DPWRST('XXX','BUG ') GOTO9000 C 1190 CONTINUE C DO1200I=1,N1 TEMPY1(I)=Y1(I) TEMPY2(I)=Y2(I) 1200 CONTINUE C J=0 DO1300I=1,N1 INDEX=TEMPY2(I)+0.1 IF(INDEX.LT.1.OR.INDEX.GT.N1)GOTO1300 J=J+1 Y3(J)=TEMPY1(INDEX) 1300 CONTINUE N3=J C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C 9000 CONTINUE C IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'PARI')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF BOOTSS--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGA3,ISUBRO,IWRITE 9012 FORMAT('IBUGA3,ISUBRO,IWRITE = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)IERROR 9013 FORMAT('IERROR = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9017)N1,N3 9017 FORMAT('N1,N3 = ',2I8) CALL DPWRST('XXX','BUG ') IF(N1.LE.0)GOTO9023 DO9021I=1,N1 WRITE(ICOUT,9022)I,Y1(I),Y2(I) 9022 FORMAT('I,Y1(I),Y2(I) = ',I8,2E13.5) CALL DPWRST('XXX','BUG ') 9021 CONTINUE 9023 CONTINUE IF(N3.LE.0)GOTO9033 DO9031I=1,N3 WRITE(ICOUT,9032)I,Y3(I) 9032 FORMAT('I,Y3(I) = ',I8,E13.5) CALL DPWRST('XXX','BUG ') 9031 CONTINUE 9033 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE BPADJU(IND1,IND2,L,NRANK,NCIRQ,KOUNT, CCCCC RENAME TO HAVE 6-CHARACTER NAME CCCCC SUBROUTINE BP_ADJUST(IND1,IND2,L,NRANK,NCIRQ,KOUNT, + ALPHA,ANGLE,K,N,M,MAXNUM,KAND1,KAND2,D,X,Y) C C Updates NCIRQ and NRANK, detects the special k-dividers and stores C their angles and the constant terms of their equations. C INTEGER NCIRQ(N),NRANK(N),IND1(M),IND2(M) INTEGER KAND1(MAXNUM),KAND2(MAXNUM) INTEGER KOUNT,K,L,N,IV,IV1,IV2,D1,D2 double precision X(N),Y(N),ANGLE(M),D(M) double precision ALPHA(MAXNUM),DUM,PI,PI2 PI=DACOS(DBLE(-1.0)) PI2=PI/2.0 D1=IND1(L) IV1=NRANK(D1) D2=IND2(L) IV2=NRANK(D2) IV=NCIRQ(IV1) NCIRQ(IV1)=NCIRQ(IV2) NCIRQ(IV2)=IV IV=IV1 NRANK(D1)=IV2 NRANK(D2)=IV IF (((IV1.EQ.K).AND.(IV2.EQ.(K+1))) + .OR.((IV2.EQ.K).AND.(IV1.EQ.(K+1))) + .OR.((IV1.EQ.(N-K)).AND.(IV2.EQ.(N-K+1))) + .OR.((IV2.EQ.(N-K)).AND.(IV1.EQ.(N-K+1)))) THEN IF (ANGLE(L).LT.PI2) THEN DUM=ANGLE(L)+PI2 ELSE DUM=ANGLE(L)-PI2 ENDIF IF (((IV1.EQ.K).AND.(IV2.EQ.(K+1))) + .OR.((IV2.EQ.K).AND.(IV1.EQ.(K+1)))) THEN IF (DUM.LE.PI2) THEN ALPHA(KOUNT)=ANGLE(L)+PI ELSE ALPHA(KOUNT)=ANGLE(L) ENDIF ENDIF IF (((IV1.EQ.(N-K)).AND.(IV2.EQ.(N-K+1))) + .OR.((IV2.EQ.(N-K)).AND.(IV1.EQ.(N-K+1)))) THEN IF (DUM.LE.PI2) THEN ALPHA(KOUNT)=ANGLE(L) ELSE ALPHA(KOUNT)=ANGLE(L)+PI ENDIF ENDIF KAND1(KOUNT)=IND1(L) KAND2(KOUNT)=IND2(L) D(KOUNT)=DSIN(ALPHA(KOUNT))*X(IND1(L)) + -DCOS(ALPHA(KOUNT))*Y(IND1(L)) KOUNT=KOUNT+1 ENDIF RETURN END SUBROUTINE BPDEPT(U,V,N,X,Y,BETA,F,DPF,JLV,JRV,HDEP) CCCCC RENAME TO 6-CHARACTER NAME CCCCC SUBROUTINE BP_DEPTH(U,V,N,X,Y,BETA,F,DPF,JLV,JRV,HDEP) C C Computes the halfspace depth of a point. This subroutine was described C in: Rousseeuw, P.J. and Ruts, I. (1996). Algorithm AS 307: Bivariate C location depth. Applied Statistics (JRSS-C) 45, 516-526. C double precision U,V,BETA(N),X(N),Y(N),DPF(N) double precision P,P2,EPSI,D,XU,YU,ANG,ALPHK,BETAK INTEGER F(N),GI,HDEP integer JLV(N),JRV(N) NUMH=0 HDEP=0 IF (N.LT.1) RETURN P=DACOS(DBLE(-1.0)) P2=P*2.0 EPSI=0.000001 NZ=0 C C Construct the array BETA. C DO 10 I=1,N D=DSQRT((X(I)-U)*(X(I)-U)+(Y(I)-V)*(Y(I)-V)) IF (D.LE.EPSI) THEN NZ=NZ+1 ELSE XU=(X(I)-U)/D YU=(Y(I)-V)/D IF (DABS(XU).GT.DABS(YU)) THEN IF (X(I).GE.U) THEN BETA(I-NZ)=DASIN(YU) IF(BETA(I-NZ).LT.0.0) THEN BETA(I-NZ)=P2+BETA(I-NZ) ENDIF ELSE BETA(I-NZ)=P-DASIN(YU) ENDIF ELSE IF (Y(I).GE.V) THEN BETA(I-NZ)=DACOS(XU) ELSE BETA(I-NZ)=P2-DACOS(XU) ENDIF ENDIF IF (BETA(I-NZ).GE.(P2-EPSI)) BETA(I-NZ)=0.0 ENDIF 10 CONTINUE NN=N-NZ IF (NN.LE.1) GOTO 60 C C Sort the array BETA. C DO 15 I=1,NN DPF(I)=DBLE(F(I)) 15 CONTINUE CALL BPSORT(BETA,F,F,DPF,NN,JLV,JRV) C C Check whether Z=(U,V) lies outside the data cloud. C ANG=BETA(1)-BETA(NN)+P2 DO 20 I=2,NN ANG=DMAX1(ANG,(BETA(I)-BETA(I-1))) 20 CONTINUE IF (ANG.GT.(P+EPSI)) GOTO 60 C C Make smallest BETA equal to zero, C and compute NU = number of BETA < PI. C ANG=BETA(1) NU=0 DO 30 I=1,NN BETA(I)=BETA(I)-ANG IF (BETA(I).LT.(P-EPSI)) NU=NU+1 30 CONTINUE IF (NU.GE.NN) GOTO 60 C C Mergesort the BETA with their antipodal angles, C and at the same time update I, F(I), and NBAD. C JA=1 JB=1 ALPHK=BETA(1) BETAK=BETA(NU+1)-P NN2=NN*2 NBAD=0 I=NU NF=NN DO 40 J=1,NN2 IF ((ALPHK+EPSI).LT.BETAK) THEN NF=NF+1 IF (JA.LT.NN) THEN JA=JA+1 ALPHK=BETA(JA) ELSE ALPHK=P2+1.0 ENDIF ELSE I=I+1 IF (I.EQ.(NN+1)) THEN I=1 NF=NF-NN ENDIF F(I)=NF NBAD=NBAD+NBPK((NF-I),2) IF (JB.LT.NN) THEN JB=JB+1 IF ((JB+NU).LE.NN) THEN BETAK=BETA(JB+NU)-P ELSE BETAK=BETA(JB+NU-NN)+P ENDIF ELSE BETAK=P2+1.0 ENDIF ENDIF 40 CONTINUE C C Computation of NUMH for halfspace depth. C GI=0 JA=1 ANG=BETA(1) NUMH=MIN0(F(1),(NN-F(1))) DO 50 I=2,NN IF(BETA(I).LE.(ANG+EPSI)) THEN JA=JA+1 ELSE GI=GI+JA JA=1 ANG=BETA(I) ENDIF KI=F(I)-GI NUMH=MIN0(NUMH,MIN0(KI,(NN-KI))) 50 CONTINUE C C Adjust for the number NZ of data points equal to Z=(U,V). C 60 NUMH=NUMH+NZ HDEP=NUMH RETURN END SUBROUTINE BPISOD(N,M,X,Y,MAXN,MAXM,MAXNUM,NRANK,D,F,BETA, CCCCC RENAME TO 6-CHARACTER NAME CCCCC SUBROUTINE BP_ISODEPTH(N,M,X,Y,MAXN,MAXM,MAXNUM,NRANK,D,F,BETA, + KAND1,KAND2,ALPHA,IND1,IND2,NCIRQ,MCIRQ,ANGLE,KORNR,L, + JRV,JLV,DPF,NUM,K,EMPTY) C C Computes the depth contour of depth k. This subroutine was described C in: Ruts, I. and Rousseeuw, P.J. (1996). Computing depth contours of C bivariate point clouds. CSDA 23, 153-168. C INTEGER NCIRQ(N),MCIRQ(N),NRANK(N),F(N) integer JLV(M),JRV(M) INTEGER IND1(M),IND2(M) INTEGER KAND1(MAXNUM),KAND2(MAXNUM),KORNR(MAXNUM,4) INTEGER KON,KONTROL,NDATA,NDK,HALT,halt2,jj,JFULL,EMPTY INTEGER IV,IW1,IW2,NEXT,JFLAG,KOUNT,NUM,tel INTEGER HDEP1,HDEP2,HDEP3,HDEP4,HDEP5,I,J,K,L,M,N double precision X(N),Y(N),BETA(N) double precision ANGLE(M),D(M),ALPHA(MAXNUM),DPF(N) double precision PI,PI2,EPS double precision XCORD,YCORD,ANG1,xcord1,ycord1,m1,m2 PI=DACOS(DBLE(-1.0)) PI2=PI/2.0 EPS=0.0000001 empty=0 C C (Re)initialize NCIRQ and NRANK. C DO 45 I=1,N NCIRQ(I)=MCIRQ(I) 45 CONTINUE DO 50 I=1,N IV=NCIRQ(I) NRANK(IV)=I 50 CONTINUE C C Let the line rotate from zero to ANGLE(1). C KOUNT=1 HALT=0 if (angle(1).gt.pi2) then l=1 CALL BPADJU(IND1,IND2,L,NRANK,NCIRQ,KOUNT,ALPHA,ANGLE, + K,N,M,MAXNUM,KAND1,KAND2,D,X,Y) halt=1 endif L=2 60 KONTROL=0 IF ((PI.LE.(ANGLE(L)+PI2)).AND.((ANGLE(L)-PI2).LT.ANGLE(1))) THEN CALL BPADJU(IND1,IND2,L,NRANK,NCIRQ,KOUNT,ALPHA,ANGLE, + K,N,M,MAXNUM,KAND1,KAND2,D,X,Y) KONTROL=1 ENDIF L=L+1 IF (KONTROL.EQ.1) HALT=1 IF ((L.EQ.M+1).AND.(KONTROL.EQ.1)) THEN JFLAG=1 GOTO 79 ENDIF IF (((HALT.EQ.1).AND.(KONTROL.EQ.0)).OR.(L.EQ.M+1)) THEN GOTO 70 ELSE GOTO 60 ENDIF 70 if (l.gt.1) then JFLAG=L-1 else jflag=m endif J=0 C C In case the first switch didn't occur between zero and ANGLE(1), C look for it between the following angles. C IF ((L.EQ.M+1).AND.(KONTROL.EQ.0)) THEN HALT=0 halt2=0 73 J=J+1 if (j.eq.m+1) j=1 L=J+1 if (l.eq.m+1) l=1 75 KONTROL=0 IF ((ANGLE(L)+PI2).LT.PI) THEN ANG1=ANGLE(L)+PI2 ELSE ANG1=ANGLE(L)-PI2 ENDIF if (j.eq.m) then jj=1 if (halt2.eq.0) angle(1)=angle(1)+pi else jj=j+1 endif IF ((ANGLE(J).LE.ANG1).AND.(ANG1.LT.ANGLE(jj))) THEN if (angle(1).gt.pi) angle(1)=angle(1)-pi CALL BPADJU(IND1,IND2,L,NRANK,NCIRQ,KOUNT,ALPHA,ANGLE, + K,N,M,MAXNUM,KAND1,KAND2,D,X,Y) KONTROL=1 ENDIF if (angle(1).gt.pi) angle(1)=angle(1)-pi IF (L.NE.M) THEN L=L+1 ELSE L=1 ENDIF IF (KONTROL.EQ.1) HALT=1 IF ((HALT.EQ.1).AND.(KONTROL.EQ.0)) THEN if (halt2.eq.1) goto 101 if (l.gt.1) then jflag=l-1 else jflag=m endif GOTO 79 ELSE IF (L.EQ.jj) THEN if (jj.eq.1) halt2=1 GOTO 73 ELSE GOTO 75 ENDIF ENDIF ENDIF C C The first switch has occurred. Now start looking for the next ones, C between the following angles. C 79 DO 80 I=J+1,M-1 L=JFLAG 90 KONTROL=0 IF ((ANGLE(L)+PI2).LT.PI) THEN ANG1=ANGLE(L)+PI2 ELSE ANG1=ANGLE(L)-PI2 ENDIF IF ((ANGLE(I).LE.ANG1).AND.(ANG1.LT.ANGLE(I+1))) THEN CALL BPADJU(IND1,IND2,L,NRANK,NCIRQ,KOUNT,ALPHA, + ANGLE,K,N,M,MAXNUM,KAND1,KAND2,D,X,Y) KONTROL=1 ENDIF IF (KONTROL.EQ.0) THEN JFLAG=L ELSE IF (L.NE.M) THEN L=L+1 ELSE L=1 ENDIF GOTO 90 ENDIF 80 CONTINUE L=JFLAG C C Finally, look for necessary switches between the last angle and zero. C 100 KONTROL=0 IF ((ANGLE(L)+PI2).LT.PI) THEN ANG1=ANGLE(L)+PI2 ELSE ANG1=ANGLE(L)-PI2 ENDIF IF ((ANGLE(M).LE.ANG1).AND.(ANG1.LT.PI)) THEN CALL BPADJU(IND1,IND2,L,NRANK,NCIRQ,KOUNT,ALPHA, + ANGLE,K,N,M,MAXNUM,KAND1,KAND2,D,X,Y) KONTROL=1 ENDIF IF (KONTROL.EQ.1) THEN IF (L.NE.M) THEN L=L+1 ELSE L=1 ENDIF GOTO 100 ENDIF 101 NUM=KOUNT-1 C C Sort the NUM special k-dividers. C Permute KAND1, KAND2 and D in the same way. C CALL BPSORT(ALPHA,KAND1,KAND2,D,NUM,JLV,JRV) IW1=1 IW2=2 JFULL=0 NDK=0 tel=0 120 NDATA=0 C C Compute the intersection point. C IF (DABS(-DSIN(ALPHA(IW2))*DCOS(ALPHA(IW1)) + +DSIN(ALPHA(IW1))*DCOS(ALPHA(IW2))).LT.EPS) THEN IW2=IW2+1 IF (IW2.EQ.NUM+1) IW2=1 GOTO 120 ENDIF XCORD=(DCOS(ALPHA(IW2))*D(IW1)-DCOS(ALPHA(IW1))*D(IW2)) + /(-DSIN(ALPHA(IW2))*DCOS(ALPHA(IW1)) + +DSIN(ALPHA(IW1))*DCOS(ALPHA(IW2))) YCORD=(-DSIN(ALPHA(IW2))*D(IW1)+DSIN(ALPHA(IW1))*D(IW2)) + /(-DSIN(ALPHA(IW1))*DCOS(ALPHA(IW2)) + +DSIN(ALPHA(IW2))*DCOS(ALPHA(IW1))) C C Test whether the intersection point is a data point. C If so, adjust IW1 and IW2. C IF ((KAND1(IW1).EQ.KAND1(IW2)).OR.(KAND1(IW1).EQ.KAND2(IW2))) + NDATA=KAND1(IW1) IF ((KAND2(IW1).EQ.KAND1(IW2)).OR.(KAND2(IW1).EQ.KAND2(IW2))) + NDATA=KAND2(IW1) IF (NDATA.NE.0) THEN iv=0 125 NEXT=IW2+1 iv=iv+1 IF (NEXT.EQ.(NUM+1)) NEXT=1 if (next.ne.iw1) then IF ((NDATA.EQ.KAND1(NEXT)).OR.(NDATA.EQ.KAND2(NEXT))) THEN IW2=IW2+1 IF (IW2.EQ.(NUM+1)) IW2=1 GOTO 125 ENDIF endif if (iv.eq.(num-1)) then num=1 KORNR(1,1)=KAND1(IW1) KORNR(1,2)=KAND2(IW1) KORNR(1,3)=KAND1(IW2) KORNR(1,4)=KAND2(IW2) return endif ENDIF IF (IW2.EQ.NUM) THEN KON=1 ELSE KON=IW2+1 ENDIF if (kon.eq.iw1) kon=kon+1 if (kon.eq.num+1) kon=1 C C Test whether the intersection point lies to the left of the special C k-divider which corresponds to ALPHA(KON). If so, compute its depth. C IF ((DSIN(ALPHA(KON))*XCORD-DCOS(ALPHA(KON))*YCORD + -D(KON)).le.eps) THEN CALL BPDEPT(XCORD,YCORD,N,X,Y,BETA,F,DPF,JLV,JRV,HDEP1) IF (HDEP1.EQ.K) NDK=1 IF (HDEP1.NE.K) THEN CALL BPDEPT(XCORD-EPS*10,YCORD-EPS*10,N,X,Y,BETA,F,DPF, + JLV,JRV,HDEP2) CALL BPDEPT(XCORD+EPS*10,YCORD+EPS*10,N,X,Y,BETA,F,DPF, + JLV,JRV,HDEP3) CALL BPDEPT(XCORD-EPS*10,YCORD+EPS*10,N,X,Y,BETA,F,DPF, + JLV,JRV,HDEP4) CALL BPDEPT(XCORD+EPS*10,YCORD-EPS*10,N,X,Y,BETA,F,DPF, + JLV,JRV,HDEP5) IF ((NDK.EQ.0).AND. + ((HDEP1.ge.K).OR.(HDEP2.ge.K).OR.(HDEP3.ge.K) + .OR.(HDEP4.ge.K).OR.(HDEP5.ge.K))) THEN NDK=1 ENDIF IF ((HDEP1.LT.K).AND.(HDEP2.LT.K) + .AND.(HDEP3.LT.K).AND.(HDEP4.LT.K) + .AND.(HDEP5.LT.K).AND.(NDK.EQ.1)) THEN C C The intersection point is not the correct one, C try the next special k-divider. C IW2=IW2+1 IF (IW2.EQ.(NUM+1)) IW2=1 GOTO 120 ENDIF ENDIF C C Store IW1 and IW2 in KORNR. If KORNR has already been filled, check whether C we have encountered this intersection point before. C IF ((IW2.GT.IW1).AND.(JFULL.EQ.0)) THEN DO 130 I=IW1,IW2-1 KORNR(I,1)=KAND1(IW1) KORNR(I,2)=KAND2(IW1) KORNR(I,3)=KAND1(IW2) KORNR(I,4)=KAND2(IW2) 130 CONTINUE ELSE IF (IW2.GT.IW1) THEN DO 140 I=IW1,IW2-1 IF ((KORNR(I,1).EQ.KAND1(IW1)).AND. + (KORNR(I,2).EQ.KAND2(IW1)).AND. + (KORNR(I,3).EQ.KAND1(IW2)).AND. + (KORNR(I,4).EQ.KAND2(IW2))) + THEN GOTO 170 ELSE tel=tel+1 if (tel.gt.num*num) then ndk=1 goto 170 endif m1=(y(kornr(i,2))-y(kornr(i,1)))/ + (x(kornr(i,2))-x(kornr(i,1))) m2=(y(kornr(i,4))-y(kornr(i,3)))/ + (x(kornr(i,4))-x(kornr(i,3))) if (m1.ne.m2) then xcord1=(m1*x(kornr(i,1))-y(kornr(i,1))- + m2*x(kornr(i,3))-y(kornr(i,3)))/(m1-m2) ycord1=(m2*(m1*x(kornr(i,1))-y(kornr(i,1)))- + m1*(m2*x(kornr(i,3))-y(kornr(i,3))))/(m1-m2) endif if ((dabs(xcord1-xcord).le.eps).and. + (dabs(ycord1-ycord).le.eps)) then goto 170 endif KORNR(I,1)=KAND1(IW1) KORNR(I,2)=KAND2(IW1) KORNR(I,3)=KAND1(IW2) KORNR(I,4)=KAND2(IW2) ENDIF 140 CONTINUE ELSE JFULL=1 DO 150 I=IW1,NUM KORNR(I,1)=KAND1(IW1) KORNR(I,2)=KAND2(IW1) KORNR(I,3)=KAND1(IW2) KORNR(I,4)=KAND2(IW2) 150 CONTINUE DO 160 I=1,IW2-1 IF ((KORNR(I,1).EQ.KAND1(IW1)).AND. + (KORNR(I,2).EQ.KAND2(IW1)).AND. + (KORNR(I,3).EQ.KAND1(IW2)).AND. + (KORNR(I,4).EQ.KAND2(IW2))) + THEN GOTO 170 ELSE tel=tel+1 if (tel.gt.num*num) then ndk=1 goto 170 endif m1=(y(kornr(i,2))-y(kornr(i,1)))/ + (x(kornr(i,2))-x(kornr(i,1))) m2=(y(kornr(i,4))-y(kornr(i,3)))/ + (x(kornr(i,4))-x(kornr(i,3))) if (m1.ne.m2) then xcord1=(m1*x(kornr(i,1))-y(kornr(i,1))- + m2*x(kornr(i,3))-y(kornr(i,3)))/(m1-m2) ycord1=(m2*(m1*x(kornr(i,1))-y(kornr(i,1)))- + m1*(m2*x(kornr(i,3))-y(kornr(i,3))))/(m1-m2) endif if ((dabs(xcord1-xcord).le.eps).and. + (dabs(ycord1-ycord).le.eps)) then goto 170 endif KORNR(I,1)=KAND1(IW1) KORNR(I,2)=KAND2(IW1) KORNR(I,3)=KAND1(IW2) KORNR(I,4)=KAND2(IW2) ENDIF 160 CONTINUE ENDIF ENDIF ELSE C C The intersection point is not the correct one, C try the next special k-divider. C IW2=IW2+1 IF (IW2.EQ.(NUM+1)) IW2=1 GOTO 120 ENDIF C C Look for the next vertex of the convex figure. C IW1=IW2 IW2=IW2+1 IF (IW2.EQ.(NUM+1)) IW2=1 GOTO 120 170 if (ndk.eq.0) empty=1 RETURN END subroutine bprdra(a,ntot,seed,n) CCCCC RENAME TO 6-CHARACTER NAME CCCCC subroutine bp_rdraw(a,ntot,seed,n) C C Draws n elements out of a dataset of size ntot, such that C the selected case numbers are uniformly distributed from 1 to ntot. C integer a(n) integer seed,nrand real xjunk(1) double precision urand jndex=0 do 20 m=1,n CCCCC call bp_uniran(1,seed,urand) call uniran(1,seed,xjunk) urand=dble(xjunk(1)) nrand=int(urand*(ntot-jndex))+1 jndex=jndex+1 if(jndex.eq.1) then a(jndex)=nrand else a(jndex)=nrand+jndex-1 do 5 i=1,jndex-1 if(a(i).gt.nrand+i-1) then do 6 j=jndex,i+1,-1 a(j)=a(j-1) 6 continue a(i)=nrand+i-1 goto 20 endif 5 continue endif 20 continue return end SUBROUTINE BPSORT(B,I1,I2,R,N,JLV,JRV) CCCCC RENAME TO USE 6 CHARACTER NAME CCCCC SUBROUTINE BP_SORT(B,I1,I2,R,N,JLV,JRV) C C Sorts a double precision array B of length N and permutes two C integer arrays I1 and I2 and one double precision array R in the C same way. C INTEGER N,I1(*),I2(*),H1,H2 double precision B(*),XX,AMM double precision R(*),H3 integer JLV(*),JRV(*) JSS=1 JLV(1)=1 JRV(1)=N 10 JNDL=JLV(JSS) JR=JRV(JSS) JSS=JSS-1 20 JNC=JNDL J=JR JTWE=(JNDL+JR)/2 XX=B(JTWE) 30 IF (B(JNC).GE.XX) GOTO 40 JNC=JNC+1 GOTO 30 40 IF (XX.GE.B(J)) GOTO 50 J=J-1 GOTO 40 50 IF (JNC.GT.J) GOTO 60 AMM=B(JNC) H1=I1(JNC) H2=I2(JNC) H3=R(JNC) B(JNC)=B(J) I1(JNC)=I1(J) I2(JNC)=I2(J) R(JNC)=R(J) B(J)=AMM I1(J)=H1 I2(J)=H2 R(J)=H3 JNC=JNC+1 J=J-1 60 IF (JNC.LE.J) GOTO 30 IF ((J-JNDL).LT.(JR-JNC)) GOTO 80 IF (JNDL.GE.J) GOTO 70 JSS=JSS+1 JLV(JSS)=JNDL JRV(JSS)=J 70 JNDL=JNC GOTO 100 80 IF (JNC.GE.JR) GOTO 90 JSS=JSS+1 JLV(JSS)=JNC JRV(JSS)=JR 90 JR=J 100 IF (JNDL.LT.JR) GOTO 20 IF (JSS.NE.0) GOTO 10 RETURN END SUBROUTINE BRACDF(X,BETA,CDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION C FUNCTION VALUE FOR THE BRADFORD C DISTRIBUTION WITH SINGLE PRECISION C TAIL LENGTH PARAMETER = BETA. C THE BRADFORD DISTRIBUTION USED C HEREIN IS DEFINED FOR 0 < x < 1. C AND HAS THE PROBABILITY DENSITY FUNCTION C F(X) = [BETA / LOG(1+BETA)]*(1/(1+BETA*X)) C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE C AT WHICH THE CUMULATIVE DISTRIBUTION C FUNCTION IS TO BE EVALUATED. C X SHOULD BE GREATER THAN C OR EQUAL TO 1. C --BETA = THE SINGLE PRECISION VALUE C OF THE TAIL LENGTH PARAMETER. C BETA SHOULD BE POSITIVE. C OUTPUT ARGUMENTS--CDF = THE SINGLE PRECISION PROBABILITY C DENSITY FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY C FUNCTION VALUE CDF FOR THE BRADFORD C DISTRIBUTION WITH TAIL LENGTH PARAMETER VALUE = BETA. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--BETA SHOULD BE POSITIVE. C --X SHOULD BE POSITIVE AND LESS THAN 1. C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN. C REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE C DISTRIBUTIONS--2, 2ND. ED., 1994, PAGE 347. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING LABORATORY (205.03) C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE: 301-975-2855 C ORIGINAL VERSION--FEBRUARY 1995. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DX DOUBLE PRECISION DB DOUBLE PRECISION DTERM1 DOUBLE PRECISION DCDF C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C--------------------------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(X.LE.0.0.OR.X.GE.1.0)THEN WRITE(ICOUT,4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') CDF=0.0 GOTO9999 ENDIF 4 FORMAT('***** FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT ', 1'TO BRACDF IS OUTSIDE THE (0,1) INTERVAL') IF(BETA.LE.-1.0)THEN WRITE(ICOUT,15) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)BETA CALL DPWRST('XXX','BUG ') CDF=0.0 GOTO9999 ENDIF 15 FORMAT('***** FATAL DIAGNOSTIC--THE SECOND INPUT ARGUMENT ', 1'TO BRACDF IS LESS THAN OR EQUAL TO -1') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') C C-----START POINT----------------------------------------------------- C DX=DBLE(X) DB=DBLE(BETA) IF(DB.LE.0.0D0)THEN DCDF=DLOG(1.0D0+DB*DX)/DLOG(1.0D0+DB) CDF=SNGL(DCDF) ELSE DTERM1=DLOG(DLOG(1.0D0+DB*DX))-DLOG(DLOG(1.0D0+DB)) IF(DTERM1.GE.-65.0D0)THEN DCDF=DEXP(DTERM1) CDF=SNGL(DCDF) ELSE CDF=0.0 ENDIF ENDIF C 9999 CONTINUE RETURN END SUBROUTINE BRAPDF(X,BETA,PDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY C FUNCTION VALUE FOR THE BRADFORD C DISTRIBUTION WITH SINGLE PRECISION C TAIL LENGTH PARAMETER = BETA. C THE BRADFORD DISTRIBUTION USED C HEREIN IS DEFINED FOR 0 < x < 1. C AND HAS THE PROBABILITY DENSITY FUNCTION C F(X) = [BETA / LOG(1+BETA)]*(1/(1+BETA*X)) C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE C AT WHICH THE PROBABILITY DENSITY C FUNCTION IS TO BE EVALUATED. C X SHOULD BE GREATER THAN C OR EQUAL TO 1. C --BETA = THE SINGLE PRECISION VALUE C OF THE TAIL LENGTH PARAMETER. C BETA SHOULD BE POSITIVE. C OUTPUT ARGUMENTS--PDF = THE SINGLE PRECISION PROBABILITY C DENSITY FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY C FUNCTION VALUE PDF FOR THE BRADFORD C DISTRIBUTION WITH TAIL LENGTH PARAMETER VALUE = BETA. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--BETA SHOULD BE POSITIVE. C --X SHOULD BE POSITIVE AND LESS THAN 1. C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN. C REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE C DISTRIBUTIONS--2, 2ND. ED., 1994, PAGE 347. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING LABORATORY (205.03) C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE: 301-975-2855 C ORIGINAL VERSION--FEBRUARY 1995. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DX DOUBLE PRECISION DB DOUBLE PRECISION DTERM1 DOUBLE PRECISION DPDF C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C--------------------------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(X.LE.0.0.OR.X.GE.1.0)THEN WRITE(ICOUT,4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9999 ENDIF 4 FORMAT('***** FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT ', 1'TO BRAPDF IS OUTSIDE THE (0,1) INTERVAL') IF(BETA.LE.-1.0)THEN WRITE(ICOUT,15) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)BETA CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9999 ENDIF 15 FORMAT('***** FATAL DIAGNOSTIC--THE SECOND INPUT ARGUMENT ', 1'TO BRAPDF IS LESS THAN OR EQUAL TO -1') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') C C-----START POINT----------------------------------------------------- C DX=DBLE(X) DB=DBLE(BETA) IF(DB.LE.0.0D0)THEN DPDF=DB/(DLOG(1.0D0+DB)*(1.0D0+DB*DX)) PDF=SNGL(DPDF) ELSE DTERM1=DLOG(DB)-DLOG(DLOG(1.0D0+DB))-DLOG(1.0D0+DB*DX) IF(DTERM1.GE.-65.0D0)THEN DPDF=DEXP(DTERM1) PDF=SNGL(DPDF) ELSE PDF=0.0 ENDIF ENDIF C 9999 CONTINUE RETURN END SUBROUTINE BRAPPF(P,BETA,PPF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT C FUNCTION VALUE FOR THE BRADFORD C DISTRIBUTION WITH SINGLE PRECISION C TAIL LENGTH PARAMETER = BETA. C THE BRADFORD DISTRIBUTION USED C HEREIN IS DEFINED FOR 0 < x < 1. C AND HAS THE PROBABILITY DENSITY FUNCTION C F(X) = [BETA / LOG(1+BETA)]*(1/(1+BETA*X)) C INPUT ARGUMENTS--P = THE SINGLE PRECISION VALUE C (BETWEEN 0.0 (INCLUSIVELY) C AND 1.0 (EXCLUSIVELY)) C AT WHICH THE PERCENT POINT C FUNCTION IS TO BE EVALUATED. C --BETA = THE SINGLE PRECISION VALUE C OF THE TAIL LENGTH PARAMETER. C BETA SHOULD BE POSITIVE. C OUTPUT ARGUMENTS--PPF = THE SINGLE PRECISION PERCENT C POINT FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION PERCENT POINT FUNCTION . C VALUE PPF FOR THE BRADFORD DISTRIBUTION C WITH TAIL LENGTH PARAMETER VALUE = BETA. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--BETA SHOULD BE POSITIVE. C --P SHOULD BE BETWEEN 0.0 (INCLUSIVELY) C AND 1.0 (EXCLUSIVELY). C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE C DISTRIBUTIONS--2, 2ND. ED., 1994, PAGE 347. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--96.2 C ORIGINAL VERSION--FEBRUARY 1996. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DP DOUBLE PRECISION DB DOUBLE PRECISION DPPF C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(P.LE.0.0.OR.P.GE.1.0)THEN WRITE(ICOUT,1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)P CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9999 ENDIF 1 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ', 1'BRAPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL') IF(BETA.LE.-1.0)THEN WRITE(ICOUT,15) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)BETA CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9999 ENDIF 15 FORMAT('***** FATAL DIAGNOSTIC--THE SECOND INPUT ARGUMENT ', 1'TO BRAPPF IS LESS THAN OR EQUAL TO -1') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') C DP=DBLE(P) DB=DBLE(BETA) DPPF=(DEXP(DLOG(1.0D0+DB)*DP)-1.0D0)/DB PPF=SNGL(DPPF) C 9999 CONTINUE RETURN END SUBROUTINE BRARAN(N,BETA,ISEED,X) C C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N C FROM THE BRADFORD DISTRIBUTION C WITH SHAPE PARAMETER VALUE = BETA. C INPUT ARGUMENTS--N = THE DESIRED INTEGER NUMBER C OF RANDOM NUMBERS TO BE C GENERATED. C --BETA = THE SINGLE PRECISION VALUE OF THE C SHAPE PARAMETER. C BETA SHOULD BE POSITIVE. C OUTPUT ARGUMENTS--X = A SINGLE PRECISION VECTOR C (OF DIMENSION AT LEAST N) C INTO WHICH THE GENERATED C RANDOM SAMPLE WILL BE PLACED. C OUTPUT--A RANDOM SAMPLE OF SIZE N C FROM THE BRADFORD DISTRIBUTION C WITH SHAPE PARAMETER VALUE = BETA. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C --BETA SHOULD BE POSITIVE. C OTHER DATAPAC SUBROUTINES NEEDED--UNIRAN. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--XX C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2001.10 C ORIGINAL VERSION--OCTOBER 2001. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DIMENSION X(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(N.LT.1)THEN WRITE(ICOUT, 5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)N CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF IF(BETA.LE.0.0)THEN WRITE(ICOUT,15) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)BETA CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF 5 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ', 1'BRARAN SUBROUTINE IS NON-POSITIVE *****') 15 FORMAT('***** FATAL ERROR--THE 2ND INPUT ARGUMENT TO THE ', 1'BRARAN SUBROUTINE IS NON-POSITIVE *****') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****') C C GENERATE N UNIFORM (0,1) RANDOM NUMBERS; C CALL UNIRAN(N,ISEED,X) C C GENERATE N BRADFORD DISTRIBUTION RANDOM NUMBERS C USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD. C DO100I=1,N CALL BRAPPF(X(I),BETA,XTEMP) X(I)=XTEMP 100 CONTINUE C 9000 CONTINUE RETURN END SUBROUTINE BSINIT(NDIM, W, LENRUL, G) * * For initializing basic rule weights and symmetric sum parameters. * INTEGER NDIM, LENRUL, RULPTS(6), I, J, NUMNUL, SDIM PARAMETER ( NUMNUL = 4, SDIM = 12 ) DOUBLE PRECISION W(LENRUL,4), G(NDIM,LENRUL) DOUBLE PRECISION LAM1, LAM2, LAM3, LAMP, RULCON * * The following code determines rule parameters and weights for a * degree 7 rule (W(1,1),...,W(5,1)), two degree 5 comparison rules * (W(1,2),...,W(5,2) and W(1,3),...,W(5,3)) and a degree 3 * comparison rule (W(1,4),...W(5,4)). * * If NDIM = 1, then LENRUL = 5 and total points = 9. * If NDIM < SDIM, then LENRUL = 6 and * total points = 1+2*NDIM*(NDIM+2)+2**NDIM. * If NDIM > = SDIM, then LENRUL = 6 and * total points = 1+2*NDIM*(1+2*NDIM). * DO 100 I = 1,LENRUL DO 200 J = 1,NDIM G(J,I) = 0 200 CONTINUE DO 300 J = 1,NUMNUL W(I,J) = 0 300 CONTINUE 100 CONTINUE RULPTS(5) = 2*NDIM*(NDIM-1) RULPTS(4) = 2*NDIM RULPTS(3) = 2*NDIM RULPTS(2) = 2*NDIM RULPTS(1) = 1 LAMP = 0.85 LAM3 = 0.4707 LAM2 = 4/(15 - 5/LAM3) W(5,1) = ( 3 - 5*LAM3 )/( 180*(LAM2-LAM3)*LAM2**2 ) IF ( NDIM .LT. SDIM ) THEN LAM1 = 8*LAM3*(31*LAM3-15)/( (3*LAM3-1)*(5*LAM3-3)*35 ) W(LENRUL,1) = 1/(3*LAM3)**3/2**NDIM ELSE LAM1 = ( LAM3*(15 - 21*LAM2) + 35*(NDIM-1)*(LAM2-LAM3)/9 ) & / ( LAM3*(21 - 35*LAM2) + 35*(NDIM-1)*(LAM2/LAM3-1)/9 ) W(6,1) = 1/(4*(3*LAM3)**3) ENDIF W(3,1) = ( 15 - 21*(LAM3+LAM1) + 35*LAM3*LAM1 ) & /( 210*LAM2*(LAM2-LAM3)*(LAM2-LAM1) ) - 2*(NDIM-1)*W(5,1) W(2,1) = ( 15 - 21*(LAM3+LAM2) + 35*LAM3*LAM2 ) & /( 210*LAM1*(LAM1-LAM3)*(LAM1-LAM2) ) IF ( NDIM .LT. SDIM ) THEN RULPTS(LENRUL) = 2**NDIM LAM3 = SQRT(LAM3) DO 400 I = 1,NDIM G(I,LENRUL) = LAM3 400 CONTINUE ELSE W(6,1) = 1/(4*(3*LAM3)**3) RULPTS(6) = 2*NDIM*(NDIM-1) LAM3 = SQRT(LAM3) DO 500 I = 1,2 G(I,6) = LAM3 500 CONTINUE ENDIF IF ( NDIM .GT. 1 ) THEN W(5,2) = 1/(6*LAM2)**2 W(5,3) = 1/(6*LAM2)**2 ENDIF W(3,2) = ( 3 - 5*LAM1 )/( 30*LAM2*(LAM2-LAM1) ) & - 2*(NDIM-1)*W(5,2) W(2,2) = ( 3 - 5*LAM2 )/( 30*LAM1*(LAM1-LAM2) ) W(4,3) = ( 3 - 5*LAM2 )/( 30*LAMP*(LAMP-LAM2) ) W(3,3) = ( 3 - 5*LAMP )/( 30*LAM2*(LAM2-LAMP) ) & - 2*(NDIM-1)*W(5,3) W(2,4) = 1/(6*LAM1) LAMP = SQRT(LAMP) LAM2 = SQRT(LAM2) LAM1 = SQRT(LAM1) G(1,2) = LAM1 G(1,3) = LAM2 G(1,4) = LAMP IF ( NDIM .GT. 1 ) THEN G(1,5) = LAM2 G(2,5) = LAM2 ENDIF DO 600 J = 1, NUMNUL W(1,J) = 1 DO 700 I = 2,LENRUL W(1,J) = W(1,J) - RULPTS(I)*W(I,J) 700 CONTINUE 600 CONTINUE RULCON = 2 CALL RULNRM( LENRUL, NUMNUL, RULPTS, W, RULCON ) C RETURN END SUBROUTINE BSPVN(T,JHIGH,K,INDEX,X,ILEFT,VNIKX,WORK,IWORK) C***BEGIN PROLOGUE BSPVN C***DATE WRITTEN 800901 (YYMMDD) C***REVISION DATE 820801 (YYMMDD) C***CATEGORY NO. E3,K6 C***KEYWORDS B-SPLINE,DATA FITTING,INTERPOLATION,SPLINE C***AUTHOR AMOS, D. E., (SNLA) C***PURPOSE Calculates the value of all (possibly) nonzero basis C functions at X. C***DESCRIPTION C C Written by Carl de Boor and modified by D. E. Amos C C Reference C SIAM J. Numerical Analysis, 14, No. 3, June, 1977, pp.441-472. C C Abstract C BSPVN is the BSPLVN routine of the reference. C C BSPVN calculates the value of all (possibly) nonzero basis C functions at X of order MAX(JHIGH,(J+1)*(INDEX-1)), where C T(K) .LE. X .LE. T(N+1) and J=IWORK is set inside the routine C on the first call when INDEX=1. ILEFT is such that T(ILEFT) C .LE. X .LT. T(ILEFT+1). A call to INTRV(T,N+1,X,ILO,ILEFT, C MFLAG) produces the proper ILEFT. BSPVN calculates using the C basic algorithm needed in BSPVD. If only basis functions are C desired, setting JHIGH=K and INDEX=1 can be faster than C calling BSPVD, but extra coding is required for derivatives C (INDEX=2) and BSPVD is set up for this purpose. C C Left limiting values are set up as described in BSPVD. C C Description of Arguments C Input C T - knot vector of length N+K, where C N = number of B-spline basis functions C N = sum of knot multiplicities-K C JHIGH - order of B-spline, 1 .LE. JHIGH .LE. K C K - highest possible order C INDEX - INDEX = 1 gives basis functions of order JHIGH C = 2 denotes previous entry with WORK, IWORK C values saved for subsequent calls to C BSPVN. C X - argument of basis functions, C T(K) .LE. X .LE. T(N+1) C ILEFT - largest integer such that C T(ILEFT) .LE. X .LT. T(ILEFT+1) C C Output C VNIKX - vector of length K for spline values. C WORK - a work vector of length 2*K C IWORK - a work parameter. Both WORK and IWORK contain C information necessary to continue for INDEX = 2. C When INDEX = 1 exclusively, these are scratch C variables and can be used for other purposes. C C Error Conditions C Improper input is a fatal error. C***REFERENCES C. DE BOOR, *PACKAGE FOR CALCULATING WITH B-SPLINES*, C SIAM JOURNAL ON NUMERICAL ANALYSIS, VOLUME 14, NO. 3, C JUNE 1977, PP. 441-472. C***ROUTINES CALLED XERROR C***END PROLOGUE BSPVN C C INTEGER ILEFT, IMJP1, INDEX, IPJ, IWORK, JHIGH, JP1, JP1ML, K, L REAL T, VM, VMPREV, VNIKX, WORK, X C DIMENSION T(ILEFT+JHIGH) DIMENSION T(*), VNIKX(K), WORK(*) C CONTENT OF J, DELTAM, DELTAP IS EXPECTED UNCHANGED BETWEEN CALLS. C WORK(I) = DELTAP(I), WORK(K+I) = DELTAM(I), I = 1,K C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C***FIRST EXECUTABLE STATEMENT BSPVN IF(K.LT.1) GO TO 90 IF(JHIGH.GT.K .OR. JHIGH.LT.1) GO TO 100 IF(INDEX.LT.1 .OR. INDEX.GT.2) GO TO 105 IF(X.LT.T(ILEFT) .OR. X.GT.T(ILEFT+1)) GO TO 110 GO TO (10, 20), INDEX 10 IWORK = 1 VNIKX(1) = 1.0E0 IF (IWORK.GE.JHIGH) GO TO 40 C 20 IPJ = ILEFT + IWORK WORK(IWORK) = T(IPJ) - X IMJP1 = ILEFT - IWORK + 1 WORK(K+IWORK) = X - T(IMJP1) VMPREV = 0.0E0 JP1 = IWORK + 1 DO 30 L=1,IWORK JP1ML = JP1 - L VM = VNIKX(L)/(WORK(L)+WORK(K+JP1ML)) VNIKX(L) = VM*WORK(L) + VMPREV VMPREV = VM*WORK(K+JP1ML) 30 CONTINUE VNIKX(JP1) = VMPREV IWORK = JP1 IF (IWORK.LT.JHIGH) GO TO 20 C 40 RETURN C C 90 CONTINUE WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,91) CALL DPWRST('XXX','BUG ') 91 FORMAT('***** FROM BSPVN, K DOES NOT SATISFY K.GE.1 *****') RETURN 100 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,101) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,102) CALL DPWRST('XXX','BUG ') 101 FORMAT('***** FROM BSPVN, JHIGH DOES NOT SATISFY ') 102 FORMAT(' 1.LE.JHIGH.LE.K ******') RETURN 105 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,106) CALL DPWRST('XXX','BUG ') 106 FORMAT('***** FROM BSPVN, INDEX IS NOT 1 OR 2 *****') RETURN 110 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,111) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,112) CALL DPWRST('XXX','BUG ') 111 FORMAT('***** FROM BSPVN, X DOES NOT SATISFY ') 112 FORMAT(' T(ILEFT).LE.X.LE.T(ILEFT+1) *****') RETURN END SUBROUTINE BTACDF(X,LAMBDA,K,CDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION C FUNCTION VALUE AT THE SINGLE PRECISION VALUE X C FOR THE BOREL-TANNER DISTRIBUTION C WITH SINGLE PRECISION SHAPE PARAMETERS LAMBDA AND K. C THIS DISTRIBUTION IS DEFINED FOR ALL C POSITIVE INTEGER X >= K. C THIS DISTRIBUTION HAS THE PROBABILITY FUNCTION C p(X;LAMBDA,K) = K*EXP(-LAMBDA*X)*(LAMBDA*X)**(X-K)/ C (X*(X-K)!), X >= K, 0 < LAMBDA < 1. C THE CUMULATIVE DISTRIBUTION IS COMPUTED BY DIRECT C SUMMATION OF THE PDF FUNCTION. C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE C AT WHICH THE CUMULATIVE DISTRIBUTION C FUNCTION IS TO BE EVALUATED. C X SHOULD BE A NON-NEGATIVE INTEGR C --LAMBDA = THE SINGLE PRECISION VALUE C OF THE FIRST SHAPE PARAMETER. C --K = THE SINGLE PRECISION VALUE C OF THE SECOND SHAPE PARAMETER. C OUTPUT ARGUMENTS--CDF = THE SINGLE PRECISION PROBABILITY C C OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION C FUNCTION VALUE CDF C FOR THE BOREL-TANNER DISTRIBUTION C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--X SHOULD BE A POSITIVE INTEGER C --0 < LAMBDA < 1, AND K SHOULD BE A POSITIVE C INTEGER C OTHER DATAPAC SUBROUTINES NEEDED--LNGAMM. C FORTRAN LIBRARY SUBROUTINES NEEDED--DEXP, DLOG C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--JOHNSON, KOTZ, AND KEMP (1992). "UNIVARIATE C DISCRETE DISTRIBUTIONS", SECOND EDITION, C WILEY, PP. 394-396. C --LUC DEVROYE, "THE BRANCHING PROCESS METHOD IN C LAGRANGE RANDOM VARIATE GENERATION", C FROM DEVROYES'S WEB SITE. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2006/5 C ORIGINAL VERSION--MAY 2006. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C REAL K REAL LAMBDA C DOUBLE PRECISION DX DOUBLE PRECISION DLAMB DOUBLE PRECISION DK DOUBLE PRECISION DCDF DOUBLE PRECISION DPDF DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 DOUBLE PRECISION DLNGAM C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C CDF=0.0 C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(LAMBDA.LE.0.0 .OR. LAMBDA.GE.1.0)THEN WRITE(ICOUT,11) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)LAMBDA CALL DPWRST('XXX','BUG ') CDF=0.0 GOTO9999 ENDIF C IK=INT(K+0.5) IF(IK.LT.1)THEN WRITE(ICOUT,12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)IK CALL DPWRST('XXX','BUG ') CDF=0.0 GOTO9999 ENDIF INTX=X+0.5 IF(INTX.LT.IK)THEN WRITE(ICOUT,5)IK CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)INTX CALL DPWRST('XXX','BUG ') CDF=0.0 GOTO9999 ENDIF C 5 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO THE BTACDF ', 1'SUBROUTINE IS LESS THAN THE THIRD ARGUMENT (= ',I8) 11 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO THE ', 1' BTACDF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL') 12 FORMAT('***** ERROR--THE THIRD INPUT ARGUMENT TO THE ', 1' BTACDF SUBROUTINE IS NON-POSITIVE') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7) 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8) C DLAMB=DBLE(LAMBDA) DK=DBLE(IK) DCDF=0.0D0 C DO100I=INTX,IK,-1 DX=DBLE(I) DTERM1=DLOG(DK) + (-DLAMB*DX) + (DX-DK)*DLOG(DLAMB*DX) DTERM2=DLOG(DX) + DLNGAM(DX-DK+1.0D0) DPDF=DEXP(DTERM1 - DTERM2) DCDF=DCDF + DPDF 100 CONTINUE C CDF=REAL(DCDF) C 9999 CONTINUE RETURN END SUBROUTINE BTAPDF(X,LAMBDA,K,PDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY C FUNCTION VALUE AT THE SINGLE PRECISION VALUE X C FOR THE BOREL-TANNER DISTRIBUTION C WITH SINGLE PRECISION SHAPE PARAMETERS LAMBDA AND K. C THIS DISTRIBUTION IS DEFINED FOR ALL C POSITIVE INTEGER X >= K. C THIS DISTRIBUTION HAS THE PROBABILITY FUNCTION C p(X;LAMBDA,K) = K*EXP(-LAMBDA*X)*(LAMBDA*X)**(X-K)/ C (X*(X-K)!), X >= K, 0 < LAMBDA < 1. C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE C AT WHICH THE PROBABILITY DENSITY C FUNCTION IS TO BE EVALUATED. C X SHOULD BE A NON-NEGATIVE INTEGR C --LAMBDA = THE SINGLE PRECISION VALUE C OF THE FIRST SHAPE PARAMETER. C --K = THE SINGLE PRECISION VALUE C OF THE SECOND SHAPE PARAMETER. C OUTPUT ARGUMENTS--PDF = THE SINGLE PRECISION PROBABILITY C C OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY C FUNCTION VALUE PDF C FOR THE BOREL-TANNER DISTRIBUTION C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--X SHOULD BE A POSITIVE INTEGER C --0 < LAMBDA < 1, AND K SHOULD BE A POSITIVE C INTEGER C OTHER DATAPAC SUBROUTINES NEEDED--LNGAMM. C FORTRAN LIBRARY SUBROUTINES NEEDED--DEXP, DLOG C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--JOHNSON, KOTZ, AND KEMP (1992). "UNIVARIATE C DISCRETE DISTRIBUTIONS", SECOND EDITION, C WILEY, PP. 394-396. C --LUC DEVROYE, "THE BRANCHING PROCESS METHOD IN C LAGRANGE RANDOM VARIATE GENERATION", C FROM DEVROYES'S WEB SITE. C --HAIGHT AND BREUER (1960), "THE BOREL-TANNER C DISTRIBUTION", BIOMETRIKA, 47, PP. 143-150. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2006/5 C ORIGINAL VERSION--MAY 2006. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C REAL K REAL LAMBDA C DOUBLE PRECISION DX DOUBLE PRECISION DLAMB DOUBLE PRECISION DK DOUBLE PRECISION DPDF DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 DOUBLE PRECISION DLNGAM C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C PDF=0.0 C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(LAMBDA.LE.0.0 .OR. LAMBDA.GE.1.0)THEN WRITE(ICOUT,11) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)LAMBDA CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9999 ENDIF C IK=INT(K+0.5) IF(IK.LT.1)THEN WRITE(ICOUT,12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)IK CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9999 ENDIF INTX=X+0.5 IF(INTX.LT.IK)THEN WRITE(ICOUT,5)IK CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)INTX CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9999 ENDIF C 5 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO THE BTAPDF ', 1'SUBROUTINE IS LESS THAN THE THIRD ARGUMENT (= ',I8) 11 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO THE ', 1' BTAPDF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL') 12 FORMAT('***** ERROR--THE THIRD INPUT ARGUMENT TO THE ', 1' BTAPDF SUBROUTINE IS NON-POSITIVE') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7) 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8) C DX=DBLE(INTX) DLAMB=DBLE(LAMBDA) DK=DBLE(IK) C DTERM1=DLOG(DK) + (-DLAMB*DX) + (DX-DK)*DLOG(DLAMB*DX) DTERM2=DLOG(DX) + DLNGAM(DX-DK+1.0D0) DPDF=DEXP(DTERM1 - DTERM2) PDF=REAL(DPDF) C 9999 CONTINUE RETURN END SUBROUTINE BTAPPF(P,LAMBDA,K,PPF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT C FUNCTION VALUE AT THE SINGLE PRECISION VALUE P C FOR THE BOREL-TANNER DISTRIBUTION WITH SINGLE PRECISION C SHAPE PARAMETERS LAMBDA AND K. C THIS DISTRIBUTION IS DEFINED FOR ALL C POSITIVE INTEGER X >= K. C THIS DISTRIBUTION HAS THE PROBABILITY FUNCTION C p(X;LAMBDA,K) = K*EXP(-LAMBDA*X)*(LAMBDA*X)**(X-K)/ C (X*(X-K)!), X >= K, 0 < LAMBDA < 1. C THIS DISTRIBUTION IS DEFINED FOR 0 <= P <= 1. C INPUT ARGUMENTS--P = THE SINGLE PRECISION VALUE C AT WHICH THE PERCENT POINT C FUNCTION IS TO BE EVALUATED. C 0 <= P < 1. C --LAMBDA = THE SINGLE PRECISION VALUE C OF THE FIRST SHAPE PARAMETER. C --K = THE SINGLE PRECISION VALUE C OF THE SECOND SHAPE PARAMETER. C OUTPUT ARGUMENTS--PPF = THE SINGLE PRECISION PERCENT POINT C FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION PERCENT POINT FUNCTION VALUE PPF C FOR THE BOREL-TANNER DISTRIBUTION C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--0 <= P < 1 C --0 < LAMBDA < 1, K A POSITIVE INTEGER C OTHER DATAPAC SUBROUTINES NEEDED--DLNGAM. C FORTRAN LIBRARY SUBROUTINES NEEDED--DEXP, DLOG C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--JOHNSON, KOTZ, AND KEMP (1992). "UNIVARIATE C DISCRETE DISTRIBUTIONS", SECOND EDITION, C WILEY, PP. 394-396. C --LUC DEVROYE, "THE BRANCHING PROCESS METHOD IN C LAGRANGE RANDOM VARIATE GENERATION", C FROM DEVROYES'S WEB SITE. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2006/5 C ORIGINAL VERSION--MAY 2006. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C REAL K REAL LAMBDA C DOUBLE PRECISION DP C DOUBLE PRECISION DX DOUBLE PRECISION DLAMB DOUBLE PRECISION DK DOUBLE PRECISION DCDF DOUBLE PRECISION DPDF DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 DOUBLE PRECISION DLNGAM C INCLUDE 'DPCOMC.INC' C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT--------------------------------------------------- C PPF=0.0 C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(P.LT.0.0.OR.P.GE.1.0)THEN WRITE(ICOUT,1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)P CALL DPWRST('XXX','BUG ') PPF=0.0 ENDIF C IF(LAMBDA.LE.0.0 .OR. LAMBDA.GE.1.0)THEN WRITE(ICOUT,11) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)LAMBDA CALL DPWRST('XXX','BUG ') CDF=0.0 GOTO9999 ENDIF C IK=INT(K+0.5) IF(IK.LT.1)THEN WRITE(ICOUT,12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)IK CALL DPWRST('XXX','BUG ') CDF=0.0 GOTO9999 C ENDIF 1 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO THE ', 1' BTAPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1] INTERVAL') 11 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO THE ', 1' BTAPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL') 12 FORMAT('***** ERROR--THE THIRD INPUT ARGUMENT TO THE ', 1' BTAPPF SUBROUTINE IS NON-POSITIVE') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7) 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8) C IF(P.LE.0.0)THEN PPF=REAL(IK) GOTO9999 ENDIF C DLAMB=DBLE(LAMBDA) DK=DBLE(IK) DP=DBLE(P) C C COMPUTE PDF FOR X = IK C DX=DK DCDF=DEXP(-DLAMB*DX - DLNGAM(1.0D0)) C IF(DCDF.GE.DP)THEN PPF=REAL(IK) GOTO9999 ENDIF I=IK C 100 CONTINUE I=I+1 IF(DBLE(I).GE.DBLE(I1MACH(9)))THEN WRITE(ICOUT,55) 55 FORMAT('***** ERROR--THE COMPUTED PERCENT POINT VALUE ', 1 'EXCEEDS THE LARGEST MACHINE INTEGER.') CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9999 ENDIF DX=DBLE(I) DTERM1=DLOG(DK) + (-DLAMB*DX) + (DX-DK)*DLOG(DLAMB*DX) DTERM2=DLOG(DX) + DLNGAM(DX-DK+1.0D0) DPDF=DEXP(DTERM1 - DTERM2) DCDF=DCDF + DPDF IF(DCDF.GE.DP)THEN PPF=REAL(I) GOTO9999 ENDIF GOTO100 C 9999 CONTINUE RETURN END SUBROUTINE BTARAN(N,LAMBDA,K,ISEED,X) C C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N C FROM THE BOREL-TANNER DISTRIBUTION C WITH SHAPE PARAMETERS LAMBDA AND K. C THIS DISTRIBUTION IS DEFINED FOR ALL C POSITIVE INTEGER X >= K. C THIS DISTRIBUTION HAS THE PROBABILITY FUNCTION C p(X;LAMBDA,K) = K*EXP(-LAMBDA*X)*(LAMBDA*X)**(X-K)/ C (X*(X-K)!), X >= K, 0 < LAMBDA < 1. C INPUT ARGUMENTS--N = THE DESIRED INTEGER NUMBER C OF RANDOM NUMBERS TO BE C GENERATED. C --LAMBDA = THE SINGLE PRECISION VALUE C OF THE FIRST SHAPE PARAMETER. C --K = THE SINGLE PRECISION VALUE C OF THE SECOND SHAPE PARAMETER. C OUTPUT ARGUMENTS--X = A SINGLE PRECISION VECTOR C (OF DIMENSION AT LEAST N) C INTO WHICH THE GENERATED C RANDOM SAMPLE WILL BE PLACED. C OUTPUT--A RANDOM SAMPLE OF SIZE N C FROM THE BOREL-TANNER DISTRIBUTION C WITH SHAPE PARAMETERS LAMBDA AND K. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C --0 < LAMBDA < 1, K A POSITIVE INTEGER C OTHER DATAPAC SUBROUTINES NEEDED--UNIRAN C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--JOHNSON, KOTZ, AND KEMP (1992). "UNIVARIATE C DISCRETE DISTRIBUTIONS", SECOND EDITION, C WILEY, PP. 394-396. C --LUC DEVROYE, "THE BRANCHING PROCESS METHOD IN C LAGRANGE RANDOM VARIATE GENERATION", C FROM DEVROYES'S WEB SITE. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2006/5 C ORIGINAL VERSION--MAY 2006. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C REAL LAMBDA REAL K DIMENSION X(*) C CCCCC DIMENSION U(2) C CCCCC DOUBLE PRECISION PI CCCCC DOUBLE PRECISION C CCCCC DOUBLE PRECISION V CCCCC DOUBLE PRECISION Y CCCCC DOUBLE PRECISION DK CCCCC DOUBLE PRECISION DLAMB CCCCC DOUBLE PRECISION U1 CCCCC DOUBLE PRECISION W CCCCC DOUBLE PRECISION WT C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----DATA STATEMENTS------------------------------------------------- C DATA PI / 3.14159265358979D+00/ C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(N.LT.1)THEN WRITE(ICOUT, 5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)N CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF IF(LAMBDA.LE.0.0 .OR. LAMBDA.GE.1.0)THEN WRITE(ICOUT,11) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)LAMBDA CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9999 ENDIF C IK=INT(K+0.5) IF(IK.LT.1)THEN WRITE(ICOUT,12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)IK CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9999 ENDIF 5 FORMAT('***** ERROR--THE REQUESTED NUMBER OF ', 1'BOREL-TANNER RANDOM NUMBERS IS NON-POSITIVE') 11 FORMAT('***** ERROR--THE LAMBDA PARAMETER FOR THE ', 1'BOREL-TANNER RANDOM NUMBERS IS OUTSIDE THE (0,1) INTERVAL') 12 FORMAT('***** ERROR--THE K PARAMETER FOR THE ', 1'BOREL-TANNER RANDOM NUMBERS IS NON-POSITIVE') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8) 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8) C C GENERATE N BOREL-TANNER DISTRIBUTION RANDOM NUMBERS C USING THE ALGORITHM GIVEN IN THE DEVROYE PAPER. C C I DON'T THINK I HAVE THIS QUITE RIGHT, SO JUST USE C INVERSE PPF METHOD FOR NOW. C CCCCC NTEMP=2 CCCCC C=1.0D0/DSQRT(2.0D0*PI) CCCCC DK=DBLE(IK) CCCCC DLAMB=DBLE(LAMBDA) C CCCCC DO100I=1,N C C110 CONTINUE CCCCC CALL UNIRAN(NTEMP,ISEED,U) CCCCC U1=DBLE(U(1)) C CCCCC V=(1.0D0 + 4.0D0*C*DSQRT(DK))*U1 C CCCCC IF(V.LE.1.0D0)THEN CCCCC X(I)=REAL(IK) CCCCC GOTO100 CCCCC ELSEIF(V.GT.1.0D0 .AND. V.LE.1.0D0+2.0D0*C*DSQRT(DK))THEN CCCCC Y=DK + 1.0D0 + (V - 1.0D0)**2/(4.0D0*C*C) CCCCC T=C/DSQRT(Y-1.0D0-DK) CCCCC ELSE CCCCC Y=DK + 1.0D0 + (2.0D0*DK*C/(1.0D0+4.0D0*C*DSQRT(DK)-V))**2 CCCCC T=DK*C/(Y-1.0D0-DK)**1.5 CCCCC ENDIF C CCCCC W=DBLE(U(2)) CCCCC WT=W*T CCCCC CALL BTACDF(REAL(Y),LAMBDA,K,CDF) CCCCC CALL BTAPDF(REAL(Y),LAMBDA,K,PDF) CCCCC CALL BTAPDF(REAL(Y),LAMBDA,K,PPF) CCCCC IF(WT.LT.DBLE(PPF))THEN CCCCC IY=INT(Y+0.5) CCCCC X(I)=REAL(IY) CCCCC GOTO100 CCCCC ELSE CCCCC GOTO110 CCCCC ENDIF C C 100 CONTINUE C CALL UNIRAN(N,ISEED,X) DO100I=1,N XTEMP=X(I) CALL BTAPPF(XTEMP,LAMBDA,K,PPF) X(I)=PPF 100 CONTINUE C 9999 CONTINUE C RETURN END SUBROUTINE BTPCF(X,N,FCN,LDF,NF,T,K,BCOEF,WORK) C***BEGIN PROLOGUE BTPCF C***REFER TO B2INK,B3INK C***ROUTINES CALLED BINTK,BNSLV C***END PROLOGUE BTPCF C C ----------------------------------------------------------------- C BTPCF COMPUTES B-SPLINE INTERPOLATION COEFFICIENTS FOR NF SETS C OF DATA STORED IN THE COLUMNS OF THE ARRAY FCN. THE B-SPLINE C COEFFICIENTS ARE STORED IN THE ROWS OF BCOEF HOWEVER. C EACH INTERPOLATION IS BASED ON THE N ABCISSA STORED IN THE C ARRAY X, AND THE N+K KNOTS STORED IN THE ARRAY T. THE ORDER C OF EACH INTERPOLATION IS K. THE WORK ARRAY MUST BE OF LENGTH C AT LEAST 2*K*(N+1). C ----------------------------------------------------------------- C C ------------ C DECLARATIONS C ------------ C C PARAMETERS C INTEGER * N, LDF, K REAL * X(N), FCN(LDF,NF), T(*), BCOEF(NF,N), WORK(*) C C LOCAL VARIABLES C INTEGER * I, J, K1, K2, IQ, IW C C --------------------------------------------- C CHECK FOR NULL INPUT AND PARTITION WORK ARRAY C --------------------------------------------- C C***FIRST EXECUTABLE STATEMENT IF (NF .LE. 0) GO TO 500 K1 = K - 1 K2 = K1 + K IQ = 1 + N IW = IQ + K2*N+1 C C ----------------------------- C COMPUTE B-SPLINE COEFFICIENTS C ----------------------------- C C C FIRST DATA SET C CALL BINTK(X,FCN,T,N,K,WORK,WORK(IQ),WORK(IW)) DO 20 I=1,N BCOEF(1,I) = WORK(I) 20 CONTINUE C C ALL REMAINING DATA SETS BY BACK-SUBSTITUTION C IF (NF .EQ. 1) GO TO 500 DO 100 J=2,NF DO 50 I=1,N WORK(I) = FCN(I,J) 50 CONTINUE CALL BNSLV(WORK(IQ),K2,N,K1,K1,WORK) DO 60 I=1,N BCOEF(J,I) = WORK(I) 60 CONTINUE 100 CONTINUE C C ---- C EXIT C ---- C 500 CONTINUE RETURN END FUNCTION BVALU(T,A,N,K,IDERIV,X,INBV,WORK) C***BEGIN PROLOGUE BVALU C***DATE WRITTEN 800901 (YYMMDD) C***REVISION DATE 820801 (YYMMDD) C***CATEGORY NO. E3,K6 C***KEYWORDS B-SPLINE,DATA FITTING,INTERPOLATION,SPLINE C***AUTHOR AMOS, D. E., (SNLA) C***PURPOSE Evaluates the B-representation of a B-spline at X for the C function value or any of its derivatives. C***DESCRIPTION C C Written by Carl de Boor and modified by D. E. Amos C C Reference C SIAM J. Numerical Analysis, 14, No. 3, June, 1977, pp.441-472. C C Abstract C BVALU is the BVALUE function of the reference. C C BVALU evaluates the B-representation (T,A,N,K) of a B-spline C at X for the function value on IDERIV = 0 or any of its C derivatives on IDERIV = 1,2,...,K-1. Right limiting values C (right derivatives) are returned except at the right end C point X=T(N+1) where left limiting values are computed. The C spline is defined on T(K) .LE. X .LE. T(N+1). BVALU returns C a fatal error message when X is outside of this interval. C C To compute left derivatives or left limiting values at a C knot T(I), replace N by I-1 and set X=T(I), I=K+1,N+1. C C BVALU calls INTRV C C Description of Arguments C Input C T - knot vector of length N+K C A - B-spline coefficient vector of length N C N - number of B-spline coefficients C N = sum of knot multiplicities-K C K - order of the B-spline, K .GE. 1 C IDERIV - order of the derivative, 0 .LE. IDERIV .LE. K-1 C IDERIV=0 returns the B-spline value C X - argument, T(K) .LE. X .LE. T(N+1) C INBV - an initialization parameter which must be set C to 1 the first time BVALU is called. C C Output C INBV - INBV contains information for efficient process- C ing after the initial call and INBV must not C be changed by the user. Distinct splines require C distinct INBV parameters. C WORK - work vector of length 3*K. C BVALU - value of the IDERIV-th derivative at X C C Error Conditions C An improper input is a fatal error C***REFERENCES C. DE BOOR, *PACKAGE FOR CALCULATING WITH B-SPLINES*, C SIAM JOURNAL ON NUMERICAL ANALYSIS, VOLUME 14, NO. 3, C JUNE 1977, PP. 441-472. C***ROUTINES CALLED INTRV,XERROR C***END PROLOGUE BVALU C C INTEGER I,IDERIV,IDERP1,IHI,IHMKMJ,ILO,IMK,IMKPJ, INBV, IPJ, 1 IP1, IP1MJ, J, JJ, J1, J2, K, KMIDER, KMJ, KM1, KPK, MFLAG, N REAL A, FKMJ, T, WORK, X C DIMENSION T(N+K), WORK(3*K) DIMENSION T(*), A(N), WORK(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C***FIRST EXECUTABLE STATEMENT BVALU BVALU = 0.0E0 IF(K.LT.1) GO TO 102 IF(N.LT.K) GO TO 101 IF(IDERIV.LT.0 .OR. IDERIV.GE.K) GO TO 110 KMIDER = K - IDERIV C C *** FIND *I* IN (K,N) SUCH THAT T(I) .LE. X .LT. T(I+1) C (OR, .LE. T(I+1) IF T(I) .LT. T(I+1) = T(N+1)). KM1 = K - 1 CALL INTRV(T, N+1, X, INBV, I, MFLAG) IF (X.LT.T(K)) GO TO 120 IF (MFLAG.EQ.0) GO TO 20 IF (X.GT.T(I)) GO TO 130 10 IF (I.EQ.K) GO TO 140 I = I - 1 IF (X.EQ.T(I)) GO TO 10 C C *** DIFFERENCE THE COEFFICIENTS *IDERIV* TIMES C WORK(I) = AJ(I), WORK(K+I) = DP(I), WORK(K+K+I) = DM(I), I=1.K C 20 IMK = I - K DO 30 J=1,K IMKPJ = IMK + J WORK(J) = A(IMKPJ) 30 CONTINUE IF (IDERIV.EQ.0) GO TO 60 DO 50 J=1,IDERIV KMJ = K - J FKMJ = FLOAT(KMJ) DO 40 JJ=1,KMJ IHI = I + JJ IHMKMJ = IHI - KMJ WORK(JJ) = (WORK(JJ+1)-WORK(JJ))/(T(IHI)-T(IHMKMJ))*FKMJ 40 CONTINUE 50 CONTINUE C C *** COMPUTE VALUE AT *X* IN (T(I),(T(I+1)) OF IDERIV-TH DERIVATIVE, C GIVEN ITS RELEVANT B-SPLINE COEFF. IN AJ(1),...,AJ(K-IDERIV). 60 IF (IDERIV.EQ.KM1) GO TO 100 IP1 = I + 1 KPK = K + K J1 = K + 1 J2 = KPK + 1 DO 70 J=1,KMIDER IPJ = I + J WORK(J1) = T(IPJ) - X IP1MJ = IP1 - J WORK(J2) = X - T(IP1MJ) J1 = J1 + 1 J2 = J2 + 1 70 CONTINUE IDERP1 = IDERIV + 1 DO 90 J=IDERP1,KM1 KMJ = K - J ILO = KMJ DO 80 JJ=1,KMJ WORK(JJ) = (WORK(JJ+1)*WORK(KPK+ILO)+WORK(JJ) 1 *WORK(K+JJ))/(WORK(KPK+ILO)+WORK(K+JJ)) ILO = ILO - 1 80 CONTINUE 90 CONTINUE 100 BVALU = WORK(1) RETURN C C 101 CONTINUE WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,901) CALL DPWRST('XXX','BUG ') 901 FORMAT('*****FROM BVALU, N DOES NOT SATISFY N.GE.K *****') RETURN 102 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,902) CALL DPWRST('XXX','BUG ') 902 FORMAT('*****FROM BVALU, K DOES NOT SATISFY K.GE.1 *****') RETURN 110 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,903) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,904) CALL DPWRST('XXX','BUG ') 903 FORMAT('*****FROM BVALU, IDERIV DOES NOT SATISFY') 904 FORMAT(' 0.LE.IDERIV.LT.K *****') RETURN 120 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,921) CALL DPWRST('XXX','BUG ') 921 FORMAT('*****FROM BVALU, X IS N0T GREATER THAN OR EQUAL TO T(K)') RETURN 130 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,931) CALL DPWRST('XXX','BUG ') 931 FORMAT('*****FROM BVALU, X IS NOT LESS THAN OR EQUAL TO T(N+1)') RETURN 140 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,941) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,942) CALL DPWRST('XXX','BUG ') 941 FORMAT('*****FROM BVALU, A LEFT LIMITING VALUE CANN0T BE') 942 FORMAT(' OBTAINED AT T(K) *****') RETURN END SUBROUTINE BVNCDF(X1,X2,CORR,CDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION C FUNCTION VALUE FOR THE BIVARIATE NORMAL (GAUSSIAN) C DISTRIBUTION WITH MEANS = 0 AND STANDARD DEVIATIONS = 1 C AND WITH A CORRELATION OF CORR. C F(X) = (1/SQRT(2*PI))*EXP(-X*X/2). C INPUT ARGUMENTS--X1 = THE SINGLE PRECISION VALUE AT WHICH C THE FIRST CUMULATIVE DISTRIBUTION C FUNCTION IS TO BE EVALUATED. C --X1 = THE SINGLE PRECISION VALUE AT WHICH C THE SECOND CUMULATIVE DISTRIBUTION C FUNCTION IS TO BE EVALUATED. C --CORR = THE CORRELATION BETWEEN THE 2 C DISTRIBUTIONS C OUTPUT ARGUMENTS--CDF = THE SINGLE PRECISION CUMULATIVE C DISTRIBUTION FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION C FUNCTION VALUE CDF. C PRINTING--NONE. C RESTRICTIONS--NONE. C OTHER DATAPAC SUBROUTINES NEEDED--NORCDF, THA. C FORTRAN LIBRARY SUBROUTINES NEEDED--SQRT. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--"A REMARK ON ALGORITHM AS76: AN INTEGRAL USEFUL IN C CALCULATING NONCENTRAL T AND BIVARIATE NORMAL C PROBABILITIES", BOYS, APPLIED STATISTICS, C --"TABLES FOR COMPUTING BIVARIATE NORMAL PROBABILITIES" C ANNALS OF MATHEMATICAL STATISTICS, OWEN, 1956 (1075- C 1090). C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--94.10 C ORIGINAL VERSION--OCTOBER 1994. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C DATA ONE/1.0/ DATA EPS/0.0000001/ C C-----START POINT----------------------------------------------------- C ACORR=ABS(CORR) IF(ACORR.GT.1.0)THEN WRITE(ICOUT,10) 10 FORMAT('***** ERROR--THIRD TERM TO BVNCDF IS OUTSIDE THE ', 1 'INTERVAL (-1,1). *****') CALL DPWRST('BUG','XXX') CDF=0.0 GOTO9999 ENDIF C C CORRELATION OF 1 IS A SPECIAL CASE C IF(ACORR.EQ.1.0)THEN TERM1=MIN(X1,X2) CALL NORCDF(TERM1,CDF) GOTO9999 ENDIF C XH=X1 XK=X2 IF(ABS(XH).LE.EPS .AND. ABS(XK).LE.EPS)THEN XH=EPS XK=-EPS ENDIF CALL NORCDF(XH,TERM1) CALL NORCDF(XK,TERM2) TERM3=1.0 IF(XH*XK.GT.0.0 .OR. (XH*XK.EQ.0.0.AND.XH+XK.GE.0.0))TERM3=0.0 A1=(XK-CORR*XH)/SQRT(1.0-CORR*CORR) A2=XH IF(A1.EQ.0.0.AND.A2.EQ.0.0)A1=0.000001 TERM4=THA(XH,ONE,A1,A2) A1=(XH-CORR*XK)/SQRT(1.0-CORR*CORR) A2=XK IF(A1.EQ.0.0.AND.A2.EQ.0.0)A1=0.000001 TERM5=THA(XK,ONE,A1,A2) CDF=0.5*(TERM1+TERM2-TERM3)-TERM4-TERM5 GOTO9999 C 9999 CONTINUE RETURN END SUBROUTINE BVNPDF(X1,X2,CORR,PDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY C FUNCTION VALUE FOR THE BIVARIATE NORMAL (GAUSSIAN) C DISTRIBUTION WITH MEANS = 0 AND STANDARD DEVIATIONS = 1 C AND WITH A CORRELATION OF CORR. USE THE FOLLOWING C FORMULA FROM ABRAMOWITZ AND STEGUM C F(X) = (1-P**2)**(-1/2)*NORPDF(X1) C *NORPDF((X2-P*X1)/(SQRT(1-P**2))) C WHERE NORPDF IS THE UNIVARIATE NORMAL PDF FUNCTION. C INPUT ARGUMENTS--X1 = THE SINGLE PRECISION VALUE AT WHICH C THE FIRST PROBABILTY DENSITY C FUNCTION IS TO BE EVALUATED. C --X1 = THE SINGLE PRECISION VALUE AT WHICH C THE SECOND PROBABILITY DENSITY C FUNCTION IS TO BE EVALUATED. C --CORR = THE CORRELATION BETWEEN THE 2 C DISTRIBUTIONS C OUTPUT ARGUMENTS--PDF = THE SINGLE PRECISION CUMULATIVE C DISTRIBUTION FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION C FUNCTION VALUE PDF. C PRINTING--NONE. C RESTRICTIONS--NONE. C OTHER DATAPAC SUBROUTINES NEEDED--NORPDF C FORTRAN LIBRARY SUBROUTINES NEEDED--SQRT. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--"AMS 55", ABRAMOWITZ AND STEGUM. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--95.9 C ORIGINAL VERSION--SEPTEMBER 1995. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ACORR=ABS(CORR) IF(ACORR.GT.1.0)THEN WRITE(ICOUT,10) 10 FORMAT('***** ERROR--THIRD TERM TO BVNPDF IS OUTSIDE THE ', 1 'INTERVAL (-1,1). *****') CALL DPWRST('BUG','XXX') PDF=0.0 GOTO9999 ENDIF C C CORRELATION OF 1 IS A SPECIAL CASE (UNDEFINED SINCE GET DIVISION C BY ZERO IN THE FORMULA). C IF(ACORR.EQ.1.0)THEN PDF=0.0 GOTO9999 ENDIF C TERM1=(1.0-ACORR*ACORR) TERM2=1.0/SQRT(TERM1) CALL NORPDF(X1,TERM3) ARG1=(X2-CORR*X1)/SQRT(1.0-CORR*CORR) CALL NORPDF(ARG1,TERM4) C PDF=TERM2*TERM3*TERM4 C 9999 CONTINUE RETURN END SUBROUTINE BWECDF(X,ASCAL1,GAMMA1,ALOC2,ASCAL2,GAMMA2,CDF,DCDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION C FUNCTION VALUE FOR THE BI-WEIBULL DISTRIBUTION AS C AS DEFINED IN THE THIRD EDITION OF "STATISTICAL C DISTRIBUTIONS", THIRD EDITION, EVANS, HASTINGS, AND C PEACOCK. THIS DISTRIBUTION IS RELATED TO, BUT SOMEWHAT C DIFFERENT THAN, A STRAIGHT MIXTURE OF TWO WEIBULL C DISTRIBUTIONS. THE CDF IS DEFINED AS: C F(X,S1,G1,L2,S2,G2) = C 1 - EXP[-(X/S1)**G1] 0 < X < L2 C 1 - EXP[-{(X/S1)**G1 + C [(X-L2)/S2]**G2}] X > L2 C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE AT C WHICH THE CUMULATIVE DISTRIBUTION C FUNCTION IS TO BE EVALUATED. C X SHOULD BE NON-NEGATIVE. C --ASCAL1 = SCALE PARAMETER (FIRST PART) C --GAMMA1 = SHAPE PARAMETER (FIRST PART) C --ALOC2 = LOCATION PARAMETER (SECOND PART) C --ASCAL2 = SCALE PARAMETER (SECOND PART) C --GAMMA2 = SHAPE PARAMETER (SECOND PART) C OUTPUT ARGUMENTS--CDF = THE SINGLE PRECISION CUMULATIVE C DISTRIBUTION FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION C FUNCTION VALUE CDF FOR THE WEIBULL DISTRIBUTION C WITH 5 SHAPE PARAMETERS C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--X SHOULD BE NON-NEGATIVE. C --GAMMA1,GAMMA2,ASCAL1,ASCAL2,ALOC2 SHOULD BE C POSITIVE. C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--EXP. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--HASTINGS AND PEACOCK, STATISTICAL C DISTRIBUTIONS--THIRD EDITION, C 2000, PP. 200-202. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--2002.5 C ORIGINAL VERSION--MAY 2002. C C--------------------------------------------------------------------- C DOUBLE PRECISION DS1 DOUBLE PRECISION DG1 DOUBLE PRECISION DL2 DOUBLE PRECISION DS2 DOUBLE PRECISION DG2 DOUBLE PRECISION DX DOUBLE PRECISION DCDF DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C DCDF=0.0D0 IF(ASCAL1.LE.0.0)THEN WRITE(ICOUT,5) 5 FORMAT('***** FATAL ERROR--THE SCALE(1) PARAMETER FOR ', 1'THE BWECDF SUBROUTINE IS NON-POSITIVE *****') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)ASCAL1 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') CALL DPWRST('XXX','BUG ') CDF=0.0 GOTO9999 ENDIF IF(GAMMA1.LE.0.0)THEN WRITE(ICOUT,15) 15 FORMAT('***** FATAL ERROR--THE GAMMA(1) SHAPE PARAMETER FOR ', 1'THE BWECDF SUBROUTINE IS NON-POSITIVE *****') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)GAMMA1 CALL DPWRST('XXX','BUG ') CDF=0.0 GOTO9999 ENDIF IF(ASCAL2.LE.0.0)THEN WRITE(ICOUT,25) 25 FORMAT('***** FATAL ERROR--THE SCALE(2) PARAMETER FOR ', 1'THE BWECDF SUBROUTINE IS NON-POSITIVE *****') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)ASCAL2 CALL DPWRST('XXX','BUG ') CDF=0.0 GOTO9999 ENDIF IF(GAMMA2.LE.0.0)THEN WRITE(ICOUT,35) 35 FORMAT('***** FATAL ERROR--THE GAMMA(2) SHAPE PARAMETER FOR ', 1'THE BWECDF SUBROUTINE IS NON-POSITIVE *****') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)GAMMA2 CALL DPWRST('XXX','BUG ') CDF=0.0 GOTO9999 ENDIF IF(ALOC2.LE.0.0)THEN WRITE(ICOUT,45) 45 FORMAT('***** FATAL ERROR--THE LOCATION(2) PARAMETER FOR ', 1'THE BWECDF SUBROUTINE IS NON-POSITIVE *****') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)ALOC2 CALL DPWRST('XXX','BUG ') CDF=0.0 GOTO9999 ENDIF C 90 CONTINUE IF(X.LE.0.0)THEN CDF=0.0 GOTO9999 ENDIF C DX=DBLE(X) DG1=DBLE(GAMMA1) DS1=DBLE(ASCAL1) DG2=DBLE(GAMMA2) DS2=DBLE(ASCAL2) DL2=DBLE(ALOC2) C IF(DX.LE.DL2)THEN DCDF=DEXP(-(DX/DS1)**DG1) ELSE DTERM1=(DX/DS1)**DG1 DTERM2=((DX-DL2)/DS2)**DG2 DCDF=DEXP(-(DTERM1 + DTERM2)) ENDIF DCDF=1.0D0 - DCDF CDF=REAL(DCDF) C 9999 CONTINUE RETURN END SUBROUTINE BWEHAZ(X,ASCAL1,GAMMA1,ALOC2,ASCAL2,GAMMA2,HAZ,DHAZ) C C PURPOSE--THIS SUBROUTINE COMPUTES THE HAZARD C FUNCTION VALUE FOR THE BI-WEIBULL DISTRIBUTION AS C AS DEFINED IN THE THIRD EDITION OF "STATISTICAL C DISTRIBUTIONS", THIRD EDITION, EVANS, HASTINGS, AND C PEACOCK. THIS DISTRIBUTION IS RELATED TO, BUT SOMEWHAT C DIFFERENT THAN, A STRAIGHT MIXTURE OF TWO WEIBULL C DISTRIBUTIONS. THE HAZARD FUNCTION IS DEFINED AS: C h(X,S1,G1,L2,S2,G2) = C (1/S1)*G1*(X/S1)**(G1-1) 0 < X < L2 C (1/S1)*G1*(X/S1)**(G1-1) + C (G2/S2)*((X-L2)/S2)**(G2-1) X >= L2 C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE AT C WHICH THE HAZARD C FUNCTION IS TO BE EVALUATED. C X SHOULD BE NON-NEGATIVE. C --ASCAL1 = SCALE PARAMETER (FIRST PART) C --GAMMA1 = SHAPE PARAMETER (FIRST PART) C --ALOC2 = LOCATION PARAMETER (SECOND PART) C --ASCAL2 = SCALE PARAMETER (SECOND PART) C --GAMMA2 = SHAPE PARAMETER (SECOND PART) C OUTPUT ARGUMENTS--HAZ = THE SINGLE PRECISION HAZARD C FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION HAZARD C FUNCTION VALUE HAZ FOR THE WEIBULL DISTRIBUTION C WITH 5 SHAPE PARAMETERS C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--X SHOULD BE NON-NEGATIVE. C --GAMMA1,GAMMA2,ASCAL1,ASCAL2,ALOC2 SHOULD BE C POSITIVE. C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--EXP. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--HASTINGS AND PEACOCK, STATISTICAL C DISTRIBUTIONS--THIRD EDITION, C 2000, PP. 200-202. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--2002.5 C ORIGINAL VERSION--MAY 2002. C C--------------------------------------------------------------------- C DOUBLE PRECISION DS1 DOUBLE PRECISION DG1 DOUBLE PRECISION DL2 DOUBLE PRECISION DS2 DOUBLE PRECISION DG2 DOUBLE PRECISION DX DOUBLE PRECISION DHAZ DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C DHAZ=0.0D0 IF(ASCAL1.LE.0.0)THEN WRITE(ICOUT,5) 5 FORMAT('***** FATAL ERROR--THE SCALE(1) PARAMETER FOR ', 1'THE BWEHAZ SUBROUTINE IS NON-POSITIVE *****') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)ASCAL1 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') CALL DPWRST('XXX','BUG ') HAZ=0.0 GOTO9999 ENDIF IF(GAMMA1.LE.0.0)THEN WRITE(ICOUT,15) 15 FORMAT('***** FATAL ERROR--THE GAMMA(1) SHAPE PARAMETER FOR ', 1'THE BWEHAZ SUBROUTINE IS NON-POSITIVE *****') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)GAMMA1 CALL DPWRST('XXX','BUG ') HAZ=0.0 GOTO9999 ENDIF IF(ASCAL2.LE.0.0)THEN WRITE(ICOUT,25) 25 FORMAT('***** FATAL ERROR--THE SCALE(2) PARAMETER FOR ', 1'THE BWEHAZ SUBROUTINE IS NON-POSITIVE *****') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)ASCAL2 CALL DPWRST('XXX','BUG ') HAZ=0.0 GOTO9999 ENDIF IF(GAMMA2.LE.0.0)THEN WRITE(ICOUT,35) 35 FORMAT('***** FATAL ERROR--THE GAMMA(2) SHAPE PARAMETER FOR ', 1'THE BWEHAZ SUBROUTINE IS NON-POSITIVE *****') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)GAMMA2 CALL DPWRST('XXX','BUG ') HAZ=0.0 GOTO9999 ENDIF IF(ALOC2.LE.0.0)THEN WRITE(ICOUT,45) 45 FORMAT('***** FATAL ERROR--THE LOCATION(2) PARAMETER FOR ', 1'THE BWEHAZ SUBROUTINE IS NON-POSITIVE *****') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)ALOC2 CALL DPWRST('XXX','BUG ') HAZ=0.0 GOTO9999 ENDIF C 90 CONTINUE IF(X.LE.0.0)THEN HAZ=0.0 GOTO9999 ENDIF C DX=DBLE(X) DG1=DBLE(GAMMA1) DS1=DBLE(ASCAL1) DG2=DBLE(GAMMA2) DS2=DBLE(ASCAL2) DL2=DBLE(ALOC2) C IF(DX.LE.DL2)THEN DHAZ=(DG1/DS1)*(DX/DS1)**(DG1-1.0D0) ELSE DTERM1=(DG1/DS1)*(DX/DS1)**(DG1-1.0D0) DTERM2=(DG2/DS2)*((DX-DL2)/DS2)**(DG2-1.0D0) DHAZ=DTERM1 + DTERM2 ENDIF HAZ=REAL(DHAZ) C 9999 CONTINUE RETURN END SUBROUTINE BWEPPF(P,ASCAL1,GAMMA1,ALOC2,ASCAL2,GAMMA2,PPF,DPPF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT C FUNCTION VALUE FOR THE BI-WEIBULL DISTRIBUTION AS C AS DEFINED IN THE THIRD EDITION OF "STATISTICAL C DISTRIBUTIONS", THIRD EDITION, EVANS, HASTINGS, AND C PEACOCK. THIS DISTRIBUTION IS RELATED TO, BUT SOMEWHAT C DIFFERENT THAN, A STRAIGHT MIXTURE OF TWO WEIBULL C DISTRIBUTIONS. THE CDF IS DEFINED AS: C F(X,S1,G1,L2,S2,G2) = C 1 - EXP[-(X/S1)**G1] 0 < X < L2 C 1 - EXP[-{(X/S1)**G1 + C [(X-L2)/S2]**G2}] X > L2 C THE PERCENT POINT FUNCTION IS CALCULATED ANALYTICALLY C FOR CASE WHEN X < L2. IT IS CALCULATED NUMERICALLY C FOR X > L2. C INPUT ARGUMENTS--P = THE SINGLE PRECISION VALUE AT C WHICH THE PERCENT POINT FUNCTION C FUNCTION IS TO BE EVALUATED. C P SHOULD BE IN THE INTERVAL [0,1). C --ASCAL1 = SCALE PARAMETER (FIRST PART) C --GAMMA1 = SHAPE PARAMETER (FIRST PART) C --ALOC2 = LOCATION PARAMETER (SECOND PART) C --ASCAL2 = SCALE PARAMETER (SECOND PART) C --GAMMA2 = SHAPE PARAMETER (SECOND PART) C OUTPUT ARGUMENTS--CDF = THE SINGLE PRECISION PERCENT POINT C FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION PERCENT POINT C FUNCTION VALUE PPF FOR THE BI-WEIBULL DISTRIBUTION C WITH 5 SHAPE PARAMETERS C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--0<= P < 1 C --GAMMA1,GAMMA2,ASCAL1,ASCAL2,ALOC2 SHOULD BE C POSITIVE. C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--EXP. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--HASTINGS AND PEACOCK, STATISTICAL C DISTRIBUTIONS--THIRD EDITION, C 2000, PP. 200-202. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--2002.5 C ORIGINAL VERSION--MAY 2002. C C--------------------------------------------------------------------- C DOUBLE PRECISION DS1 DOUBLE PRECISION DG1 DOUBLE PRECISION DL2 DOUBLE PRECISION DS2 DOUBLE PRECISION DG2 DOUBLE PRECISION DX DOUBLE PRECISION DP DOUBLE PRECISION DPPF DOUBLE PRECISION DCDF DOUBLE PRECISION DCDFL DOUBLE PRECISION DCDFR DOUBLE PRECISION DXINC DOUBLE PRECISION DXL DOUBLE PRECISION DXR DOUBLE PRECISION DFXL DOUBLE PRECISION DFXR DOUBLE PRECISION DP1 DOUBLE PRECISION DFCS DOUBLE PRECISION DXRML DOUBLE PRECISION DSIG DOUBLE PRECISION DEPS C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C DATA DEPS /0.0000001/ DATA DSIG /1.0D-7/ DATA MAXIT /2000/ C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(P.LT.0.0 .OR. P.GE.1.0)THEN WRITE(ICOUT,1) 1 FORMAT('***** FATAL ERROR--THE INPUT ARGUMENT FOR THE ', 1'THE BWEPPF SUBROUTINE IS OUTSIDE THE INTERVAL [0,1).') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)P CALL DPWRST('XXX','BUG ') PPF=0.0 DPPF=0.0D0 GOTO9999 ENDIF IF(ASCAL1.LE.0.0)THEN WRITE(ICOUT,5) 5 FORMAT('***** FATAL ERROR--THE SCALE(1) PARAMETER FOR ', 1'THE BWEPPF SUBROUTINE IS NON-POSITIVE *****') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)ASCAL1 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') CALL DPWRST('XXX','BUG ') PPF=0.0 DPPF=0.0D0 GOTO9999 ENDIF IF(GAMMA1.LE.0.0)THEN WRITE(ICOUT,15) 15 FORMAT('***** FATAL ERROR--THE GAMMA(1) SHAPE PARAMETER FOR ', 1'THE BWEPPF SUBROUTINE IS NON-POSITIVE *****') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)GAMMA1 CALL DPWRST('XXX','BUG ') PPF=0.0 DPPF=0.0D0 GOTO9999 ENDIF IF(ASCAL2.LE.0.0)THEN WRITE(ICOUT,25) 25 FORMAT('***** FATAL ERROR--THE SCALE(2) PARAMETER FOR ', 1'THE BWEPPF SUBROUTINE IS NON-POSITIVE *****') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)ASCAL2 CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9999 ENDIF IF(GAMMA2.LE.0.0)THEN WRITE(ICOUT,35) 35 FORMAT('***** FATAL ERROR--THE GAMMA(2) SHAPE PARAMETER FOR ', 1'THE BWEPPF SUBROUTINE IS NON-POSITIVE *****') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)GAMMA2 CALL DPWRST('XXX','BUG ') PPF=0.0 DPPF=0.0D0 GOTO9999 ENDIF IF(ALOC2.LE.0.0)THEN WRITE(ICOUT,45) 45 FORMAT('***** FATAL ERROR--THE LOCATION(2) PARAMETER FOR ', 1'THE BWEPPF SUBROUTINE IS NON-POSITIVE *****') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)ALOC2 CALL DPWRST('XXX','BUG ') PPF=0.0 DPPF=0.0D0 GOTO9999 ENDIF C 90 CONTINUE IF(P.EQ.0.0)THEN PPF=0.0 DPPF=0.0D0 GOTO9999 ENDIF C DP=DBLE(P) DG1=DBLE(GAMMA1) DS1=DBLE(ASCAL1) DG2=DBLE(GAMMA2) DS2=DBLE(ASCAL2) DL2=DBLE(ALOC2) C C CHECK IF P <= BWECDF(LOC2) C CALL BWECDF(ALOC2,ASCAL1,GAMMA1,ALOC2,ASCAL2,GAMMA2,CDF,DCDF) IF(DP.LE.DCDF)THEN DPPF=(DLOG(1.0D0/(1.0D0-DP)))**(1.0D0/DG1) DPPF=DS1*DPPF PPF=REAL(DPPF) GOTO9999 ENDIF C C CASE WHERE PPF CALCULATED NUMERICALLY C C C FIND BRACKETING INTERVAL. C DXL=DL2 DXINC=DS2 IF(DXINC.LT.1.0D0)DXINC=1.0D0 ICOUNT=0 MAXCNT=10000 C 91 CONTINUE DXR=DXL+DXINC IF(DXL.LE.DL2)DXL=DL2 IF(DXR.LE.DL2)DXR=DXL+DXINC XL=REAL(DXL) XR=REAL(DXR) CALL BWECDF(XL,ASCAL1,GAMMA1,ALOC2,ASCAL2,GAMMA2,CDFL,DCDFL) CALL BWECDF(XR,ASCAL1,GAMMA1,ALOC2,ASCAL2,GAMMA2,CDFR,DCDFR) IF(DCDFL.LT.DP .AND. DCDFR.LT.DP)THEN DXL=DXR ELSEIF(DCDFL.GT.DP .AND. DCDFR.GT.DP)THEN DXL=DXL-DXINC ELSE GOTO99 ENDIF ICOUNT=ICOUNT+1 IF(ICOUNT.GT.MAXCNT)THEN WRITE(ICOUT,96) CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9999 ENDIF 96 FORMAT('***** FATAL ERROR--BWEPPF UNABLE TO FIND BRACKETING ', * 'INTERVAL. *****') GOTO91 C C C BISECTION METHOD C 99 CONTINUE IC = 0 DFXL = -DP DFXR = 1.0D0 - DP 105 CONTINUE DX = (DXL+DXR)*0.5D0 X=REAL(DX) CALL BWECDF(X,ASCAL1,GAMMA1,ALOC2,ASCAL2,GAMMA2,CDF,DCDF) DP1=DCDF DPPF=DX PPF=REAL(DPPF) DFCS = DP1 - DP IF(DFCS*DFXL.GT.0.0D0)GOTO110 DXR = DX DFXR = DFCS GOTO115 110 CONTINUE DXL = DX DFXL = DFCS 115 CONTINUE DXRML = DXR - DXL IF(DXRML.LE.DSIG .AND. DABS(DFCS).LE.DEPS)GOTO9999 IC = IC + 1 IF(IC.LE.MAXIT)GOTO105 WRITE(ICOUT,130) CALL DPWRST('XXX','BUG ') 130 FORMAT('***** FATAL ERROR--BWEPPF ROUTINE DID NOT CONVERGE. ***') GOTO9999 C 9999 CONTINUE RETURN END SUBROUTINE BWERAN(N,ASCAL1,GAMMA1,ALOC2,ASCAL2,GAMMA2,ISEED,X) C C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N C FROM THE BIWEIBULL DISTRIBUTION C WITH 5 SHAPE PARAMETERS. C INPUT ARGUMENTS--N = THE DESIRED INTEGER NUMBER C OF RANDOM NUMBERS TO BE C GENERATED. C --ASCAL1 = THE SINGLE PRECISION VALUE OF THE C SCALE (1) PARAMETER. C --GAMMA1 = THE SINGLE PRECISION VALUE OF THE C SHAPE (1) PARAMETER. C --ALOC2 = THE SINGLE PRECISION VALUE OF THE C LOCATION (2) PARAMETER. C --ASCAL2 = THE SINGLE PRECISION VALUE OF THE C SCALE (2) PARAMETER. C --GAMMA2 = THE SINGLE PRECISION VALUE OF THE C SHAPE (2) PARAMETER. C OUTPUT ARGUMENTS--X = A SINGLE PRECISION VECTOR C (OF DIMENSION AT LEAST N) C INTO WHICH THE GENERATED C RANDOM SAMPLE WILL BE PLACED. C OUTPUT--A RANDOM SAMPLE OF SIZE N C FROM THE BIWEIBULL DISTRIBUTION C WITH 5 SHAPE PARAMETERS. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C --5 SHAPE PARAMETERS SHOULD BE POSITIVE. C OTHER DATAPAC SUBROUTINES NEEDED--UNIRAN. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--2002.5 C ORIGINAL VERSION--MAY 2002. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DIMENSION X(*) DOUBLE PRECISION DTEMP C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(ASCAL1.LE.0.0)THEN WRITE(ICOUT,5) 5 FORMAT('***** FATAL ERROR--THE SCALE(1) PARAMETER FOR ', 1'THE BWERAN SUBROUTINE IS NON-POSITIVE *****') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)ASCAL1 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF IF(GAMMA1.LE.0.0)THEN WRITE(ICOUT,15) 15 FORMAT('***** FATAL ERROR--THE GAMMA(1) SHAPE PARAMETER FOR ', 1'THE BWERAN SUBROUTINE IS NON-POSITIVE *****') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)GAMMA1 CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF IF(ASCAL2.LE.0.0)THEN WRITE(ICOUT,25) 25 FORMAT('***** FATAL ERROR--THE SCALE(2) PARAMETER FOR ', 1'THE BWERAN SUBROUTINE IS NON-POSITIVE *****') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)ASCAL2 CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF IF(GAMMA2.LE.0.0)THEN WRITE(ICOUT,35) 35 FORMAT('***** FATAL ERROR--THE GAMMA(2) SHAPE PARAMETER FOR ', 1'THE BWERAN SUBROUTINE IS NON-POSITIVE *****') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)GAMMA2 CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF IF(ALOC2.LE.0.0)THEN WRITE(ICOUT,45) 45 FORMAT('***** FATAL ERROR--THE LOCATION(2) PARAMETER FOR ', 1'THE BWERAN SUBROUTINE IS NON-POSITIVE *****') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)ALOC2 CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF C C GENERATE N UNIFORM (0,1) RANDOM NUMBERS; C CALL UNIRAN(N,ISEED,X) C C GENERATE N BIWEIBULL DISTRIBUTION RANDOM C NUMBERS USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD. C DO100I=1,N CALL BWEPPF(X(I),ASCAL1,GAMMA1,ALOC2,ASCAL2,GAMMA2, 1 XTEMP,DTEMP) X(I)=XTEMP 100 CONTINUE C 9999 CONTINUE RETURN END DOUBLE PRECISION FUNCTION BVN ( LOWER, UPPER, INFIN, CORREL ) * * A function for computing bivariate normal probabilities. * * Parameters * * LOWER REAL, array of lower integration limits. * UPPER REAL, array of upper integration limits. * INFIN INTEGER, array of integration limits flags: * if INFIN(I) = 0, Ith limits are (-infinity, UPPER(I)]; * if INFIN(I) = 1, Ith limits are [LOWER(I), infinity); * if INFIN(I) = 2, Ith limits are [LOWER(I), UPPER(I)]. * CORREL REAL, correlation coefficient. * DOUBLE PRECISION LOWER(*), UPPER(*), CORREL, BVNU INTEGER INFIN(*) IF ( INFIN(1) .EQ. 2 .AND. INFIN(2) .EQ. 2 ) THEN BVN = BVNU ( LOWER(1), LOWER(2), CORREL ) + - BVNU ( UPPER(1), LOWER(2), CORREL ) + - BVNU ( LOWER(1), UPPER(2), CORREL ) + + BVNU ( UPPER(1), UPPER(2), CORREL ) ELSE IF ( INFIN(1) .EQ. 2 .AND. INFIN(2) .EQ. 1 ) THEN BVN = BVNU ( LOWER(1), LOWER(2), CORREL ) + - BVNU ( UPPER(1), LOWER(2), CORREL ) ELSE IF ( INFIN(1) .EQ. 1 .AND. INFIN(2) .EQ. 2 ) THEN BVN = BVNU ( LOWER(1), LOWER(2), CORREL ) + - BVNU ( LOWER(1), UPPER(2), CORREL ) ELSE IF ( INFIN(1) .EQ. 2 .AND. INFIN(2) .EQ. 0 ) THEN BVN = BVNU ( -UPPER(1), -UPPER(2), CORREL ) + - BVNU ( -LOWER(1), -UPPER(2), CORREL ) ELSE IF ( INFIN(1) .EQ. 0 .AND. INFIN(2) .EQ. 2 ) THEN BVN = BVNU ( -UPPER(1), -UPPER(2), CORREL ) + - BVNU ( -UPPER(1), -LOWER(2), CORREL ) ELSE IF ( INFIN(1) .EQ. 1 .AND. INFIN(2) .EQ. 0 ) THEN BVN = BVNU ( LOWER(1), -UPPER(2), -CORREL ) ELSE IF ( INFIN(1) .EQ. 0 .AND. INFIN(2) .EQ. 1 ) THEN BVN = BVNU ( -UPPER(1), LOWER(2), -CORREL ) ELSE IF ( INFIN(1) .EQ. 1 .AND. INFIN(2) .EQ. 1 ) THEN BVN = BVNU ( LOWER(1), LOWER(2), CORREL ) ELSE IF ( INFIN(1) .EQ. 0 .AND. INFIN(2) .EQ. 0 ) THEN BVN = BVNU ( -UPPER(1), -UPPER(2), CORREL ) END IF C RETURN END DOUBLE PRECISION FUNCTION BVNU( SH, SK, R ) * * A function for computing bivariate normal probabilities. * * Yihong Ge * Department of Computer Science and Electrical Engineering * Washington State University * Pullman, WA 99164-2752 * Email : yge@eecs.wsu.edu * and * Alan Genz * Department of Mathematics * Washington State University * Pullman, WA 99164-3113 * Email : alangenz@wsu.edu * * BVN - calculate the probability that X is larger than SH and Y is * larger than SK. * * Parameters * * SH REAL, integration limit * SK REAL, integration limit * R REAL, correlation coefficient * LG INTEGER, number of Gauss Rule Points and Weights * DOUBLE PRECISION BVN, SH, SK, R, ZERO, TWOPI INTEGER I, LG, NG PARAMETER ( ZERO = 0.0D0, TWOPI = 6.2831 85307 179586D0 ) DOUBLE PRECISION X(10,3), W(10,3), AS, A, B, C, D, RS, XS DOUBLE PRECISION PHI, SN, ASR, H, K, BS, HS, HK * Gauss Legendre Points and Weights, N = 6 DATA ( W(I,1), X(I,1), I = 1,3) / & 0.1713244923791705D+00,-0.9324695142031522D+00, & 0.3607615730481384D+00,-0.6612093864662647D+00, & 0.4679139345726904D+00,-0.2386191860831970D+00/ * Gauss Legendre Points and Weights, N = 12 DATA ( W(I,2), X(I,2), I = 1,6) / & 0.4717533638651177D-01,-0.9815606342467191D+00, & 0.1069393259953183D+00,-0.9041172563704750D+00, & 0.1600783285433464D+00,-0.7699026741943050D+00, & 0.2031674267230659D+00,-0.5873179542866171D+00, & 0.2334925365383547D+00,-0.3678314989981802D+00, & 0.2491470458134029D+00,-0.1252334085114692D+00/ * Gauss Legendre Points and Weights, N = 20 DATA ( W(I,3), X(I,3), I = 1,10) / & 0.1761400713915212D-01,-0.9931285991850949D+00, & 0.4060142980038694D-01,-0.9639719272779138D+00, & 0.6267204833410906D-01,-0.9122344282513259D+00, & 0.8327674157670475D-01,-0.8391169718222188D+00, & 0.1019301198172404D+00,-0.7463319064601508D+00, & 0.1181945319615184D+00,-0.6360536807265150D+00, & 0.1316886384491766D+00,-0.5108670019508271D+00, & 0.1420961093183821D+00,-0.3737060887154196D+00, & 0.1491729864726037D+00,-0.2277858511416451D+00, & 0.1527533871307259D+00,-0.7652652113349733D-01/ SAVE X, W IF ( ABS(R) .LT. 0.3 ) THEN NG = 1 LG = 3 ELSE IF ( ABS(R) .LT. 0.75 ) THEN NG = 2 LG = 6 ELSE NG = 3 LG = 10 ENDIF H = SH K = SK HK = H*K BVN = 0.0D0 IF ( ABS(R) .LT. 0.925D0 ) THEN HS = ( H*H + K*K )/2.0D0 ASR = ASIN(R) DO 10 I = 1, LG SN = SIN(ASR*( X(I,NG)+1.0D0 )/2.0D0) BVN = BVN + W(I,NG)*EXP( ( SN*HK - HS )/(1.0D0 - SN*SN)) SN = SIN(ASR*(-X(I,NG)+1.0D0 )/2.0D0) BVN = BVN + W(I,NG)*EXP( ( SN*HK - HS )/(1.0D0 - SN*SN)) 10 CONTINUE BVN = BVN*ASR/(2.0D0*TWOPI) + PHI(-H)*PHI(-K) ELSE IF ( R .LT. 0.0D0 ) THEN K = -K HK = -HK ENDIF IF ( ABS(R) .LT. 1.0D0 ) THEN AS = ( 1.0D0 - R )*( 1.0D0 + R ) A = SQRT(AS) BS = ( H - K )**2 C = ( 4.0D0 - HK )/8.0D0 D = ( 12.0D0 - HK )/16.0D0 BVN = A*EXP( -(BS/AS + HK)/2.0D0 ) + *( 1.0D0 - C*(BS - AS)*(1.0D0 - D*BS/5)/3.0D0 + + C*D*AS*AS/5.0D0 ) IF ( HK .GT. -160.0D0 ) THEN B = SQRT(BS) BVN = BVN - EXP(-HK/2.0D0)*SQRT(TWOPI)*PHI(-B/A)*B + *( 1.0D0 - C*BS*( 1.0D0 - D*BS/5.0D0 )/3.0D0 ) ENDIF A = A/2.0D0 DO 20 I = 1, LG XS = ( A*(X(I,NG)+1) )**2 RS = SQRT( 1.0D0 - XS ) BVN = BVN + A*W(I,NG)* + ( EXP( -BS/(2.0D0*XS) - HK/(1.0D0+RS) )/RS + - EXP( -(BS/XS+HK)/2.0D0 )* + ( 1.0D0 + C*XS*( 1.0D0 + D*XS ) ) ) XS = AS*(-X(I,NG)+1.0D0)**2/4.0D0 RS = SQRT( 1.0D0 - XS ) BVN = BVN + A*W(I,NG)*EXP( -(BS/XS + HK)/2.0D0 ) + *( EXP( -HK*(1.0D0-RS)/(2.0D0*(1.0D0+RS)))/RS + - ( 1.0D0 + C*XS*( 1.0D0 + D*XS ) ) ) 20 CONTINUE BVN = -BVN/TWOPI ENDIF IF (R .GT. 0.0D0) BVN = BVN + PHI( -MAX( H, K ) ) IF (R .LT. 0.0D0) BVN = -BVN + MAX( ZERO, PHI(-H) - PHI(-K)) ENDIF BVNU = BVN C RETURN END