xref: /dports/graphics/dataplot/dataplot-2c1b27601a3b7523449de612613eadeead9a8f70/src/dp3.F

      SUBROUTINE AAD(X,N,IWRITE,XTEMP,MAXNXT,XAAD,ICASE,IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE SAMPLE AVERAGE ABSOLUTE
C              DEVIATION (WITH DENOMINATOR N) OF THE DATA IN THE INPUT
C              VECTOR X.  NOTE THAT THERE ARE TWO VARIATIONS OF THIS
C              STATISTIC:
C
C              1) THE SAMPLE AVERAGE ABSOLUTE DEVIATION = (THE SUM OF
C                 THE ABSOLUTE DEVIATIONS ABOUT THE SAMPLE MEDIAN) / N).
C
C              2) THE SAMPLE AVERAGE ABSOLUTE DEVIATION = (THE SUM OF
C                 THE ABSOLUTE DEVIATIONS ABOUT THE SAMPLE MEAN) / N).
C
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                     --ICASE  = EITHER "MEAN" OR "MEDI" TO SPECIFY
C                                WHICH OF THE TWO CASES TO COMPUTE.
C     OUTPUT ARGUMENTS--XAAD   = THE SINGLE PRECISION VALUE OF THE
C                                COMPUTED SAMPLE AVERAGE ABSOLUTE
C                                DEVIATION.
C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE SAMPLE AVERAGE
C             ABSOLUTE DEVIATION (WITH DENOMINATOR N).
C     OTHER DATAPAC   SUBROUTINES NEEDED--MEAN, 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                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1966)
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     UPDATED         --JULY      2014. ADD ICASE ARGUMRNT TO ALLOW
C                                       EITHER DEVIATIONS FROM THE
C                                       MEAN OR FROM THE MEDIAN
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 ICASE
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 IWRIT2
      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
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='AAD '
      ISUBN2='    '
C
      IERROR='NO'
C
      DMED=0.0D0
      DDEL=0.0D0
C
      IF(IBUGA3.EQ.'ON')THEN
        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,ICASE,N
   52   FORMAT('IBUGA3,ICASE,N = ',2(A4,2X),I8)
        CALL DPWRST('XXX','BUG ')
        DO55I=1,N
          WRITE(ICOUT,56)I,X(I)
   56     FORMAT('I,X(I) = ',I8,G15.7)
          CALL DPWRST('XXX','BUG ')
   55   CONTINUE
      ENDIF
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.LT.1)THEN
        IERROR='YES'
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,111)
  111   FORMAT('***** ERROR IN AVERAGE ABSOLUTE DEVIATION--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,112)
  112   FORMAT('      THE NUMBER OF OBSERVATIONS FOR THE RESPONSE')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,113)
  113   FORMAT('      VARIABLE IS LESS THAN 1.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,117)N
  117   FORMAT('      THE NUMBER OF OBSERVATIONS HERE = ',I8,'.')
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(N.EQ.1)THEN
        XAAD=0.0
        GOTO9000
      ENDIF
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)
  136 FORMAT('***** WARNING IN AVERAGE ABSOLUTE DEVIATION--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,137)HOLD
  137 FORMAT('***** THE RESPONSE VARIABLE HAS ALL ELEMENTS = ',G15.7)
      CALL DPWRST('XXX','BUG ')
      XAAD=0.0
      GOTO9000
  139 CONTINUE
C
C               ***********************************************
C               **  STEP 2--                                 **
C               **  COMPUTE THE AVERAGE ABSOLUTE DEVIATION.  **
C               ***********************************************
C
      IWRIT2='OFF'
      IF(ICASE.EQ.'MEDI')THEN
        CALL MEDIAN(X,N,IWRIT2,XTEMP,MAXNXT,XMED,IBUGA3,IERROR)
        DMED=XMED
      ELSE
        CALL MEAN(X,N,IWRIT2,XMED,IBUGA3,IERROR)
        DMED=XMED
      ENDIF
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
C     BUG FIX: AUGUST, 1987
CCCCC XAAD=DDEL/DN
C
      XAAD=DSUM/DN
C
C  END BUG FIX
C
C               *******************************
C               **  STEP 3--                 **
C               **  WRITE OUT A LINE         **
C               **  OF SUMMARY INFORMATION.  **
C               *******************************
C
      IF(IFEEDB.EQ.'ON' .AND. IWRITE.EQ.'ON')THEN
        IF(ICASE.EQ.'MEDI')THEN
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,813)N,XAAD
  813     FORMAT('THE AVERAGE ABSOLUTE DEVIATION (FROM THE MEDIAN) OF ',
     1           I8,' THE OBSERVATIONS = ',G15.7)
          CALL DPWRST('XXX','BUG ')
        ELSE
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,811)N,XAAD
  811     FORMAT('THE AVERAGE ABSOLUTE DEVIATION (FROM THE MEAN) OF ',
     1           I8,' THE OBSERVATIONS = ',G15.7)
          CALL DPWRST('XXX','BUG ')
        ENDIF
      ENDIF
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'ON')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9011)
 9011   FORMAT('***** AT THE END       OF AAD--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9012)IERROR,DMED,XAAD
 9012   FORMAT('IERROR,DMED,XAAD = ',A4,2X,2G15.7)
        CALL DPWRST('XXX','BUG ')
      ENDIF
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'
      INCLUDE 'DPCOP2.INC'
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
      XLOW=0.0
      XLOW1=0.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'
      INCLUDE 'DPCOP2.INC'
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
      XLOW=0.0D0
      XLOW1=0.0D0
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'
      INCLUDE 'DPCOP2.INC'
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
      XLOW=0.0
      XLOW1=0.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
C
      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 = INT(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*INT((MESH(DIVAXN)+1.0D0)/MESH(DIVAXN))
     &        .LE. MINCLS ) THEN
            RGNCLS = RGNCLS*INT((MESH(DIVAXN)+1.0D0)/MESH(DIVAXN))
            NWRGNS = NWRGNS*INT((MESH(DIVAXN)+1.0D0)/MESH(DIVAXN))
            MESH(DIVAXN) = MESH(DIVAXN) + 1.0D0
            WIDTH(DIVAXN) = 1.0D0/( 2.0D0*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.0D0
 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 = INT(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 = INT(DBLE(RGNCLS)*MESH(I))
  600    CONTINUE
         CALL DIFFER(NDIM, LOWER, UPPER, WIDTH, WORK, WORK(NDIM+1),
     &        FUNCTN, DIVAXN, DIFCLS)
         FUNCLS = FUNCLS + DIFCLS
         RGNCLS = INT(DBLE(RGNCLS)*(MESH(DIVAXN)+1.0D0)/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     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
      INCLUDE 'DPCOP2.INC'
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 ADEML1(Y,N,MAXNXT,
     1                  TEMP1,DALPHA,DBETA,DH,
     1                  XMEAN,XMED,XSD,XVAR,XMIN,XMAX,
     1                  ALOCML,SCALML,AKML,
     1                  ISUBRO,IBUGA3,IERROR)
C
C     PURPOSE--THIS ROUTINE COMPUTES THE MAXIMUM LIKELIHOOD ESTIMATES
C              FOR THE ASYMMETRIC DOUBLE EXPONENTIAL DISTRIBUTION FOR
C              THE RAW DATA CASE (I.E., NO CENSORING AND NO GROUPING).
C              THIS ROUTINE RETURNS ONLY THE POINT ESTIMATES (CONFIDENCE
C              INTERVALS WILL BE COMPUTED IN A SEPARATE ROUTINE).
C
C              IT IS ASSUMED THAT BASIC ERROR CHECKING HAS ALREADY BEEN
C              PERFORMED.
C
C              PUT THIS IN A SEPARATE ROUTINE AS IT MAY BE CALLED
C              FROM MULTIPLE PLACES (DPMLAD WILL GENERATE THE OUTPUT
C              FOR THE ASYMMETRIC DOUBLE EXPONENTIAL MLE COMMAND).
C
C              THE ALGORITHM IS:
C
C              1) SORT THE DATA
C
C              2) COMPUTE
C
C                 h(x(j)) = 2*LOG[alpha(theta)) + SQRT(beta(theta))] +
C                           SQRT(alpha(theta)*SQRT(beta(theta))
C
C                 WHERE
C
C                 alpha(theta) = (1/N)*SUM[j=1 to N][(x(j) - theta)+]
C                 beta(theta)  = (1/N)*SUM[j=1 to N][(x(j) - theta)-]
C
C                 WHERE
C
C                 (x(j) - theta)+ = x(j) - theta       x(j) >= theta
C                                 = 0                  x(j) < theta
C                 (x(j) - theta)- = theta - x(j)       x(j) <= theta
C                                 = 0                  x(j) > theta
C
C              3) SET R EQUAL TO THE VALUE OF J WHERE H(x(j)) HAS
C                 IT'S MINIMUM VALUE.
C
C              4) IF R=1 OR R=N, THE MAXIMUM LIKELIHOOD ESTIMATES
C                 DO NOT EXIST.  HOWEVER, THESE CASES SUGGEST
C                 POSITIVE AND NEGATIVE EXPONENTIAL DISTRIBUTIONS,
C                 RESPECTIVELY.
C
C              5) OTHERWISE, THE MAXIMUM LIKELIHOOD ESTIMATES ARE:
C
C                 THETAHAT = X(R)
C
C                 KHAT     = (BETA(THETAHAT))**(1/4)/
C                            (ALPHA(THETAHAT))**(1/4)
C
C                 SIGMAHAT = SQRT(2)*(BETA(THETAHAT))**(1/4)*
C                            (ALPHA(THETAHAT))**(1/4)*
C                            (SQRT(ALPHA(THETAHAT)) +
C                            SQRT(BETA(THETAHAT)))
C
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. 133-178.
C     WRITTEN BY--ALAN HECKERT
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     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2010/07
C     ORIGINAL VERSION--JULY      2010. EXTRACTED AS A SEPARATE
C                                       SUBROUTINE (FROM DPMLAD)
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DIMENSION Y(*)
      DIMENSION TEMP1(*)
      DOUBLE PRECISION DALPHA(*)
      DOUBLE PRECISION DBETA(*)
      DOUBLE PRECISION DH(*)
C
      DOUBLE PRECISION DHMIN
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DSUM2
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
      DOUBLE PRECISION DTERM4
C
      CHARACTER*4 ISUBRO
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 IWRITE
      CHARACTER*40 IDIST
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 ISTEPN
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='ADEM'
      ISUBN2='L1  '
C
      IERROR='NO'
      IWRITE='OFF'
      AN=REAL(N)
      ALOCML=CPUMIN
      SCALML=CPUMIN
      AKML=CPUMIN
C
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'EML1')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,51)
   51   FORMAT('**** AT THE BEGINNING OF ADEML1--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,52)IBUGA3,ISUBRO,N
   52   FORMAT('IBUGA3,ISUBRO,N = ',2(A4,2X),I8)
        CALL DPWRST('XXX','WRIT')
        DO56I=1,MIN(N,100)
          WRITE(ICOUT,57)I,Y(I)
   57     FORMAT('I,Y(I) = ',I8,G15.7)
          CALL DPWRST('XXX','WRIT')
   56   CONTINUE
      ENDIF
C
C               *****************************************************
C               **  STEP 2--                                       **
C               **  CARRY OUT CALCULATIONS                         **
C               **  FOR ASYMMETRIC DOUBLE EXPONENTIAL MLE ESTIMATE **
C               *****************************************************
C
      ISTEPN='2'
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'EML1')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IDIST='ASYMMETRIC DOUBLE EXPONENTIAL'
      IFLAG=0
      CALL SUMRAW(Y,N,IDIST,IFLAG,
     1            XMEAN,XVAR,XSD,XMIN,XMAX,
     1            ISUBRO,IBUGA3,IERROR)
      IF(IERROR.EQ.'YES')GOTO9000
C
      CALL MEDIAN(Y,N,IWRITE,TEMP1,MAXNXT,XMED,IBUGA3,IERROR)
      CALL SORT(Y,N,Y)
C
      DHMIN=DBLE(CPUMAX)
      DO2110I=1,N
        THETA=Y(I)
        DSUM1=0.0D0
        DSUM2=0.0D0
        DO2120J=1,N
          IF(Y(J).GE.THETA)DSUM1=DSUM1 + DBLE(Y(J) - THETA)
          IF(Y(J).LE.THETA)DSUM2=DSUM2 + DBLE(THETA - Y(J))
 2120   CONTINUE
        DALPHA(I)=DSUM1/DBLE(N)
        DBETA(I)=DSUM2/DBLE(N)
        DH(I)=2.0D0*DLOG(DSQRT(DALPHA(I)) + DSQRT(DBETA(I)))
     1        + DSQRT(DALPHA(I))*DSQRT(DBETA(I))
        IF(DH(I).LT.DHMIN)THEN
          DHMIN=DH(I)
          IR=I
        ENDIF
C
        IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'EML1')THEN
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,2125)I,IR,Y(I),DALPHA(I),DBETA(I),DH(I),DHMIN
 2125     FORMAT('I,IR,Y(I),DALPHA(I),DBETA(I),DH(I),DHMIN = ',
     1           2I8,5G15.7)
          CALL DPWRST('XXX','WRIT')
        ENDIF
C
 2110 CONTINUE
C
      IF(IR.EQ.1)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,2131)
 2131   FORMAT('***** ERROR IN ASYMMETRIC DOUBLE EXPONENTIAL ',
     1       'MAXIMUM LIKELIHOOD--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,2133)
 2133   FORMAT('      ESTIMATE OF LOCATION PARAMTER EQUALS DATA ',
     1       'MINIMUM.  THE MAXIMUM')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,2135)
 2135   FORMAT('      LIKELIHOOD ESTIMATES DO NOT EXIST.  HOWEVER, ')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,2137)
 2137   FORMAT('      THIS IMPLIES THAT AN EXPONENTIAL MODEL IS ',
     1         'APPROPRIATE.')
        CALL DPWRST('XXX','WRIT')
        IERROR='YES'
        GOTO9000
      ELSEIF(IR.EQ.N)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,2131)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,2143)
 2143   FORMAT('      ESTIMATE OF LOCATION PARAMTER EQUALS DATA ',
     1       'MAXIMUM.  THE MAXIMUM')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,2145)
 2145   FORMAT('      LIKELIHOOD ESTIMATES DO NOT EXIST.  HOWEVER, ')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,2147)
 2147   FORMAT('      THIS IMPLIES THAT A NEGATIVE EXPONENTIAL ',
     1         'MODEL IS APPROPRIATE.')
        CALL DPWRST('XXX','WRIT')
        IERROR='YES'
        GOTO9000
      ELSE
        ALOCML=Y(IR)
      ENDIF
C
      DTERM1=DBETA(IR)**(1.0D0/4.0D0)
      DTERM2=DALPHA(IR)**(1.0D0/4.0D0)
      DTERM3=DSQRT(DBETA(IR))
      DTERM4=DSQRT(DALPHA(IR))
      IF(DTERM2.LE.0.0D0)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,2131)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,2153)
 2153   FORMAT('      INFINITE VALUE FOR THE SHAPE PARAMETER.')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,2155)
 2155   FORMAT('      THE CAUSE OF THIS IS TIES FOR THE ',
     1         'MAXIMUM DATA VALUE AND')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,2157)
 2157   FORMAT('      THE ESTIMATE OF THE LOCATION PARAMETER ',
     1         'OCCURS AT THE DATA MAXIMUM.')
        CALL DPWRST('XXX','WRIT')
        IERROR='YES'
        GOTO9000
      ENDIF
      AKML=DTERM1/DTERM2
      SCALML=DSQRT(2.0D0)*DTERM2*DTERM1*(DTERM3 + DTERM4)
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'EML1')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9011)
 9011   FORMAT('**** AT THE END OF ADEML1--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9013)N,XMEAN,XSD,XMIN,XMAX
 9013   FORMAT('N,XMEAN,XSD,XMIN,XMAX = ',I8,4G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9019)ALOCML,SCALML,AKML
 9019   FORMAT('ALOCML,SCALML,AKML =  ',3G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9021)IERROR
 9021   FORMAT('IERROR = ',A4)
        CALL DPWRST('XXX','WRIT')
      ENDIF
C
      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     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
      INCLUDE 'DPCOP2.INC'
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     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
C
      CHARACTER*4 IADEDF
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
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     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
      INCLUDE 'DPCOP2.INC'
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                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
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
      INCLUDE 'DPCOP2.INC'
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 ARGUMENT 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                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
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
      INCLUDE 'DPCOP2.INC'
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
      SUBROUTINE ADJUS3(NVAR, X, Y, Z, LOCZ, NX, NY, NZ, DIM, CONFIG, D)
C
C     NOTE: FOR DATAPLOT, RENAME TO AVOID NAME CONFLICT.
C
CCCCC SUBROUTINE ADJUST(NVAR, X, Y, Z, LOCZ, NX, NY, NZ, DIM, CONFIG, D)
C
C        ALGORITHM AS 51.2  APPL. STATIST. (1972) VOL.21, P.218
C
C        MAKES PROPORTIONAL ADJUSTMENT CORRESPONDING TO CONFIG.
C        ALL PARAMETERS ARE ASSUMED VALID WITHOUT TEST.
C
C        IF THE VALUE OF NVAR IS TO BE GREATER THAN 7, THE
C        DIMENSIONS IN THE DECLARATIONS OF SIZE AND COORD MUST
C        BE INCREASED TO NVAR+1 AND NVAR RESPECTIVELY.
C
      INTEGER SIZE(8), DIM(NVAR), CONFIG(NVAR), COORD(7)
      REAL X(NX), Y(NY), Z(NZ), D, E, ZERO, ZABS
C
      DATA ZERO /0.0/
C
      ZABS(E) = ABS(E)
C
C        SET SIZE ARRAY
C
      SIZE(1) = 1
      DO 10 K = 1, NVAR
         L = CONFIG(K)
         IF (L .EQ. 0) GOTO 20
         SIZE(K + 1) = SIZE(K) * DIM(L)
   10 CONTINUE
C
C        FIND NUMBER OF VARIABLES IN CONFIGURATION
C
      K = NVAR + 1
   20 CONTINUE
      N = K - 1
C
C        TEST SIZE OF DEVIATION
C
      L = SIZE(K)
      J = 1
      K = LOCZ
      DO 30 I = 1, L
         E = ZABS(Z(K) - Y(J))
         IF (E .GT. D) D = E
         J = J + 1
         K = K + 1
   30 CONTINUE
C
C        INITIALIZE COORDINATES
C
      DO 40 K = 1, NVAR
         COORD(K) = 0
   40 CONTINUE
      I = 1
C
C        PERFORM ADJUSTMENT
C
   50 CONTINUE
      J = 0
      DO 60 K = 1, N
         L = CONFIG(K)
         J = J + COORD(L) * SIZE(K)
   60 CONTINUE
      K = J + LOCZ
      J = J + 1
C
C        NOTE THAT Y(J) SHOULD BE NON-NEGATIVE
C
      IF (Y(J) .LE. ZERO) X(I) = ZERO
      IF (Y(J) .GT. ZERO) X(I) = X(I) * Z(K) / Y(J)
C
C        UPDATE COORDINATES
C
      I = I + 1
      DO 70 K = 1, NVAR
         COORD(K) = COORD(K) + 1
         IF (COORD(K) .LT. DIM(K)) GOTO 50
         COORD(K) = 0
   70 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'
      INCLUDE 'DPCOP2.INC'
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'
      INCLUDE 'DPCOP2.INC'
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'
      INCLUDE 'DPCOP2.INC'
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
      XHIGH1=0.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      CONTINUE
      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'
      INCLUDE 'DPCOP2.INC'
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
      XHIGH2=0.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'
      INCLUDE 'DPCOP2.INC'
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'
      INCLUDE 'DPCOP2.INC'
C
      ALI = CPUMIN
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'
      INCLUDE 'DPCOP2.INC'
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
C
      ALNREL=CPUMIN
C
      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
ccccc 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
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
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
      INCLUDE 'DPCOP2.INC'
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     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
      INCLUDE 'DPCOP2.INC'
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     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
      INCLUDE 'DPCOP2.INC'
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
      DOUBLE PRECISION FUNCTION algdiv(a,b)
C-----------------------------------------------------------------------
C
C     COMPUTATION OF LN(GAMMA(B)/GAMMA(A+B)) WHEN B .GE. 8
C
C                         --------
C
C     IN THIS ALGORITHM, DEL(X) IS THE FUNCTION DEFINED BY
C     LN(GAMMA(X)) = (X - 0.5)*LN(X) - X + 0.5*LN(2*PI) + DEL(X).
C
C-----------------------------------------------------------------------
C     .. Scalar Arguments ..
      DOUBLE PRECISION a,b
C     ..
C     .. Local Scalars ..
      DOUBLE PRECISION c,c0,c1,c2,c3,c4,c5,d,h,s11,s3,s5,s7,s9,t,u,v,w,
     +                 x,x2
C     ..
C     .. External Functions ..
      DOUBLE PRECISION alnrel
      EXTERNAL alnrel
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC dlog
C     ..
C     .. Data statements ..
      DATA c0/.833333333333333D-01/,c1/-.277777777760991D-02/,
     +     c2/.793650666825390D-03/,c3/-.595202931351870D-03/,
     +     c4/.837308034031215D-03/,c5/-.165322962780713D-02/
C     ..
C     .. Executable Statements ..
C------------------------
      IF (a.LE.b) GO TO 10
      h = b/a
      c = 1.0D0/ (1.0D0+h)
      x = h/ (1.0D0+h)
      d = a + (b-0.5D0)
      GO TO 20

   10 h = a/b
      c = h/ (1.0D0+h)
      x = 1.0D0/ (1.0D0+h)
      d = b + (a-0.5D0)
C
C                SET SN = (1 - X**N)/(1 - X)
C
   20 x2 = x*x
      s3 = 1.0D0 + (x+x2)
      s5 = 1.0D0 + (x+x2*s3)
      s7 = 1.0D0 + (x+x2*s5)
      s9 = 1.0D0 + (x+x2*s7)
      s11 = 1.0D0 + (x+x2*s9)
C
C                SET W = DEL(B) - DEL(A + B)
C
      t = (1.0D0/b)**2
      w = ((((c5*s11*t+c4*s9)*t+c3*s7)*t+c2*s5)*t+c1*s3)*t + c0
      w = w* (c/b)
C
C                    COMBINE THE RESULTS
C
      u = d*alnrel(a/b)
      v = a* (dlog(b)-1.0D0)
      IF (u.LE.v) GO TO 30
      algdiv = (w-v) - u
      RETURN

   30 algdiv = (w-u) - v
      RETURN

      END
      SUBROUTINE ALPCDF(DX,DALPHA,DCDF)
CCCCC SUBROUTINE ALPCDF(X,ALPHA,BETA,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE ALPHA DISTRIBUTION
C              WITH SHAPE PARAMETER ALPHA AND SCALE PARAMETER BETA.
C              THIS DISTRIBUTION IS DEFINED FOR ALL
C              NON-NEGATIVE X, AND HAS THE CUMULATIVE DISTRIBUTION
C              FUNCTION
C
C                F(X;ALPHA) = NORCDF(ALPHA-BETA/X)/NORCDF(ALPHA)
C
C              NOTE 11/2007: ROUTINE PREVIOSLY TREATED BETA AS A
C                            SHAPE PARAMETER.  CORRECT SO THAT
C                            BETA IS A SCALE PARAMETER (AND
C                            SO CAN BE ASSUMED TO BE 1 IN THIS
C                            ROUTINE).
C
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     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--95/4
C     ORIGINAL VERSION--APRIL     1995.
C     UPDATED         --NOVEMBER  2007. BETA IS A SCALE PARAMETER,
C                                       SO ASSUME = 1
C     UPDATED         --NOVEMBER  2007. MAKE ARGUMENTS DOUBLE PRECISON
C
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DALPHA
      DOUBLE PRECISION DCDF
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      DCDF=0.0D0
      IF(DX.LT.0.0D0)THEN
        WRITE(ICOUT,4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)DX
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ELSEIF(DX.EQ.0.0D0)THEN
        GOTO9999
      ELSEIF(DALPHA.LE.0.0D0)THEN
        WRITE(ICOUT,14)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)DALPHA
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
    4 FORMAT('***** ERROR--THE FIRST ARGUMENT TO ALPCDF IS NEGATIVE.')
   14 FORMAT('***** ERROR--THE SECOND ARGUMENT TO ALPCDF IS ',
     1       'NON-POSITIVE.')
   47 FORMAT('      THE VALUE OF THE ARGUMENT IS ',G15.7)
C
      CALL NODCDF(DALPHA,DTERM1)
      DTERM2=DALPHA-(1.0D0/DX)
      CALL NODCDF(DTERM2,DTERM3)
      IF(DTERM1.GT.0.0D0)THEN
        DCDF=DTERM3/DTERM1
      ELSE
        DCDF=0.0D0
      ENDIF
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE ALPCHA(DX,DALPHA,DHAZ)
CCCCC SUBROUTINE ALPCHA(X,ALPHA,BETA,HAZ)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE HAZARD
C              FUNCTION VALUE FOR THE ALPHA DISTRIBUTION
C              WITH SHAPE PARAMETER ALPHA AND SCALE PARAMETER
C              BETA.  THIS DISTRIBUTION IS DEFINED FOR ALL
C              NON-NEGATIVE X, AND HAS THE CUMULATIVE HAZARD
C              FUNCTION
C
C              H(X;ALPHA) = -LOG(1 - NORCDF(ALPHA-BETA/X)/NORCDF(ALPHA))
C
C              NOTE 11/2007: ROUTINE PREVIOSLY TREATED BETA AS A
C                            SHAPE PARAMETER.  CORRECT SO THAT
C                            BETA IS A SCALE PARAMETER (AND
C                            SO CAN BE ASSUMED TO BE 1 IN THIS
C                            ROUTINE).
C
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     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--98/4
C     ORIGINAL VERSION--APRIL     1998.
C     UPDATED         --NOVEMBER  2007. ALPHA IS A SCALE PARAMETER,
C                                       SO ASSUME = 1
C     UPDATED         --NOVEMBER  2007. MAKE ARGUMENTS DOUBLE PRECISON
C
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DALPHA
      DOUBLE PRECISION DHAZ
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
      DOUBLE PRECISION DCDF
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      DHAZ=0.0D0
      IF(DX.LT.0.0D0)THEN
        WRITE(ICOUT,4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)DX
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ELSEIF(DX.EQ.0.0D0)THEN
        GOTO9999
      ELSEIF(DALPHA.LE.0.0D0)THEN
        WRITE(ICOUT,14)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)DALPHA
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
    4 FORMAT('***** ERROR--THE FIRST ARGUMENT TO ALPCHAZ IS NEGATIVE.')
   14 FORMAT('***** ERROR--THE SECOND ARGUMENT TO ALPCHAZ IS ',
     1       'NON-POSITIVE.')
   47 FORMAT('      THE VALUE OF THE ARGUMENT IS ',G15.7)
C
      CALL NODCDF(DALPHA,DTERM1)
      DTERM2=DALPHA - (1.0D0/DX)
      CALL NODCDF(DTERM2,DTERM3)
      DCDF=1.0D0 - DTERM3/DTERM1
C
      IF(DCDF.GT.0.0D0)THEN
        DHAZ=-DLOG(DCDF)
      ELSE
        DHAZ=0.0D0
        WRITE(ICOUT,301)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,302)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,303)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,304)DX
        CALL DPWRST('XXX','BUG ')
      ENDIF
  301 FORMAT('**** ERROR FROM ALPCHAZ--')
  302 FORMAT('     THE CDF VALUE IS ESSENTIALLY 1, SO THE CUMULATIVE')
  303 FORMAT('     HAZARD IS UNDEFINED (SET TO 0).')
  304 FORMAT('     THE VALUE OF THE FIRST INPUT ARGUMENT IS ',G15.7)
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE ALPHAZ(DX,DALPHA,DHAZ)
CCCCC SUBROUTINE ALPHAZ(X,ALPHA,BETA,HAZ)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE HAZARD
C              FUNCTION VALUE FOR THE ALPHA DISTRIBUTION
C              WITH SHAPE PARAMETER ALPHA AND SCALE PARAMETER BETA.
C              THIS DISTRIBUTION IS DEFINED FOR ALL
C              NON-NEGATIVE X, AND HAS THE HAZARD FUNCTION
C
C              H(X;ALPHA) = BETA*NORPDF(T)/
C                           (X**2*(NORCDF(ALPHA)-NORCDF(T))
C
C              WHERE T = ALPHA - BETA/X
C
C              NOTE 11/2007: ROUTINE PREVIOSLY TREATED BETA AS A
C                            SHAPE PARAMETER.  CORRECT SO THAT
C                            BETA IS A SCALE PARAMETER (AND
C                            SO CAN BE ASSUMED TO BE 1 IN THIS
C                            ROUTINE).
C
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     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--98/4
C     ORIGINAL VERSION--APRIL     1998.
C     UPDATED         --NOVEMBER  2007. ALPHA IS A SCALE PARAMETER,
C                                       SO ASSUME = 1
C     UPDATED         --NOVEMBER  2007. MAKE ARGUMENTS DOUBLE PRECISON
C
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DALPHA
      DOUBLE PRECISION DHAZ
C
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
      DOUBLE PRECISION DNUM
      DOUBLE PRECISION DDENOM
      DOUBLE PRECISION DT
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      DHAZ=0.0D0
      IF(DX.LE.0.0D0)THEN
        WRITE(ICOUT,4)
    4   FORMAT('***** ERROR--THE FIRST ARGUMENT TO ALPHAZ IS ',
     1         'NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)DX
   47   FORMAT('      THE VALUE OF THE ARGUMENT IS ',G15.7)
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ELSEIF(DALPHA.LE.0.0D0)THEN
        WRITE(ICOUT,14)
   14   FORMAT('***** ERROR--THE SECOND ARGUMENT TO ALPHAZ IS ',
     1         'NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)DALPHA
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
C
      DT=DALPHA - (1.0D0/DX)
C
      CALL NODCDF(DT,DTERM2)
      CALL NODCDF(DALPHA,DTERM3)
      DTERM1=DTERM3-DTERM2
      CALL NODPDF(DT,DNUM)
      DDENOM=(DX**2)*DTERM1
      IF(DDENOM.NE.0.0D0)THEN
        DHAZ=DNUM/DDENOM
      ELSE
        WRITE(ICOUT,101)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,102)DX
        CALL DPWRST('XXX','BUG ')
      ENDIF
  101 FORMAT('***** ERROR IN ALPHAZ--HAZARD FUNCTION IS UNDEFINED.')
  102 FORMAT('      VALUE OF THE ARGUMENT IS ',G15.7,'.')
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE ALPFUN (N, X, FVEC, IFLAG, XDATA, NOBS)
C
C     PURPOSE--THIS ROUTINE COMPUTES THE FUNCTIONS FOR THE
C              ALPHA MAXIMUM LIKELIHOOD EQUATIONS.
C
C              BETA*SUM[i=1 to N][1/X(i)] - N*ALPHA - N*Z = 0
C
C              (N/BETA) + BETA*SUM[i=1 to N][1/X(i)**2] -
C              ALPHA*SUM[i=1 to N][1/X(i)] = 0
C
C              WHERE
C
C              Z        = d/dalpha LOG(NORCDF(ALPHA))
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--ALPHA MAXIMUM LIKELIHOOD Y
C     REFERENCE--JOHNSON, KOTZ, AND BALAKRISHNAN (1994), "CONTINUOUS
C                UNIVARIATE DISTRIBUTIONS--VOLUME I", SECOND EDITION,
C                WILEY, P. 173.
C              --SALVIA (1985), "RELIABILITY APPLICATIONS OF THE
C                ALPHA DISTRIBUTION", IEEE TRANSACTIONS ON
C                RELIABILITY, VOL. R-34, NO. 3, PP. 251-252.
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     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2007/12
C     ORIGINAL VERSION--DECEMBER  2007.
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION X(*)
      DOUBLE PRECISION FVEC(*)
      REAL XDATA(*)
C
      DOUBLE PRECISION DBETA
      DOUBLE PRECISION DALPHA
      DOUBLE PRECISION DN
      DOUBLE PRECISION DX
      DOUBLE PRECISION H
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DSUM2
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
      DOUBLE PRECISION DTERM4
      DOUBLE PRECISION DTERM5
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
      DOUBLE PRECISION ERR
      DOUBLE PRECISION CON
      DOUBLE PRECISION CON2
      DOUBLE PRECISION BIG
      DOUBLE PRECISION SAFE
      DOUBLE PRECISION ERRT
      DOUBLE PRECISION FAC
      DOUBLE PRECISION HH
      DOUBLE PRECISION DZ
      INTEGER I
      INTEGER J
      PARAMETER (CON=1.4D0)
      PARAMETER (CON2=CON*CON)
      PARAMETER (BIG=1.D30)
      PARAMETER (NTAB=10)
      PARAMETER (SAFE=2.D0)
C
      DOUBLE PRECISION A(NTAB,NTAB)
C
C-----START POINT-----------------------------------------------------
C
C  COMPUTE SOME SUMS
C
      N=2
      IFLAG=0
C
      DN=DBLE(NOBS)
      DALPHA=DBLE(X(1))
      DBETA=DBLE(X(2))
      DZ=0.0D0
C
C     COMPUTE Z USING RIDDER'S METHOD:
C
      H=0.3D0
      HH=H
      CALL NODCDF(DALPHA+HH,DTERM4)
      DTERM4=DLOG(DTERM4)
      CALL NODCDF(DALPHA-HH,DTERM5)
      DTERM5=DLOG(DTERM5)
      DTERM2=(DTERM4 - DTERM5)/(2.0D0*HH)
      A(1,1)=DTERM2
      ERR=BIG
      DO10I=2,NTAB
        HH=HH/CON
        CALL NODCDF(DALPHA+HH,DTERM4)
        DTERM4=DLOG(DTERM4)
        CALL NODCDF(DALPHA-HH,DTERM5)
        DTERM5=DLOG(DTERM5)
        DTERM2=(DTERM4 - DTERM5)/(2.0D0*HH)
        A(1,I)=DTERM2
        FAC=CON2
        DO20J=2,I
          A(J,I)=(A(J-1,I)*FAC - A(J-1,I-1))/(FAC-1.0D0)
          FAC=CON2*FAC
          ERRT=MAX(DABS(A(J,I)-A(J-1,I)),DABS(A(J,I)-A(J-1,I-1)))
          IF(ERRT.LE.ERR)THEN
            ERR=ERRT
            DZ=A(J,I)
          ENDIF
   20   CONTINUE
        IF(DABS(A(I,I)-A(I-1,I-1)).GE.SAFE*ERR)GOTO99
   10 CONTINUE
   99 CONTINUE
C
      DTERM1=DN*DALPHA
      DTERM2=DN*DZ
      DTERM3=DN/DBETA
      DSUM1=0.0D0
      DSUM2=0.0D0
C
      DO200I=1,NOBS
C
        DX=1.0D0/DBLE(XDATA(I))
C
        DSUM1=DSUM1 + DX
        DSUM2=DSUM2 + DX*DX
C
  200 CONTINUE
C
      FVEC(1)=DBETA*DSUM1 - DTERM1 - DTERM2
      FVEC(2)=DTERM3 + DBETA*DSUM2 - DALPHA*DSUM1
C
      RETURN
      END
      SUBROUTINE ALPPDF(DX,DALPHA,DPDF)
CCCCC SUBROUTINE ALPPDF(X,ALPHA,BETA,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE ALPHA DISTRIBUTION
C              WITH SHAPE PARAMETER ALPHA AND SCALE PARAMETER BETA.
C              THIS DISTRIBUTION IS DEFINED FOR ALL
C              NON-NEGATIVE X, AND HAS THE PROBABILITY DENSITY
C              FUNCTION
C
C              f(X;ALPHA,BETA) = BETA*NORPDF(ALPHA-BETA/X)/
C                                [X**2*NORCDF(ALPHA)]
C
C              NOTE 11/2007: ROUTINE PREVIOSLY TREATED BETA AS A
C                            SHAPE PARAMETER.  CORRECT SO THAT
C                            BETA IS A SCALE PARAMETER (AND
C                            SO CAN BE ASSUMED TO BE 1 IN THIS
C                            ROUTINE).
C
C     REFERENCE--JOHNSON, KOTZ, AND BALAKRISHNAN (1994), "CONTINUOUS
C                UNIVARIATE DISTRIBUTIONS--VOLUME I", SECOND EDITION,
C                WILEY, P. 173.
C              --SALVIA (1985), "RELIABILITY APPLICATIONS OF THE
C                ALPHA DISTRIBUTION", IEEE TRANSACTIONS ON
C                RELIABILITY, VOL. R-34, NO. 3, PP. 251-252.
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     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--95/4
C     ORIGINAL VERSION--APRIL     1995.
C     UPDATED         --JULY      1995. DEFINE DPDF AS DOUBLE PREC.
C     UPDATED         --NOVEMBER  2007. ALPHA IS A SCALE PARAMETER,
C                                       SO ASSUME = 1
C     UPDATED         --NOVEMBER  2007. MAKE ARGUMENTS DOUBLE PRECISON
C
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DALPHA
      DOUBLE PRECISION DPDF
C
      DOUBLE PRECISION DT
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
C
      INCLUDE 'DPCOP2.INC'
C
CCCCC DATA EPS/0.1E-16/
C
C-----START POINT-----------------------------------------------------
C
      DPDF=0.0D0
      IF(DX.LE.0.0D0)THEN
        WRITE(ICOUT,4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)DX
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ELSEIF(DALPHA.LE.0.0D0)THEN
        WRITE(ICOUT,14)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)ALPHA
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
    4 FORMAT('***** ERROR--THE FIRST ARGUMENT TO ALPPDF IS ',
     1       'NON-POSITIVE.')
   14 FORMAT('***** ERROR--THE SECOND ARGUMENT TO ALPPDF IS ',
     1       'NON-POSITIVE.')
   47 FORMAT('      THE VALUE OF THE ARGUMENT IS ',G15.7)
C
C
      DT=DALPHA - (1.0D0/DX)
      CALL NODPDF(DT,DTERM1)
      CALL NODCDF(DALPHA,DTERM2)
      DPDF=DTERM1/(DTERM2*(DX**2))
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE ALPML1(Y,N,ALPHSV,SCALSV,MAXNXT,
     1                  TEMP1,TEMP2,DISPAR,DTEMP1,
     1                  XMEAN,XSD,XVAR,XMIN,XMAX,
     1                  ALPHMO,SCALMO,ALPHML,SCALML,
     1                  ISUBRO,IBUGA3,IERROR)
C
C     PURPOSE--THIS ROUTINE COMPUTES THE MAXIMUM LIKELIHOOD ESTIMATES
C              FOR THE ALPHA DISTRIBUTION FOR THE RAW DATA CASE (I.E.,
C              NO CENSORING AND NO GROUPING).  THIS ROUTINE RETURNS ONLY
C              THE POINT ESTIMATES.
C
C              IT IS ASSUMED THAT BASIC ERROR CHECKING HAS ALREADY BEEN
C              PERFORMED.
C
C              PUT THIS IN A SEPARATE ROUTINE AS IT MAY BE CALLED
C              FROM MULTIPLE PLACES (DPMLAL WILL GENERATE THE OUTPUT
C              FOR THE ALPHA MLE COMMAND).
C
C     NOTE--THE MAXIMIUM LIKELIHOOD ESTIMATES ARE THE SOLUTIONS
C           TO THE FOLLOWING EQUATIONS:
C
C             BETA*SUM[i=1 to N][1/X(i)] - N*ALPHA - N*Z = 0
C
C             (N/BETA) + BETA*SUM[i=1 to N][1/X(i)**2] -
C             ALPHA*SUM[i=1 to N][1/X(i)] = 0
C
C           WHERE
C
C             Z        = d/dalpha LOG(NORCDF(ALPHA))
C
C           THE MOMENT ESTIMATES ARE
C
C           ALPHAHAT = M/S
C           BETAHAT = M**2/S
C
C           WHERE M AND S ARE THE SAMPLE MEAN AND SAMPLE SD.
C     REFERENCE--JOHNSON, KOTZ, AND BALAKRISHNAN (1994), "CONTINUOUS
C                UNIVARIATE DISTRIBUTIONS--VOLUME I", SECOND EDITION,
C                WILEY, P. 173.
C              --SALVIA (1985), "RELIABILITY APPLICATIONS OF THE
C                ALPHA DISTRIBUTION", IEEE TRANSACTIONS ON
C                RELIABILITY, VOL. R-34, NO. 3, PP. 251-252.
C     WRITTEN BY--ALAN HECKERT
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     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2010/7
C     ORIGINAL VERSION--JULY      2010. EXTRACTED AS A SEPARATE
C                                       SUBROUTINE (FROM DPMLAL)
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DIMENSION Y(*)
      DIMENSION TEMP1(*)
      DIMENSION TEMP2(*)
      DIMENSION DISPAR(*)
      DIMENSION DISPA2(1)
      INTEGER   IPPCAP(2)
      DOUBLE PRECISION DTEMP1(*)
C
      EXTERNAL ALPFUN
C
      DOUBLE PRECISION DPPF
      DOUBLE PRECISION TOL
      DOUBLE PRECISION XPAR(2)
      DOUBLE PRECISION FVEC(2)
C
      CHARACTER*4 ISUBRO
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 IWRITE
      CHARACTER*40 IDIST
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 ISTEPN
C
      CHARACTER*4 IADEDF
      CHARACTER*4 IGEPDF
      CHARACTER*4 IMAKDF
      CHARACTER*4 IBEIDF
      CHARACTER*4 ILGADF
      CHARACTER*4 ISKNDF
      CHARACTER*4 IGLDDF
      CHARACTER*4 IBGEDF
      CHARACTER*4 IGETDF
      CHARACTER*4 ICONDF
      CHARACTER*4 IGOMDF
      CHARACTER*4 IKATDF
      CHARACTER*4 IGIGDF
      CHARACTER*4 IGEODF
      CHARACTER*4 ICASPL
      CHARACTER*4 ICASP2
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='ALPM'
      ISUBN2='L1  '
      IERROR='NO'
      IWRITE='OFF'
C
      SHAPE1=0.0
      SCALE2=0.0
      ALPHMO=0.0
      ALPHML=0.0
      SCALMO=0.0
      SCALML=0.0
C
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'PML1')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,51)
   51   FORMAT('**** AT THE BEGINNING OF ALPML1--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,52)IBUGA3,ISUBRO,N
   52   FORMAT('IBUGA3,ISUBRO,N = ',2(A4,2X),I8)
        CALL DPWRST('XXX','WRIT')
        DO56I=1,MIN(N,100)
          WRITE(ICOUT,57)I,Y(I)
   57     FORMAT('I,Y(I) = ',I8,G15.7)
          CALL DPWRST('XXX','WRIT')
   56   CONTINUE
      ENDIF
C
C               ****************************************************
C               **  STEP 2--                                      **
C               **  CARRY OUT CALCULATIONS                        **
C               **  FOR ALPHA MLE ESTIMATE                        **
C               ****************************************************
C
      ISTEPN='2'
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'PML1')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IDIST='ALPHA'
      SCALMO=CPUMIN
      SHAPMO=CPUMIN
      SCALML=CPUMIN
      SHAPML=CPUMIN
C
      IFLAG=2
      CALL SUMRAW(Y,N,IDIST,IFLAG,
     1            XMEAN,XVAR,XSD,XMIN,XMAX,
     1            ISUBRO,IBUGA3,IERROR)
      IF(IERROR.EQ.'YES')GOTO9000
C
C               **********************************
C               **  STEP 21--                   **
C               **  CARRY OUT CALCULATIONS      **
C               **  FOR ALPHA MLE               **
C               **  ESTIMATE (FULL SAMPLE CASE) **
C               **********************************
C
      ISTEPN='21'
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'MLAL')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      DO1125I=1,N
        TEMP1(I)=1.0/Y(I)
 1125 CONTINUE
      CALL MEAN(TEMP1,N,IWRITE,ZMEAN,IBUGA3,IERROR)
      CALL SD(TEMP1,N,IWRITE,ZSD,IBUGA3,IERROR)
C
      ALPHMO=ZMEAN/ZSD
      SCALMO=ZMEAN**2/ZSD
C
      IF(ALPHSV.GT.0.0 .AND. SCALSV.GT.0.0)THEN
        XPAR(1)=DBLE(ALPHSV)
        XPAR(2)=DBLE(SCALSV)
      ELSE
C
C       IF NO STARTING VALUES SPECIFIED, COMPUTE STARTING
C       VALUES BASED ON PPCC METHOD.
C
        CALL UNIMED(N,TEMP1)
        CALL SORT(Y,N,Y)
        ICASP2='ALPH'
        ICASPL='PPCC'
        IPPCAP(1)=100
        IPPCAP(2)=1
C
C       OBTAIN LOWER/UPPER LIMITS FOR SHAPE PARAMETER
C
        CALL EXTPA2(ICASP2,IDIST,A,B,
     1              SHAP11,SHAP12,SHAP21,SHAP22,
     1              SHAPE1,SHAPE2,SHAPE3,SHAPE4,SHAPE5,
     1              IADEDF,IGEPDF,IMAKDF,IBEIDF,
     1              ILGADF,ISKNDF,IGLDDF,IBGEDF,
     1              IGETDF,ICONDF,IGOMDF,IKATDF,
     1              IGIGDF,IGEODF,
     1              ISUBRO,IBUGA3,IERROR)
C
C       CREATE ARRAY FOR THE CANDIDATE VALUES OF SHAPE PARAMETER
C
        NUMSHA=1
        NUMDIS=50
        CALL DPPPC7(ICASPL,ICASP2,IPPCAP,
     1              SHAP11,SHAP12,SHAP21,SHAP22,
     1              SHAPE1,SHAPE2,SHAPE3,SHAPE4,
     1              XMIN,XMAX,A,B,
     1              DISPAR,DISPA2,NUMDIS,NUMSHA,
     1              IADEDF,IGEPDF,IMAKDF,IBEIDF,
     1              ILGADF,ISKNDF,IGLDDF,IBGEDF,IGETDF,
     1              ICONDF,IGOMDF,IKATDF,IGIGDF,IGEODF,
     1              IBUGA3,ISUBRO,IERROR)
C
        CORRMX=-1.0
        IWRITE='OFF'
        DO1010IDIS=1,NUMDIS
          SHAPE=DISPAR(IDIS)
          DO1020I=1,N
            CALL ALPPPF(DBLE(TEMP1(I)),DBLE(SHAPE),DPPF)
            TEMP2(I)=REAL(DPPF)
 1020     CONTINUE
          CALL CORR(Y,TEMP2,N,IWRITE,CC,IBUGA3,IERROR)
          IF(CC.GT.CORRMX)THEN
            SHAPE1=SHAPE
            CALL LINFI2(Y,TEMP2,N,PPA0,PPA1,ISUBRO,IBUGA3,IERROR)
            CORRMX=CC
            SCALE2=PPA1
          ENDIF
 1010   CONTINUE
        XPAR(1)=DBLE(SHAPE1)
        XPAR(2)=DBLE(SCALE2)
      ENDIF
C
      IOPT=2
      TOL=1.0D-5
      NVAR=2
      NPRINT=-1
      INFO=0
      CALL DNSQE(ALPFUN,JAC,IOPT,NVAR,XPAR,FVEC,TOL,NPRINT,INFO,
     1           DTEMP1,MAXNXT,Y,N)
C
      ALPHML=REAL(XPAR(1))
      SCALML=REAL(XPAR(2))
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'PML1')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9011)
 9011   FORMAT('**** AT THE END OF ALPML1--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9013)N,XMEAN,XSD,XMIN,XMAX
 9013   FORMAT('N,XMEAN,XSD,XMIN,XMAX = ',I8,4G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9017)ALPHML,SCALML,ALPHMO,SCALMO
 9017   FORMAT('ALPPML,SCALML,ALPHMO,SCALMO =  ',4G15.7)
        CALL DPWRST('XXX','WRIT')
      ENDIF
C
      RETURN
      END
      SUBROUTINE ALPPPF(DP,DALPHA,DPPF)
CCCCC SUBROUTINE ALPPPF(P,ALPHA,BETA,PPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE ALPHA DISTRIBUTION
C              WITH SHAPE PARAMETER ALPHA AND SCALE PARAMETER BETA.
C              THIS DISTRIBUTION IS DEFINED FOR ALL
C              NON-NEGATIVE X, AND HAS THE PERCENT POINT FUNCTION
C
C              G(P;ALPHA,BETA) = BETA/
C                                [ALPHA - NORPPF(P*NORCDF(ALPHA))]
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     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--95/4
C     ORIGINAL VERSION--APRIL     1995.
C     UPDATED         --JULY      1995.   DEFINE DPPF AS DOUBLE PREC.
C     UPDATED         --NOVEMBER  2007. ALPHA IS A SCALE PARAMETER,
C                                       SO ASSUME = 1
C     UPDATED         --NOVEMBER  2007. MAKE ARGUMENTS DOUBLE PRECISON
C
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C
      DOUBLE PRECISION DP
      DOUBLE PRECISION DALPHA
      DOUBLE PRECISION DPPF
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      DPPF=0.0D0
      IF(DP.LE.0.0D0 .OR. DP.GE.1.0D0)THEN
        WRITE(ICOUT,4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)DP
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ELSEIF(DALPHA.LE.0.0D0)THEN
        WRITE(ICOUT,14)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)DALPHA
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
    4 FORMAT('***** ERROR--THE FIRST ARGUMENT TO ALPPPF IS ',
     1       'OUTSIDE THE ALLOWABLE (0,1) INTERVAL.')
   14 FORMAT('***** ERROR--THE SECOND ARGUMENT TO ALPCDF IS ',
     1       'NON-POSITIVE.')
   47 FORMAT('      THE VALUE OF THE ARGUMENT IS ',G15.7)
C
      CALL NODCDF(DALPHA,DTERM1)
      DTERM2=DP*DTERM1
      CALL NODPPF(DTERM2,DTERM3)
      DDENOM=DALPHA - DTERM3
      IF(DDENOM.NE.0.0D0)THEN
        DPPF=1.0D0/DDENOM
      ELSE
        WRITE(ICOUT,301)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,302)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,304)DP
        CALL DPWRST('XXX','BUG ')
      ENDIF
  301 FORMAT('**** ERROR FROM ALPPPF--')
  302 FORMAT('     AN INFINITE PPF VALUE IS ENCOUNTERED (SET TO 0).')
  304 FORMAT('     THE VALUE OF THE FIRST INPUT ARGUMENT IS ',G15.7)
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE ALPRAN(N,ALPHA,ISEED,X)
CCCCC 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 ALPHA.
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     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 ALPHA.
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--ALPPPF.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
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     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2001.10
C     ORIGINAL VERSION--OCTOBER   2001.
C     UPDATED         --NOVEMBER  2007. BETA IS REALLY A SCALE
C                                       PARAMETER.
C     UPDATED         --NOVEMBER  2007. CALL LIST TO ALPPPF
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
C
      DOUBLE PRECISION DTEMP
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
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,46)N
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
    5 FORMAT('***** ERROR--THE REQUESTED NUMBER OF ALPHA RANDOM ',
     1       'NUMBERS IS NON-POSITIVE.')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8)
C
      IF(ALPHA.LE.0.0)THEN
        WRITE(ICOUT,14)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)ALPHA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
   14 FORMAT('***** ERROR--THE VALUE OF THE ALPHA SHAPE ',
     1       'PARAMETER IS NON-POSITIVE.')
   47 FORMAT('      THE VALUE OF THE ARGUMENT IS ',G15.7)
C
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(DBLE(X(I)),DBLE(ALPHA),DTEMP)
        X(I)=REAL(DTEMP)
  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                 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     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--95/9
C     ORIGINAL VERSION--SEPTEMBER 1995.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C
      INCLUDE 'DPCOP2.INC'
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
      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                 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     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--95/9
C     ORIGINAL VERSION--SEPTEMBER 1995.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C
      INCLUDE 'DPCOP2.INC'
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                 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     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--95/9
C     ORIGINAL VERSION--SEPTEMBER 1995.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      INCLUDE 'DPCOP2.INC'
C
      DATA PI/3.1415926535898E0/
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      PPF=0.0
      IF(P.LT.0.0.OR.P.GT.1.0)THEN
        WRITE(ICOUT,1)
    1   FORMAT('***** ERROR--THE FIRST ARGUMENT TO ANGPPF ',
     1         '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
      PPF=ASIN(SQRT(P))-PI/4.0
C
 9000 CONTINUE
      RETURN
      END
      FUNCTION ANGRAD (X1,Y1,X2,Y2,X3,Y3,IBUGA3)
C
C     PURPOSE--RETURNS THE ANGLE SWEPT OUT BETEEN TWO RAYS
C              IN 2D.
C     WRITTEN BY--ALAN HECKERT
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--THIS USES THE CODE FROM JOHN BURKARDT "geometry.f90"
C           LIBRARY.  WE CODE IT IN FORTRAN 77, BUT MAKE NO
C           SUBSTANTIVE CHANGES OTHERWISE.
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2012.10
C     ORIGINAL VERSION--OCTOBER   2012.
C
C-----NON-COMMON VARIABLES (GRAPHICS)-------------------------------------
C
      CHARACTER*4 IBUGA3
C
      REAL X1
      REAL Y1
      REAL X2
      REAL Y2
      REAL X3
      REAL Y3
      REAL X
      REAL Y
      REAL PI
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
      DATA PI/3.14159265358979/
C
C-----START POINT-----------------------------------------------------
C
      IF(IBUGA3.EQ.'ON')THEN
        WRITE(ICOUT,51)
   51   FORMAT('AT THE BEGININNING OF ANGRAD')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,53)X1,Y1,X2,Y2,X3,Y3
   53   FORMAT('X1,Y1,X2,Y2,X3,Y3 = ',6G15.7)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      X=(X1 - X2)*(X3 - X2) + (Y1 - Y2)*(Y3 - Y2)
      Y=(X1 - X2)*(Y3 - Y2) - (Y1 - Y2)*(X3 - X2)
C
      IF(X.EQ.0.0 .AND. Y.EQ.0.0)THEN
        ANGRAD = 0.0
      ELSE
         ANGRAD = ATAN2(Y,X)
         IF(ANGRAD .LT. 0.0)THEN
           ANGRAD = ANGRAD + 2.0*PI
         ENDIF
      ENDIF
C
C     WE WANT THE ANGLE BETWEEN 0 AND PI
C
      IF(IBUGA3.EQ.'ON')THEN
        WRITE(ICOUT,9051)
 9051   FORMAT('AT THE END OF ANGRAD')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9053)X,Y,ANGRAD
 9053   FORMAT('X,Y,ANGRAD = ',3G15.7)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      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                 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     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
      INCLUDE 'DPCOP2.INC'
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
      DOUBLE PRECISION FUNCTION ANORM(ARG)
CS    REAL FUNCTION ANORM(ARG)
C------------------------------------------------------------------
C
C This function evaluates the normal distribution function:
C
C                              / x
C                     1       |       -t*t/2
C          P(x) = ----------- |      e       dt
C                 sqrt(2 pi)  |
C                             /-oo
C
C   The main computation evaluates near-minimax approximations
C   derived from those in "Rational Chebyshev approximations for
C   the error function" by W. J. Cody, Math. Comp., 1969, 631-637.
C   This transportable program uses rational functions that
C   theoretically approximate the normal distribution function to
C   at least 18 significant decimal digits.  The accuracy achieved
C   depends on the arithmetic system, the compiler, the intrinsic
C   functions, and proper selection of the machine-dependent
C   constants.
C
C*******************************************************************
C*******************************************************************
C
C Explanation of machine-dependent constants.  Let
C
C   XMIN  = the smallest positive floating-point number.
C
C Then the following machine-dependent constants must be declared
C   in DATA statements.  IEEE values are provided as a default.
C
C   EPS   = argument below which anorm(x) may be represented by
C           0.5  and above which  x*x  will not underflow.
C           A conservative value is the largest machine number X
C           such that   1.0 + X = 1.0   to machine precision.
C   XLOW  = the most negative argument for which ANORM does not
C           vanish.  This is the negative of the solution to
C                    W(x) * (1-1/x**2) = XMIN,
C           where W(x) = exp(-x*x/2)/[x*sqrt(2*pi)].
C   XUPPR = positive argument beyond which anorm = 1.0.  A
C           conservative value is the solution to the equation
C                    exp(-x*x/2) = EPS,
C           i.e., XUPPR = sqrt[-2 ln(eps)].
C
C   Approximate values for some important machines are:
C
C                          XMIN        EPS        XLOW    XUPPR
C
C  CDC 7600      (S.P.)  3.13E-294   7.11E-15   -36.641   8.072
C  CRAY-1        (S.P.)  4.58E-246   7.11E-157 -106.521  26.816
C  IEEE (IBM/XT,
C    SUN, etc.)  (S.P.)  1.18E-38    5.96E-8    -12.949   5.768
C  IEEE (IBM/XT,
C    SUN, etc.)  (D.P.)  2.23D-308   1.11D-16   -37.519   8.572
C  IBM 195       (D.P.)  5.40D-79    1.39D-17   -18.781   8.811
C  VAX D-Format  (D.P.)  2.94D-39    1.39D-17   -13.055   8.811
C  VAX G-Format  (D.P.)  5.56D-309   1.11D-16   -37.556   8.572
C
C*******************************************************************
C*******************************************************************
C
C Error returns
C
C  The program returns  ANORM = 0     for  ARG .LE. XLOW.
C
C
C Intrinsic functions required are:
C
C     ABS, AINT, EXP
C
C
C  Author: W. J. Cody
C          Mathematics and Computer Science Division
C          Argonne National Laboratory
C          Argonne, IL 60439
C
C  Latest modification: March 15, 1992
C
C------------------------------------------------------------------
      INTEGER I
CS    REAL
      DOUBLE PRECISION
     1     A,ARG,B,C,D,DEL,EPS,HALF,P,ONE,Q,RESULT,SIXTEN,
     2     SQRPI,THRSH,ROOT32,X,XLOW,XDEN,XNUM,Y,XSQ,XUPPR,ZERO
      DIMENSION A(5),B(4),C(9),D(8),P(6),Q(5)
C------------------------------------------------------------------
C  Mathematical constants
C
C  SQRPI = 1 / sqrt(2*pi), ROOT32 = sqrt(32), and
C  THRSH is the argument for which anorm = 0.75.
C------------------------------------------------------------------
CS    DATA ONE,HALF,ZERO,SIXTEN/1.0E0,0.5E0,0.0E0,1.60E1/,
CS   1     SQRPI/3.9894228040143267794E-1/,THRSH/0.66291E0/,
CS   2     ROOT32/5.656854248E0/
      DATA ONE,HALF,ZERO,SIXTEN/1.0D0,0.5D0,0.0D0,1.60D1/,
     1     SQRPI/3.9894228040143267794D-1/,THRSH/0.67441D0/,
CCCCC1     SQRPI/3.9894228040143267794D-1/,THRSH/0.66291D0/,
     2     ROOT32/5.656854248D0/
C------------------------------------------------------------------
C  Machine-dependent constants
C------------------------------------------------------------------
CS    DATA EPS/5.96E-8/,XLOW/-12.949E0/,XUPPR/5.768E0/
      DATA EPS/1.11D-16/,XLOW/-37.519D0/,XUPPR/8.572D0/
C------------------------------------------------------------------
C  Coefficients for approximation in first interval
C------------------------------------------------------------------
CS    DATA A/2.2352520354606839287E00,1.6102823106855587881E02,
CS   1       1.0676894854603709582E03,1.8154981253343561249E04,
CS   2       6.5682337918207449113E-2/
CS    DATA B/4.7202581904688241870E01,9.7609855173777669322E02,
CS   1       1.0260932208618978205E04,4.5507789335026729956E04/
      DATA A/2.2352520354606839287D00,1.6102823106855587881D02,
     1       1.0676894854603709582D03,1.8154981253343561249D04,
     2       6.5682337918207449113D-2/
      DATA B/4.7202581904688241870D01,9.7609855173777669322D02,
     1       1.0260932208618978205D04,4.5507789335026729956D04/
C------------------------------------------------------------------
C  Coefficients for approximation in second interval
C------------------------------------------------------------------
CS    DATA C/3.9894151208813466764E-1,8.8831497943883759412E00,
CS   1       9.3506656132177855979E01,5.9727027639480026226E02,
CS   2       2.4945375852903726711E03,6.8481904505362823326E03,
CS   3       1.1602651437647350124E04,9.8427148383839780218E03,
CS   4       1.0765576773720192317E-8/
CS    DATA D/2.2266688044328115691E01,2.3538790178262499861E02,
CS   1       1.5193775994075548050E03,6.4855582982667607550E03,
CS   2       1.8615571640885098091E04,3.4900952721145977266E04,
CS   3       3.8912003286093271411E04,1.9685429676859990727E04/
      DATA C/3.9894151208813466764D-1,8.8831497943883759412D00,
     1       9.3506656132177855979D01,5.9727027639480026226D02,
     2       2.4945375852903726711D03,6.8481904505362823326D03,
     3       1.1602651437647350124D04,9.8427148383839780218D03,
     4       1.0765576773720192317D-8/
      DATA D/2.2266688044328115691D01,2.3538790178262499861D02,
     1       1.5193775994075548050D03,6.4855582982667607550D03,
     2       1.8615571640885098091D04,3.4900952721145977266D04,
     3       3.8912003286093271411D04,1.9685429676859990727D04/
C------------------------------------------------------------------
C  Coefficients for approximation in third interval
C------------------------------------------------------------------
CS    DATA P/2.1589853405795699E-1,1.274011611602473639E-1,
CS   1       2.2235277870649807E-2,1.421619193227893466E-3,
CS   2       2.9112874951168792E-5,2.307344176494017303E-2/
CS    DATA Q/1.28426009614491121E00,4.68238212480865118E-1,
CS   1       6.59881378689285515E-2,3.78239633202758244E-3,
CS   2       7.29751555083966205E-5/
      DATA P/2.1589853405795699D-1,1.274011611602473639D-1,
     1       2.2235277870649807D-2,1.421619193227893466D-3,
     2       2.9112874951168792D-5,2.307344176494017303D-2/
      DATA Q/1.28426009614491121D00,4.68238212480865118D-1,
     1       6.59881378689285515D-2,3.78239633202758244D-3,
     2       7.29751555083966205D-5/
C------------------------------------------------------------------
      X = ARG
      Y = ABS(X)
      IF (Y .LE. THRSH) THEN
C------------------------------------------------------------------
C  Evaluate  anorm  for  |X| <= 0.66291
C                               0.6744 (= NORPPF(0.75)
C------------------------------------------------------------------
            XSQ = ZERO
            IF (Y .GT. EPS) XSQ = X * X
            XNUM = A(5)*XSQ
            XDEN = XSQ
            DO 20 I = 1, 3
               XNUM = (XNUM + A(I)) * XSQ
               XDEN = (XDEN + B(I)) * XSQ
   20       CONTINUE
            RESULT = X * (XNUM + A(4)) / (XDEN + B(4))
            RESULT = HALF + RESULT
C------------------------------------------------------------------
C  Evaluate  anorm  for 0.66291 <= |X| <= sqrt(32)
C------------------------------------------------------------------
         ELSE IF (Y .LE. ROOT32) THEN
            XNUM = C(9)*Y
            XDEN = Y
            DO 120 I = 1, 7
               XNUM = (XNUM + C(I)) * Y
               XDEN = (XDEN + D(I)) * Y
  120       CONTINUE
            RESULT = (XNUM + C(8)) / (XDEN + D(8))
            XSQ = AINT(Y*SIXTEN)/SIXTEN
            DEL = (Y-XSQ)*(Y+XSQ)
            RESULT = EXP(-XSQ*XSQ*HALF)*EXP(-DEL*HALF)*RESULT
            IF (X .GT. ZERO) RESULT = ONE - RESULT
C------------------------------------------------------------------
C  Evaluate  anorm  for |X| > sqrt(32)
C------------------------------------------------------------------
         ELSE
            RESULT = ZERO
            IF ((X .GE. XLOW) .AND. (X .LT. XUPPR)) THEN
               XSQ = ONE / (X * X)
               XNUM = P(6)*XSQ
               XDEN = XSQ
               DO 240 I = 1, 4
                  XNUM = (XNUM + P(I)) * XSQ
                  XDEN = (XDEN + Q(I)) * XSQ
  240          CONTINUE
               RESULT = XSQ *(XNUM + P(5)) / (XDEN + Q(5))
               RESULT = (SQRPI -  RESULT) / Y
               XSQ = AINT(X*SIXTEN)/SIXTEN
               DEL = (X-XSQ)*(X+XSQ)
               RESULT = EXP(-XSQ*XSQ*HALF)*EXP(-DEL*HALF)*RESULT
            END IF
            IF (X .GT. ZERO) RESULT = ONE - RESULT
      END IF
C------------------------------------------------------------------
C  Fix up for negative argument, erf, etc.
C------------------------------------------------------------------
      ANORM = RESULT
C---------- Last card of ANORM ----------
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--ALAN HECKERT
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     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--95/9
C     ORIGINAL VERSION--SEPTEMBER 1995.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C
      INCLUDE 'DPCOP2.INC'
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
      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--ALAN HECKERT
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     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--95/9
C     ORIGINAL VERSION--SEPTEMBER 1995.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      INCLUDE 'DPCOP2.INC'
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('***** ERROR--THE INPUT ARGUMENT TO ARSPDF IS NOT IN '
     1       'THE INTERVAL (0,1).')
  302 FORMAT('      IT HAS THE VALUE ',G15.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--ALAN HECKERT
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     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--95/9
C     ORIGINAL VERSION--SEPTEMBER 1995.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      INCLUDE 'DPCOP2.INC'
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)THEN
        WRITE(ICOUT,1)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)P
        CALL DPWRST('XXX','BUG ')
        PPF=0.0
        GOTO9000
      ENDIF
    1 FORMAT('***** ERROR--THE FIRST ARGUMENT TO ARSPPF IS ',
     1       'OUTSIDE THE ALLOWABLE (0,1) INTERVAL')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
C
      PPF=SIN(PI*P/2.0)*SIN(PI*P/2.0)
C
 9000 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--ALAN HECKERT
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     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
      INCLUDE 'DPCOP2.INC'
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('***** ERROR--THE REQUESTED NUMBER OF ARCSIN RANDOM ',
     1       'NUMBERS 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
 9000 CONTINUE
      RETURN
      END
      DOUBLE PRECISION FUNCTION apser(a,b,x,eps)
C-----------------------------------------------------------------------
C     APSER YIELDS THE INCOMPLETE BETA RATIO I(SUB(1-X))(B,A) FOR
C     A .LE. MIN(EPS,EPS*B), B*X .LE. 1, AND X .LE. 0.5. USED WHEN
C     A IS VERY SMALL. USE ONLY IF ABOVE INEQUALITIES ARE SATISFIED.
C-----------------------------------------------------------------------
C     .. Scalar Arguments ..
      DOUBLE PRECISION a,b,eps,x
C     ..
C     .. Local Scalars ..
      DOUBLE PRECISION aj,bx,c,g,j,s,t,tol
C     ..
C     .. External Functions ..
      DOUBLE PRECISION psi
      EXTERNAL psi
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC abs,dlog
C     ..
C     .. Data statements ..
C--------------------
      DATA g/.577215664901533D0/
C     ..
C     .. Executable Statements ..
C--------------------
      bx = b*x
      t = x - bx
      IF (b*eps.GT.2.D-2) GO TO 10
      c = dlog(x) + psi(b) + g + t
      GO TO 20

   10 c = dlog(bx) + g + t
C
   20 tol = 5.0D0*eps*abs(c)
      j = 1.0D0
      s = 0.0D0
   30 j = j + 1.0D0
      t = t* (x-bx/j)
      aj = t/j
      s = s + aj
      IF (abs(aj).GT.tol) GO TO 30
C
      apser = -a* (c+s)
      RETURN

      END
      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'
      INCLUDE 'DPCOP2.INC'
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'
      INCLUDE 'DPCOP2.INC'
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'
      INCLUDE 'DPCOP2.INC'
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 ATNCDF(X,PHI,ALPHA,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE ARCTANGENT DISTRIBUTION
C
C              THIS DISTRIBUTION IS DEFINED FOR X >= 0 AND HAS
C              THE CUMULATIVE DISTRIBUTION FUNCTION
C
C              F(X;PHI,ALPHA) = 1 - ARCTAN(ALPHA*(PHI - X) + PI/2]/
C                               (ARCTAN(ALPHA*PHI) + PI/2)
C                               X >= 0, ALPHA > 0
C
C              NOTE THAT PHI AND ALPHA ARE ANALOGOUS TO LOCATION AND
C              SCALE PARAMETERS.  HOWEVER, THEY ARE NOT TRUE LOCATION
C              AND SCALE PARAMETERS IN THE SENSE THAT
C
C                  F(X;PHI,ALPHA) = F((X-PHI)/ALPHA;0,1)
C
C              DOES NOT HOLD.
C
C     INPUT  ARGUMENTS--X      = THE DOUBLE PRECISION VALUE AT
C                                WHICH THE CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C                     --PHI    = THE DOUBLE PRECISION PHASE SHIFT
C                                PARAMETER
C                     --ALPHA  = THE DOUBLE PRECISION SCALING PARAMETER
C     OUTPUT ARGUMENTS--CDF    = THE DOUBLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION CUMULATIVE DISTRIBUTION FUNCTION
C             VALUE CDF.
C     PRINTING--NONE.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--ATAN.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN.
C     REFERENCES--GLEN AND LEMIS (1997), "THE ARCTANGENT SURVIVAL
C                 DISTRIBUTION", JOURNAL OF QUALITY TECHNOLOGY,
C                 VOL. 29, NO. 2.
C     WRITTEN BY--ALAN HECKERT
C                 STATISTICAL ENGINEERING LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE:  301-975-2899
C     ORIGINAL VERSION--JANUIARY  2010.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C
      INCLUDE 'DPCOP2.INC'
C
C---------------------------------------------------------------------
C
      DATA PI/ 3.14159265358979D+00/
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS.
C
      CDF=0.0D0
      IF(X.LT.0.0D0)THEN
        CDF=0.0D0
        GOTO9000
      ELSEIF(ALPHA.LE.0.0D0)THEN
        WRITE(ICOUT,2)
    2   FORMAT('***** ERROR--THE SECOND ARGUMENT TO ATNCDF IS ',
     1         'NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ALPHA
   46   FORMAT('      THE ARGUMENT HAS THE VALUE ',G15.7,'.')
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
      TERM1=ATAN(ALPHA*(PHI - X)) + PI/2.0D0
      TERM2=ATAN(ALPHA*PHI) + PI/2.0D0
      CDF=1.0D0 - (TERM1/TERM2)
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE ATNHAZ(X,PHI,ALPHA,HAZ)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE HAZARD
C              FUNCTION VALUE FOR THE ARCTANGENT DISTRIBUTION
C
C              THIS DISTRIBUTION IS DEFINED FOR X >= 0 AND HAS
C              THE HAZARD FUNCTION
C
C              h(X;PHI,ALPHA) = ALPHA/
C                               [ARCTAN(ALPHA*(PHI-X)) + PI/2]*
C                               [1 + ALPHA**2*(X - PHI)**2]
C                               X >= 0, ALPHA > 0
C
C              NOTE THAT PHI AND ALPHA ARE ANALOGOUS TO LOCATION AND
C              SCALE PARAMETERS.  HOWEVER, THEY ARE NOT TRUE LOCATION
C              AND SCALE PARAMETERS IN THE SENSE THAT
C
C                  h(X;PHI,ALPHA) = (1/ALPHA)*h((X-PHI)/ALPHA;0,1)
C
C              DOES NOT HOLD.
C
C     INPUT  ARGUMENTS--X      = THE DOUBLE PRECISION VALUE AT
C                                WHICH THE HAZARD
C                                FUNCTION IS TO BE EVALUATED.
C                     --PHI    = THE DOUBLE PRECISION PHASE SHIFT
C                                PARAMETER
C                     --ALPHA  = THE DOUBLE PRECISION SCALING PARAMETER
C     OUTPUT ARGUMENTS--HAZ    = THE DOUBLE PRECISION HAZARD
C                                FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION HAZARD FUNCTION VALUE HAZ.
C     PRINTING--NONE.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--ARCTAN.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN.
C     REFERENCES--GLEN AND LEMIS (1997), "THE ARCTANGENT SURVIVAL
C                 DISTRIBUTION", JOURNAL OF QUALITY TECHNOLOGY,
C                 VOL. 29, NO. 2.
C     WRITTEN BY--ALAN HECKERT
C                 STATISTICAL ENGINEERING LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE:  301-975-2899
C     ORIGINAL VERSION--JANUARY  2011.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C
      INCLUDE 'DPCOP2.INC'
C
C---------------------------------------------------------------------
C
      DATA PI/ 3.14159265358979D+00/
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS.
C
      IF(X.LT.0.0D0)THEN
        WRITE(ICOUT,1)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(ALPHA.LE.0.0D0)THEN
        WRITE(ICOUT,2)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ALPHA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
    1 FORMAT('***** ERROR--THE FIRST ARGUMENT TO ATNHAZ IS NEGATIVE.')
    2 FORMAT('***** ERROR--THE SECOND ARGUMENT TO ATNHAZ IS ',
     1       'NON-POSITIVE.')
   46 FORMAT('      THE ARGUMENT HAS THE VALUE ',G15.7)
C
      TERM1=ATAN(ALPHA*(PHI-X)) + PI/2.0D0
      TERM2=1.0D0 + ALPHA**2*(X - PHI)**2
      HAZ=ALPHA/(TERM1*TERM2)
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE ATNPDF(X,PHI,ALPHA,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE ARCTANGENT DISTRIBUTION
C
C              THIS DISTRIBUTION IS DEFINED FOR X >= 0 AND HAS
C              THE PROBABILITY DENSITY FUNCTION
C
C              f(X;PHI,ALPHA) = ALPHA/
C                               [ARCTAN(ALPHA*PHI) + PI/2]*
C                               [1 + ALPHA**2*(X - PHI)**2]
C                               X >= 0, ALPHA > 0
C
C              NOTE THAT PHI AND ALPHA ARE ANALOGOUS TO LOCATION AND
C              SCALE PARAMETERS.  HOWEVER, THEY ARE NOT TRUE LOCATION
C              AND SCALE PARAMETERS IN THE SENSE THAT
C
C                  f(X;PHI,ALPHA) = (1/ALPHA)*f((X-PHI)/ALPHA;0,1)
C
C              DOES NOT HOLD.
C
C     INPUT  ARGUMENTS--X      = THE DOUBLE PRECISION VALUE AT
C                                WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C                     --PHI    = THE DOUBLE PRECISION PHASE SHIFT
C                                PARAMETER
C                     --ALPHA  = THE DOUBLE PRECISION SCALING PARAMETER
C     OUTPUT ARGUMENTS--PDF    = THE DOUBLE PRECISION PROBABILITY DENSITY
C                                FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION PROBABILITY DENSITY FUNCTION VALUE PDF.
C     PRINTING--NONE.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--ARCTAN.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN.
C     REFERENCES--GLEN AND LEMIS (1997), "THE ARCTANGENT SURVIVAL
C                 DISTRIBUTION", JOURNAL OF QUALITY TECHNOLOGY,
C                 VOL. 29, NO. 2.
C     WRITTEN BY--ALAN HECKERT
C                 STATISTICAL ENGINEERING LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE:  301-975-2899
C     ORIGINAL VERSION--JANUARY  2010.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C
      INCLUDE 'DPCOP2.INC'
C
C---------------------------------------------------------------------
C
      DATA PI/ 3.14159265358979D+00/
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS.
C
      IF(X.LT.0.0D0)THEN
        WRITE(ICOUT,1)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(ALPHA.LE.0.0D0)THEN
        WRITE(ICOUT,2)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ALPHA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
    1 FORMAT('***** ERROR--THE FIRST ARGUMENT TO ATNPDF IS NEGATIVE.')
    2 FORMAT('***** ERROR--THE SECOND ARGUMENT TO ATNPDF IS ',
     1       'NON-POSITIVE.')
   46 FORMAT('      THE ARGUMENT HAS THE VALUE ',G15.7)
C
      TERM1=ATAN(ALPHA*PHI) + PI/2.0D0
      TERM2=1.0D0 + ALPHA**2*(X - PHI)**2
      PDF=ALPHA/(TERM1*TERM2)
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE ATNPPF(P,PHI,ALPHA,PPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE ARCTANGENT DISTRIBUTION
C
C              THIS DISTRIBUTION IS DEFINED FOR X >= 0 AND HAS
C              THE PERCENT POINT FUNCTION
C
C              G(P;PHI,ALPHA) = PHI + (1/ALPHA)*
C                               TAN((PI/2) - (1 - P)*(ARCTAN(ALPHA*PHI) +
C                               (PI/2))
C                               0 <= P < 1, ALPHA > 0
C
C              NOTE THAT PHI AND ALPHA ARE ANALOGOUS TO LOCATION AND
C              SCALE PARAMETERS.  HOWEVER, THEY ARE NOT TRUE LOCATION
C              AND SCALE PARAMETERS IN THE SENSE THAT
C
C                  G(P;PHI,ALPHA) = PHI * ALPHA*G(P;0,1)
C
C              DOES NOT HOLD.
C
C     INPUT  ARGUMENTS--P      = THE DOUBLE PRECISION VALUE AT
C                                WHICH THE PERCENT POINT
C                                FUNCTION IS TO BE EVALUATED.
C                     --PHI    = THE DOUBLE PRECISION PHASE SHIFT
C                                PARAMETER
C                     --ALPHA  = THE DOUBLE PRECISION SCALING PARAMETER
C     OUTPUT ARGUMENTS--PPF    = THE DOUBLE PRECISION PERCENT POINT
C                                FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION PERCENT POINT FUNCTION
C             VALUE PPF.
C     PRINTING--NONE.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--ATAN, TAN.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN.
C     REFERENCES--GLEN AND LEMIS (1997), "THE ARCTANGENT SURVIVAL
C                 DISTRIBUTION", JOURNAL OF QUALITY TECHNOLOGY,
C                 VOL. 29, NO. 2.
C     WRITTEN BY--ALAN HECKERT
C                 STATISTICAL ENGINEERING LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE:  301-975-2899
C     ORIGINAL VERSION--JANUIARY  2010.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C
      INCLUDE 'DPCOP2.INC'
C
C---------------------------------------------------------------------
C
      DATA PI/ 3.14159265358979D+00/
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS.
C
      PPF=0.0D0
      IF(P.LT.0.0D0 .OR. P.GE.1.0D0)THEN
        WRITE(ICOUT,1)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)P
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(ALPHA.LE.0.0D0)THEN
        WRITE(ICOUT,2)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ALPHA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
    1 FORMAT('***** ERROR--THE FIRST ARGUMENT TO ATNPPF IS OUTSIDE ',
     1       'THE (0,1] INTERVAL.')
    2 FORMAT('***** ERROR--THE SECOND ARGUMENT TO ATNPPF IS ',
     1       'NON-POSITIVE.')
   46 FORMAT('      THE ARGUMENT HAS THE VALUE ',G15.7)
C
      TERM1=(PI/2.0D0) - (1.0D0 - P)*(ATAN(ALPHA*PHI) + (PI/2.0D0))
      TERM2=TAN(TERM1)
      PPF=PHI + (1.0D0/ALPHA)*TERM2
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE ATNRAN(N,PHI,ALPHA,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE ARCTANGENT DISTRIBUTION WITH SHAPE PARAMETERS
C              PHI AND ALPHA.
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER OF RANDOM
C                                NUMBERS TO BE GENERATED.
C                     --PHI    = THE SINGLE PRECISION PHASE SHIFT
C                                PARAMETER.
C                     --ALPHA  = THE SINGLE PRECISION SCALING PARAMETER.
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR (OF DIMENSION
C                                AT LEAST N) INTO WHICH THE GENERATED
C                                RANDOM SAMPLE WILL BE PLACED.
C     OUTPUT--A RANDOM SAMPLE OF SIZE N
C             FROM THE ARCTANGENT DISTRIBUTION
C             WITH SHAPE PARAMETERS PHI AND ALPHA.
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 > 0
C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN, ATNPPF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--GLEN AND LEMIS (1997), "THE ARCTANGENT SURVIVAL
C                 DISTRIBUTION", JOURNAL OF QUALITY TECHNOLOGY,
C                 VOL. 29, NO. 2.
C     WRITTEN BY--ALAN HECKERT
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     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2011.1
C     ORIGINAL VERSION--JANUARY   2011.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
C
      DOUBLE PRECISION DXOUT
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
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,15)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ALPHA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
    5 FORMAT('***** ERROR--THE NUMBER OF ARCTANGENT RANDOM ',
     1'NUMBERS IS NON-POSITIVE.')
   15 FORMAT('***** ERROR--THE SHAPE PARAMETER ALPHA FOR THE ',
     1'ARCTANGENT RANDOM NUMBERS IS NON-POSITIVE.')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
   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 ARCTANGENT DISTRIBUTION RANDOM NUMBERS
C     USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD.
C
      DO100I=1,N
        CALL ATNPPF(DBLE(X(I)),DBLE(PHI),DBLE(ALPHA),DXOUT)
        X(I)=REAL(DXOUT)
  100 CONTINUE
C
 9000 CONTINUE
      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                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
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
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='AUTO'
      ISUBN2='CR  '
      IERROR='NO'
C
      DN=0.0D0
      DMEAN=0.0D0
      DSUM12=0.0D0
      DDENOM=0.0D0
C
      IF(IBUGA3.EQ.'ON')THEN
        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,N
   52   FORMAT('IBUGA3,N = ',A4,2X,I10)
        CALL DPWRST('XXX','BUG ')
        DO55I=1,N
          WRITE(ICOUT,56)I,X(I)
   56     FORMAT('I,X(I) = ',I8,G15.7)
          CALL DPWRST('XXX','BUG ')
   55   CONTINUE
      ENDIF
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.LT.1)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,111)
  111   FORMAT('***** ERROR IN AUTOCORRELATION--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,112)
  112   FORMAT('      THE NUMBER OF OBSERVATIONS FOR THE RESPONSE ',
     1         'VARIABLE')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,115)
  115   FORMAT('      COMPUTED, MUST BE 1 OR LARGER.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,117)N
  117   FORMAT('      THE NUMBER OF OBSERVATIONS = ',I8,'.')
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        GOTO9000
      ENDIF
C
      IF(N.EQ.1)THEN
        XAUTCR=1.0
        GOTO9000
      ENDIF
C
      HOLD=X(1)
      DO135I=2,N
      IF(X(I).NE.HOLD)GOTO139
  135 CONTINUE
CCCCC WRITE(ICOUT,999)
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC WRITE(ICOUT,136)HOLD
CC136 FORMAT('***** NON-FATAL DIAGNOSTIC IN AUTOCR--',
CCCCC1'THE FIRST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7)
CCCCC CALL DPWRST('XXX','BUG ')
      XAUTCR=1.0
      GOTO9000
  139 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.'ON' .AND. IWRITE.EQ.'ON')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,811)N,XAUTCR
  811   FORMAT('THE LAG-ONE AUTOCORRELATION COEFFICIENT OF THE ',
     1         I8,' OBSERVATIONS = ',G15.7)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'ON')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9011)
 9011   FORMAT('***** AT THE END       OF AUTOCR--')
        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,IERROR
 9015   FORMAT('XAUTCR,IERROR = ',G15.7,2X,A4)
        CALL DPWRST('XXX','BUG ')
      ENDIF
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                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1966)
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
      INCLUDE 'DPCOP2.INC'
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
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,
     1                 WORK,ISPACE,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 INSTITUTE OF STANDARDS AND TECHNOLOGY
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
      INCLUDE 'DPCOP2.INC'
C
C
C  -----------------------
C  CHECK VALIDITY OF INPUT
C  -----------------------
C
C***FIRST EXECUTABLE STATEMENT
      IF ((IFLAG .LT. 0) .OR. (IFLAG .GT. 1))  THEN
         WRITE(ICOUT,999)
  999    FORMAT(1X)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,921)IFLAG
  921    FORMAT('***** FROM B2INK -   IFLAG = ',I2,
     1          ' IS OUT OF RANGE. **')
         CALL DPWRST('XXX','BUG ')
         IFLAG = 2
         GO TO 9999
      ELSE IF (NX .LT. 3) THEN
         IFLAG = 3
         WRITE(ICOUT,999)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,931)NX
         CALL DPWRST('XXX','BUG ')
  931    FORMAT('***** FROM B2INK -  NX = ',I4,
     1          ' IS OUT OF RANGE. *****')
         GO TO 9999
      ELSE IF (NY .LT. 3) THEN
         IFLAG = 7
         WRITE(ICOUT,999)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,971)NY
         CALL DPWRST('XXX','BUG ')
  971    FORMAT('***** FROM B2INK - NY = ',I4,
     1          ' IS OUT OF RANGE. ****')
         GO TO 9999
      ELSE IF ((KX .LT. 2) .OR. (KX .GE. NX)) THEN
         IFLAG = 4
         WRITE(ICOUT,999)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,941)KX
         CALL DPWRST('XXX','BUG ')
  941    FORMAT('***** FROM B2INK - KX = ',I4,
     1          ' IS OUT OF RANGE. *****')
         GO TO 9999
      ELSE IF ((KY .LT. 2) .OR. (KY .GE. NY)) THEN
         IFLAG = 8
         WRITE(ICOUT,999)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,981)KY
         CALL DPWRST('XXX','BUG ')
  981    FORMAT('***** FROM B2INK - KY = ',I4,
     1          ' IS OUT OF RANGE. *****')
         GO TO 9999
      ELSE
        IVAL1=NX*NY
        IVAL2=2*KX*(NX+1)
        IVAL3=2*KY*(NY+1)
        IVAL=IVAL1 + MAX(IVAL2,IVAL3)
        IF(IVAL.GT.ISPACE)THEN
          IFLAG = 11
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,1011)
 1011     FORMAT('***** FROM B2INK - INSUFFICIENT WORK SPACE.')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,1013)IVAL
 1013     FORMAT('      REQUIRED WORK SPACE:  ',I10)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,1015)ISPACE
 1015     FORMAT('      AVAILABLE WORK SPACE: ',I10)
          CALL DPWRST('XXX','BUG ')
          GO TO 9999
        ENDIF
      ENDIF
C
      DO 10 I=2,NX
         IF (X(I) .LE. X(I-1)) THEN
            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 ',
     1             'INCREASING.')
            GO TO 9999
         ENDIF
   10 CONTINUE
C
      DO 20 I=2,NY
         IF (Y(I) .LE. Y(I-1)) THEN
            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 ',
     1             'INCREASING.')
            GO TO 9999
         ENDIF
   20 CONTINUE
C
      IF (IFLAG .EQ. 0)  GO TO 50
         NPK = NX + KX
         DO 30 I=2,NPK
            IF (TX(I) .LT. TX(I-1)) THEN
               IFLAG = 6
               WRITE(ICOUT,999)
               CALL DPWRST('XXX','BUG ')
               WRITE(ICOUT,961)
               CALL DPWRST('XXX','BUG ')
  961          FORMAT('***** FROM B2INK -   TX ARRAY MUST BE ',
     1                'NON-DECREASING.')
               GO TO 9999
            ENDIF
   30    CONTINUE
         NPK = NY + KY
         DO 40 I=2,NPK
            IF (TY(I) .LT. TY(I-1)) THEN
               IFLAG = 10
               WRITE(ICOUT,999)
               CALL DPWRST('XXX','BUG ')
               WRITE(ICOUT,1001)
               CALL DPWRST('XXX','BUG ')
 1001          FORMAT('***** FROM B2INK - TY ARRAY MUST BE ',
     1                'NON-DECREASING. ***')
               GO TO 9999
            ENDIF
   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
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 INSTITUTE OF STANDARDS AND TECHNOLOGY
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                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
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
      INCLUDE 'DPCOP2.INC'
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
      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                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
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
      INCLUDE 'DPCOP2.INC'
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
      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
      DOUBLE PRECISION FUNCTION BD0(DX,DNP)
C
C     PURPOSE--THIS FUNCTION IS A UTILITY FUNCTION FOR THE
C              BINRAW SUBROUTINE.  ADAPTED FROM ORIGINAL C
C              CODE OF CATHERINE LOADER.
C     PRINTING--NONE
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--ABS.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--CATHERINE LOADER (2000), "FAST AND ACCURATE COMPUTATION
C                 OF BINOMIAL PROBABILITIES", BELL LABS?
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-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2009/3
C     ORIGINAL VERSION--MARCH     2009.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----DATA STATEMENTS-------------------------------------------------
C
C-----START POINT-----------------------------------------------------
C
      IF(DNP.EQ.0.0D0)THEN
        BD0=CPUMIN
        GOTO9000
      ENDIF
C
      IF(ABS(DX-DNP).LT.0.1D0*(DX+DNP))THEN
        V=(DX-DNP)/(DX+DNP)
        S=(DX-DNP)*V
        EJ=2.0D0*DX*V
        V=V*V
        J=1
  100   CONTINUE
          EJ=EJ*V
          S1=S+(EJ/(DBLE(2*J+1)))
          IF(S1.EQ.S)THEN
            BD0=S1
            GOTO9000
          ENDIF
          S=S1
          GOTO100
      ELSE
        BD0=DX*LOG(DX/DNP)+DNP-DX
      ENDIF
C
 9000 CONTINUE
      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'
      INCLUDE 'DPCOP2.INC'
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=INT(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 = ',F15.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.D0
      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
        SCALE(I) = 1.0E0
  180 CONTINUE
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
           A(I,J) = A(I,J) * G
  250    CONTINUE
C
         DO 260 J = 1, L
           A(J,I) = A(J,I) * F
  260    CONTINUE
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
           Z(I,J) = Z(I,J) * S
  100    CONTINUE
C
  110 CONTINUE
C     ......... FOR I=LOW-1 STEP -1 UNTIL 1,
C               IGH+1 STEP 1 UNTIL N DO -- ..........
  120 CONTINUE
      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 = INT(SCALE(I) + 0.1)
         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
      DOUBLE PRECISION FUNCTION basym(a,b,lambda,eps)
C-----------------------------------------------------------------------
C     ASYMPTOTIC EXPANSION FOR IX(A,B) FOR LARGE A AND B.
C     LAMBDA = (A + B)*Y - B  AND EPS IS THE TOLERANCE USED.
C     IT IS ASSUMED THAT LAMBDA IS NONNEGATIVE AND THAT
C     A AND B ARE GREATER THAN OR EQUAL TO 15.
C-----------------------------------------------------------------------
C     .. Scalar Arguments ..
      DOUBLE PRECISION a,b,eps,lambda
C     ..
C     .. Local Scalars ..
      DOUBLE PRECISION bsum,dsum,e0,e1,f,h,h2,hn,j0,j1,r,r0,r1,s,sum,t,
     +                 t0,t1,u,w,w0,z,z0,z2,zn,znm1
      INTEGER i,im1,imj,j,m,mm1,mmj,n,np1,num
C     ..
C     .. Local Arrays ..
      DOUBLE PRECISION a0(21),b0(21),c(21),d(21)
C     ..
C     .. External Functions ..
      DOUBLE PRECISION bcorr,erfc1,rlog1
      EXTERNAL bcorr,erfc1,rlog1
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC abs,exp,sqrt
C     ..
C     .. Data statements ..
C------------------------
C     ****** NUM IS THE MAXIMUM VALUE THAT N CAN TAKE IN THE DO LOOP
C            ENDING AT STATEMENT 50. IT IS REQUIRED THAT NUM BE EVEN.
C            THE ARRAYS A0, B0, C, D HAVE DIMENSION NUM + 1.
C
C------------------------
C     E0 = 2/SQRT(PI)
C     E1 = 2**(-3/2)
C------------------------
      DATA num/20/
      DATA e0/1.12837916709551D0/,e1/.353553390593274D0/
C     ..
C     .. Executable Statements ..
C------------------------
      basym = 0.0D0
      IF (a.GE.b) GO TO 10
      h = a/b
      r0 = 1.0D0/ (1.0D0+h)
      r1 = (b-a)/b
      w0 = 1.0D0/sqrt(a* (1.0D0+h))
      GO TO 20

   10 h = b/a
      r0 = 1.0D0/ (1.0D0+h)
      r1 = (b-a)/a
      w0 = 1.0D0/sqrt(b* (1.0D0+h))
C
   20 f = a*rlog1(-lambda/a) + b*rlog1(lambda/b)
      t = exp(-f)
      IF (t.EQ.0.0D0) RETURN
      z0 = sqrt(f)
      z = 0.5D0* (z0/e1)
      z2 = f + f
C
      a0(1) = (2.0D0/3.0D0)*r1
      c(1) = -0.5D0*a0(1)
      d(1) = -c(1)
      j0 = (0.5D0/e0)*erfc1(1,z0)
      j1 = e1
      sum = j0 + d(1)*w0*j1
C
      s = 1.0D0
      h2 = h*h
      hn = 1.0D0
      w = w0
      znm1 = z
      zn = z2
      DO 70 n = 2,num,2
          hn = h2*hn
          a0(n) = 2.0D0*r0* (1.0D0+h*hn)/ (n+2.0D0)
          np1 = n + 1
          s = s + hn
          a0(np1) = 2.0D0*r1*s/ (n+3.0D0)
C
          DO 60 i = n,np1
              r = -0.5D0* (i+1.0D0)
              b0(1) = r*a0(1)
              DO 40 m = 2,i
                  bsum = 0.0D0
                  mm1 = m - 1
                  DO 30 j = 1,mm1
                      mmj = m - j
                      bsum = bsum + (j*r-mmj)*a0(j)*b0(mmj)
   30             CONTINUE
                  b0(m) = r*a0(m) + bsum/m
   40         CONTINUE
              c(i) = b0(i)/ (i+1.0D0)
C
              dsum = 0.0D0
              im1 = i - 1
              DO 50 j = 1,im1
                  imj = i - j
                  dsum = dsum + d(imj)*c(j)
   50         CONTINUE
              d(i) = - (dsum+c(i))
   60     CONTINUE
C
          j0 = e1*znm1 + (n-1.0D0)*j0
          j1 = e1*zn + n*j1
          znm1 = z2*znm1
          zn = z2*zn
          w = w0*w
          t0 = d(n)*w*j0
          w = w0*w
          t1 = d(np1)*w*j1
          sum = sum + (t0+t1)
          IF ((abs(t0)+abs(t1)).LE.eps*sum) GO TO 80
   70 CONTINUE
C
   80 u = exp(-bcorr(a,b))
      basym = e0*t*u*sum
      RETURN

      END
      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                 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     LANGUAGE--ANSI FORTRAN (1966)
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
      INCLUDE 'DPCOP2.INC'
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=INT(X+0.0001)
      FINTX=REAL(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
        W(I) = W(I)/(1.0D0+R*(W(I)-1.0D0))
   25 CONTINUE
      J = .TRUE.
      GOTO 10
   30 CONTINUE
      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                 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     LANGUAGE--ANSI FORTRAN (1966)
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
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
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 ')
        GOTO9999
      ELSEIF(W.LE.0.0)THEN
        WRITE(ICOUT,12)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)V
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ELSEIF(N.LE.0)THEN
        WRITE(ICOUT,25)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
C
      INTX=INT(X+0.0001)
      FINTX=REAL(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 ')
      ELSEIF(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('***** ERROR--THE FIRST ARGUMENT TO BBNPDF IS OUTSIDE ',
     1       'THE (0,',I8,') INTERVAL.')
    5 FORMAT('***** WARNING--THE FIRST ARGUMENT TO BBNPDF IS ',
     1        'NON-INTEGRAL.')
    6 FORMAT('      IT HAS BEEN SET TO ',I8)
   11 FORMAT('***** ERROR--THE SECOND ARGUMENT TO ',
     1       'BBNPDF IS NON-POSITIVE.')
   12 FORMAT('***** ERROR--THE THIRD ARGUMENT TO ',
     1       ' BBNPDF IS NON-POSITIVE.')
   25 FORMAT('***** ERROR--THE FOURTH ARGUMENT TO ',
     1       ' BBNPDF 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(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                 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     LANGUAGE--ANSI FORTRAN (1966)
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
      INCLUDE 'DPCOP2.INC'
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 INSTITUTE OF STANDARDS AND TECHNOLOGY 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                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1966)
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
      INCLUDE 'DPCOP2.INC'
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=INT(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 CONTINUE
      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 CONTINUE
      IFAULT = 4
      DO 30 I = 1,3
        LM(I) = 0
        DO 32 J = 1,MRL
          RL(J,I) = 0
   32   CONTINUE
   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   CONTINUE
CCCCC   IF(JJ) 50,60,55
        IF(JJ.LT.0)THEN
          GOTO50
        ELSEIF(JJ.EQ.0)THEN
          GOTO60
        ELSEIF(JJ.GT.0)THEN
          GOTO55
        ENDIF
   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 BCNORM(Y,N,X2TEMP,Y2TEMP,D2TEMP,
     1                  PPCC,ALAMBA,
     1                  IBUGA3,ISUBRO,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PPCC VALUE AND THE
C              OPTIMAL LAMBDA VALUE FOR THE BOX-COX NORMALITY
C              TRANSFORMATION.
C     INPUT  ARGUMENTS--Y      = 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--PPCC   = THE SINGLE PRECISION VALUE OF THE
C                                COMPUTED NORMAL PPCC FOR THE OPTIMAL
C                                VALUE OF LAMBDA FOR THE BOX-COX
C                                TRANSFORMATION.
C                     --ALAMB  = THE SINGLE PRECISION VALUE OF THE
C                                LAMBDA PARAMETER THAT RESULTS IN THE
C                                MAXIMUM NORMAL PPCC VALUE.
C     OUTPUT--NONE.
C     PRINTING--YES.
C     OTHER DATAPAC   SUBROUTINES NEEDED--SORT, UNIMED, NORPPF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--SQRT.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     WRITTEN BY--ALAN HECKERT
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     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2014.7
C     ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--JULY      2014.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IBUGA3
      CHARACTER*4 ISUBRO
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DIMENSION Y(*)
      DIMENSION X2TEMP(*)
      DIMENSION Y2TEMP(*)
      DIMENSION D2TEMP(*)
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='BCNO'
      ISUBN2='RM  '
      IERROR='NO'
C
C     COMPUTE NORMAL ORDER STATISTIC MEDIANS
C
      CALL UNIMED(N,X2TEMP)
      DO110I=1,N
        CALL NORPPF(X2TEMP(I),X2OUT)
        X2TEMP(I)=X2OUT
  110 CONTINUE
C
C     SORT DATA AND SHIFT DATA TO MAKE IT POSITIVE
C
      CALL SORT(Y,N,D2TEMP)
      XMIN=D2TEMP(1)
      IF(XMIN.LE.0.0)THEN
        DO112I=1,N
          D2TEMP(I)=D2TEMP(I)-XMIN+1.0
  112   CONTINUE
      ENDIF
C
      ALAMBA=-2.0
      ALAMSV=ALAMBA
      AINC=0.1
      CCMAX=CPUMIN
C
      DO140IDIS=1,41
C
C       LOG TRANSFORMATION
C
        IF(-0.001.LE.ALAMBA.AND.ALAMBA.LE.0.001)THEN
          ALAMBA=0.0
          DO141I=1,N
            Y2TEMP(I)=LOG(D2TEMP(I))
  141     CONTINUE
        ELSE
          DO146I=1,N
            Y2TEMP(I)=((D2TEMP(I)**ALAMBA)-1.0)/ALAMBA
  146     CONTINUE
        ENDIF
C
        AN1=N
        SUMY=0.0
        DO151I=1,N
          SUMY=SUMY+Y2TEMP(I)
  151   CONTINUE
        XBAR=0.0
        YBAR=SUMY/AN1
C
        SUMX=0.0
        SUMY=0.0
        SUMXY=0.0
        DO152I=1,N
          SUMX=SUMX+(X2TEMP(I)-XBAR)*(X2TEMP(I)-XBAR)
          SUMY=SUMY+(Y2TEMP(I)-YBAR)*(Y2TEMP(I)-YBAR)
          SUMXY=SUMXY+(X2TEMP(I)-XBAR)*(Y2TEMP(I)-YBAR)
  152   CONTINUE
        ARG=SUMX*SUMY
        CC=0.0
        IF(ARG.GT.0.0)CC=SUMXY/SQRT(ARG)
        IF(CC.GT.CCMAX)THEN
          CCMAX=CC
          ALAMSV=ALAMBA
        ENDIF
C
        ALAMBA=ALAMBA + AINC
C
  140 CONTINUE
C
      ALAMBA=ALAMSV
      PPCC=CCMAX
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'NORM')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9011)
 9011   FORMAT('***** AT THE END       OF BCNORM--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9012)IBUGA3,IERROR
 9012   FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9014)ALAMBA,PPCC
 9014   FORMAT('ALAMBA,PPCC = ',2G15.7)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      RETURN
      END
      DOUBLE PRECISION FUNCTION bcorr(a0,b0)
C-----------------------------------------------------------------------
C
C     EVALUATION OF  DEL(A0) + DEL(B0) - DEL(A0 + B0)  WHERE
C     LN(GAMMA(A)) = (A - 0.5)*LN(A) - A + 0.5*LN(2*PI) + DEL(A).
C     IT IS ASSUMED THAT A0 .GE. 8 AND B0 .GE. 8.
C
C-----------------------------------------------------------------------
C     .. Scalar Arguments ..
      DOUBLE PRECISION a0,b0
C     ..
C     .. Local Scalars ..
      DOUBLE PRECISION a,b,c,c0,c1,c2,c3,c4,c5,h,s11,s3,s5,s7,s9,t,w,x,
     +                 x2
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC dmax1,dmin1
C     ..
C     .. Data statements ..
      DATA c0/.833333333333333D-01/,c1/-.277777777760991D-02/,
     +     c2/.793650666825390D-03/,c3/-.595202931351870D-03/,
     +     c4/.837308034031215D-03/,c5/-.165322962780713D-02/
C     ..
C     .. Executable Statements ..
C------------------------
      a = dmin1(a0,b0)
      b = dmax1(a0,b0)
C
      h = a/b
      c = h/ (1.0D0+h)
      x = 1.0D0/ (1.0D0+h)
      x2 = x*x
C
C                SET SN = (1 - X**N)/(1 - X)
C
      s3 = 1.0D0 + (x+x2)
      s5 = 1.0D0 + (x+x2*s3)
      s7 = 1.0D0 + (x+x2*s5)
      s9 = 1.0D0 + (x+x2*s7)
      s11 = 1.0D0 + (x+x2*s9)
C
C                SET W = DEL(B) - DEL(A + B)
C
      t = (1.0D0/b)**2
      w = ((((c5*s11*t+c4*s9)*t+c3*s7)*t+c2*s5)*t+c1*s3)*t + c0
      w = w* (c/b)
C
C                   COMPUTE  DEL(A) + W
C
      t = (1.0D0/a)**2
      bcorr = (((((c5*t+c4)*t+c3)*t+c2)*t+c1)*t+c0)/a + w
      RETURN

      END
      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     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)
CCCCC 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
CCCCC DOUBLE PRECISION RESULT
      DOUBLE PRECISION DCDF
      DOUBLE PRECISION DEPS
      DOUBLE PRECISION DLOW
      DOUBLE PRECISION DUPP
      DOUBLE PRECISION X
CCCCC 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
      INCLUDE 'DPCOP2.INC'
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     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
      INCLUDE 'DPCOP2.INC'
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
      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     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
      INCLUDE 'DPCOP2.INC'
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
      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     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
      INCLUDE 'DPCOP2.INC'
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     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
CCCCC DOUBLE PRECISION DTERM1
CCCCC DOUBLE PRECISION DTERM2
CCCCC DOUBLE PRECISION DTERM3
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
      INCLUDE 'DPCOP2.INC'
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
      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     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
      INCLUDE 'DPCOP2.INC'
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
      INCLUDE 'DPCOP2.INC'
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
      INCLUDE 'DPCOP2.INC'
C
      TERM6=1.0
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'
      INCLUDE 'DPCOP2.INC'
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
      KM = 0
      NS = 0
      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)
CCCCC IF (N-1) 590, 10, 20
      IF (N-1.LE.0)THEN
         GOTO590
      ELSEIF (N-1.EQ.0)THEN
         GOTO10
      ELSEIF (N-1.GT.0)THEN
         GOTO20
      ENDIF
   10 KT = 2
   20 NN = N
      IF (KODE.LT.1 .OR. KODE.GT.2) GO TO 570
CCCCC IF (X) 600, 30, 80
      IF (X.LT.0.0)THEN
         GOTO600
      ELSEIF (X.EQ.0.0)THEN
         GOTO30
      ELSEIF (X.GT.0.0)THEN
         GOTO80
      ENDIF
   30 CONTINUE
CCCCC IF (ALPHA) 580, 40, 50
      IF (ALPHA.LT.0.0) THEN
         GOTO580
      ELSEIF (ALPHA.EQ.0.0) THEN
         GOTO40
      ELSEIF (ALPHA.GT.0.0) THEN
         GOTO50
      ENDIF
   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
CCCCC IF (NN-1) 340, 290, 130
      IF (NN-1.LT.0)THEN
         GOTO340
      ELSEIF (NN-1.EQ.0)THEN
         GOTO290
      ELSEIF (NN-1.GT.0)THEN
         GOTO130
      ENDIF
  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
CCCCC IF (NN-1) 340, 310, 320
      IF (NN-1.LT.0)THEN
         GOTO340
      ELSEIF (NN-1.EQ.0)THEN
         GOTO310
      ELSEIF (NN-1.GT.0)THEN
         GOTO320
      ENDIF
  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'
      INCLUDE 'DPCOP2.INC'
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
      BESI0 = 0.0
C
      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'
      INCLUDE 'DPCOP2.INC'
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
      BESI0E = 0.0
C
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'
      INCLUDE 'DPCOP2.INC'
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'
      INCLUDE 'DPCOP2.INC'
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
      BESI1E = 0.0
C
      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'
      INCLUDE 'DPCOP2.INC'
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)
CCCCC IF (N-1) 720, 10, 20
      IF (N-1.LT.0)THEN
         GOTO720
      ELSEIF (N-1.EQ.0)THEN
         GOTO10
      ELSEIF (N-1.GT.0)THEN
         GOTO20
      ENDIF
   10 KT = 2
   20 NN = N
CCCCC IF (X) 730, 30, 80
      IF (X.LT.0.0)THEN
         GOTO730
      ELSEIF (X.EQ.0.0)THEN
         GOTO30
      ELSEIF (X.GT.0.0)THEN
         GOTO80
      ENDIF
   30 CONTINUE
CCCCC IF (ALPHA) 710, 40, 50
      IF (ALPHA.LT.0.0)THEN
         GOTO710
      ELSEIF (ALPHA.EQ.0.0)THEN
         GOTO40
      ELSEIF (ALPHA.GT.0.0)THEN
         GOTO50
      ENDIF
   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
CCCCC IF (NN-1) 440, 390, 130
      IF (NN-1.LT.0) THEN
         GOTO440
      ELSEIF (NN-1.EQ.0)THEN
         GOTO390
      ELSEIF (NN-1.GT.0)THEN
         GOTO130
      ENDIF
  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
CCCCC IF (NN-1) 440, 410, 420
      IF (NN-1.LT.0)THEN
         GOTO440
      ELSEIF (NN-1.EQ.0)THEN
         GOTO410
      ELSEIF (NN-1.GT.0)THEN
         GOTO420
      ENDIF
  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 BESJ0DP(X)
CCCCC RENAME TO AVOID CONFLICT WITH INTRINSIC BESJ0 FUNCTION
CCCCC 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'
      INCLUDE 'DPCOP2.INC'
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
      BESJ0DP = 1.0
      IF (Y.GT.XSML) BESJ0DP = CSEVL (.125*Y*Y-1., BJ0CS, NTJ0)
      RETURN
C
 20   CONTINUE
      IF (Y.GT.XMAX) THEN
        WRITE(ICOUT,1)
        CALL DPWRST('XXX','BUG ')
        BESJ0DP = 0.0
        RETURN
      ENDIF
    1 FORMAT('***** ERORR FROM BESJ0DP, 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
      BESJ0DP = AMPL * COS (THETA)
C
      RETURN
      END
      FUNCTION BESJ1DP(X)
CCCCC RENAME TO AVOID CONFLICT WITH INTRINSIC BESJ1 FUNCTION
CCCCC 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'
      INCLUDE 'DPCOP2.INC'
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
      BESJ1DP = 0.
      IF (Y.EQ.0.0) RETURN
      IF (Y.LT.XMIN) THEN
        WRITE(ICOUT,2)
        CALL DPWRST('XXX','BUG ')
      ENDIF
    2 FORMAT('***** WARNING FROM BESJ1DP, UNDERFLOW BECAUSE THE ',
     1       'ABSOLUTE VALUE OF X IS TOO SMALL.  ****')
      IF (Y.GT.XMIN) BESJ1DP = 0.5*X
      IF (Y.GT.XSML) BESJ1DP = X *
     1   (.25 + CSEVL(.125*Y*Y-1., BJ1CS, NTJ1))
      RETURN
C
 20   CONTINUE
      IF (Y.GT.XMAX) THEN
        WRITE(ICOUT,1)
        CALL DPWRST('XXX','BUG ')
        BESJ1DP = 0.0
        RETURN
      ENDIF
    1 FORMAT('***** ERORR FROM BESJ1DP, 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
      BESJ1DP = 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'
      INCLUDE 'DPCOP2.INC'
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
C
      S2=0.0
      TRX=0.0
      TM=0.0
      NN = -I1MACH(12)
C
      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'
      INCLUDE 'DPCOP2.INC'
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
C
      S2=0.0
      DNU2=0.0
C
      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'
      INCLUDE 'DPCOP2.INC'
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'
      INCLUDE 'DPCOP2.INC'
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
C
      BESK0E=CPUMIN
C
      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'
      INCLUDE 'DPCOP2.INC'
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'
      INCLUDE 'DPCOP2.INC'
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
C
      BESK1E=CPUMIN
C
      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.
CCCCC 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
        BB=CC*BB
    1 CONTINUE
      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 INSTITUTE OF STANDARDS AND TECHNOLOGY, 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 INSTITUTE OF STANDARDS AND TECHNOLOGY,
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
      DOUBLE PRECISION DGAMMA
      INCLUDE 'DPCOMC.INC'
      INCLUDE 'DPCOP2.INC'
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
        BJ(M)=FAC*BJ(M)
   34 CONTINUE
C
C THIS IS THE ONLY RETURN STATEMENT IN THE ROUTINE
C
   70 CONTINUE
      RETURN
C
C FOR VERY SMALL Z, CALCULATE J*S VIA ASYMPTOTIC FORMULA 9.1.7 OF (1)
C
   72 CONTINUE
      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
        BJ(N)=(Z*BJ(N-1))*(.5/(A+REAL(N-2)))
   74 CONTINUE
      GO TO 70
C UNDERFLOW. SET J*S ZERO
   80 CONTINUE
      DO 81 M=N,MAXN
        BJ(M + 2) = (0.0, 0.0)
   81 CONTINUE
      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'
      INCLUDE 'DPCOP2.INC'
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 CONTINUE
      HH=-G*(EN*(EN*FF+PP)+A*QQ)
    8 CONTINUE
      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)
      QQ=QQ/(EN+A)
   10 CONTINUE
      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)
         HH=HH+AK1(ITEMP)
   14 CONTINUE
      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 CONTINUE
      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 CONTINUE
      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
      EE=EE+PP
   25 CONTINUE
      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
        BK(N)=DD*HH-EE*BK(N)
   28 CONTINUE
      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 CONTINUE
      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
        BK(ITEMP) = DD * PP
   32 CONTINUE
      IF(REALP(Z).LT.0.) GO TO 26
   40 CONTINUE
      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
      BK(N)=(ZINV*(A+REAL(N-3)))*BK(N-1)+BK(N-2)
   65 CONTINUE
   70 CONTINUE
      RETURN
   82 CONTINUE
      DO 83 M=N,MAXP
         BK(M) = (0.0, 0.0)
   83 CONTINUE
      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
      FUNCTION BESRAT(V)
C
C     ROUTINE NEEDED BY VKAPPA FOR COMPUTING MAXIMUM LIKELIHOOD
C     ESTIMATES FOR KAPPA (SHAPE PARAMETER OF VON MISES
C     DISTRIBUTION).  FROM:
C
C ACM ALGORITHM 571
C
C STATISTICS FOR VON MISES' AND FISCHER'S DISTRIBUTIONS
C
C BY G.W. HILL
C
C ACM TRANSACTIONS ON MATHEMATICAL SOFTWARE, JUNE 1981
C
C ----------------------------------------------------------------
C RETURNS BESRAT = A(K) FOR K = ABS(V), WHERE A(K) IS THE EXPECTED
C MODULUS OF THE MEAN VECTOR SUM OF UNIT VECTORS SAMPLED FROM THE
C VON MISES DISTRIBUTION OF DIRECTIONS IN 2D WITH PARAMETER = K.
C A(V) = THE RATIO OF MODIFIED BESSEL FUNCTIONS OF THE FIRST KIND
C OF ORDERS 1 AND 0, I.E., A(V) = I1(V)/I0(V).
C ----------------------------------------------------------------
C
C  ADJUST TO S DECIMAL DIGIT PRECISION BY SETTING DATA CONSTANTS -
C     C1 = (S+9.0-8.0/S)*0.0351
C     C2 = ((S-5.0)**3/180.0+S-5.0)/10.0
C     CX = S*0.5 + 11.0
C  FOR S IN RANGE (5,14).  THUS FOR S = 9.3 :
      DATA C1 /0.613/, C2 /0.475/, CX /15.65/
C
      Y = 0.0
      X = ABS(V)
      IF (X.GT.CX) GO TO 20
C
C  FOR SMALL X, RATIO = X/(2+X*X/(4+X*X/(6+X*X/(8+ ... )))
      N = INT((X+16.0-16.0/(X+C1+0.75))*C1)
      X = X*0.5
      XX = X*X
      DO 10 J=1,N
        Y = XX/(FLOAT(N-J+2)+Y)
   10 CONTINUE
      BESRAT = X/(1.0+Y)
      RETURN
C
C  FOR LARGE X, RATIO = 1-2/(4X-1-1/(4X/3-2-1/(4X/5-2- ... )))
   20 N = INT((68.0/X+1.0)*C2) + 1
      X = X*4.0
      XX = FLOAT(N*2+1)
      DO 30 J=1,N
        Y = XX/((-2.0-Y)*XX+X)
        XX = XX - 2.0
   30 CONTINUE
      BESRAT = 1.0 - 2.0/(X-1.0-Y)
      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'
      INCLUDE 'DPCOP2.INC'
C
      EXTERNAL YAIRY, BESY0DP, BESY1DP
      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 BESY0DP, BESY1DP
      DIMENSION W(2), NULIM(2), Y(*), WK(7)
      SAVE NULIM
C
      DATA NULIM(1),NULIM(2) / 70 , 100 /
C***FIRST EXECUTABLE STATEMENT  BESY
C
      S2=0.0
      TRX=0.0
      TM=0.0
      NN = -I1MACH(12)
C
      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 = BESY0DP(X)
      IF (NUD.EQ.0 .AND. ND.EQ.1) GO TO 70
      S2 = BESY1DP(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) = BESY0DP(X)
      IF (ND.EQ.1) RETURN
      J = J + 1
  130 CONTINUE
      Y(J) = BESY1DP(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'
      INCLUDE 'DPCOP2.INC'
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
C
      S1=0.0
      S2=0.0
      CK=0.0
C
      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 BESY0DP (X)
CCCCC RENAME TO AVOID CONFLICT WITH INTRINSIC BESY0 FUNCTION
CCCCC 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'
      INCLUDE 'DPCOP2.INC'
C
      EXTERNAL BESJ0DP, 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
C
      BESY0DP = CPUMIN
C
      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 BESY0DP, X ZERO OR NEGATIVE.  *******')
        CALL DPWRST('XXX','BUG ')
        BESY0DP=0.0
        RETURN
      ENDIF
      IF (X.GT.4.0) GO TO 20
C
      Y = 0.
      IF (X.GT.XSML) Y = X*X
      BESY0DP = TWODPI*LOG(0.5*X)*BESJ0DP(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 BESY0DP, 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
      BESY0DP = AMPL * SIN (THETA)
C
      RETURN
      END
      FUNCTION BESY1DP (X)
CCCCC RENAME TO AVOID CONFLICT WITH INTRINSIC BESY1 FUNCTION
CCCCC 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'
      INCLUDE 'DPCOP2.INC'
C
      EXTERNAL BESJ1DP, 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 BESY1DP, X ZERO OR NEGATIVE.  *******')
        CALL DPWRST('XXX','BUG ')
        BESY1DP=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 BESY1DP, UNDERFLOW BECAUSE THE ',
     1       'VALUE OF X IS SO SMALL.  ****')
      Y = 0.
      IF (X.GT.XSML) Y = X*X
      BESY1DP = TWODPI*LOG(0.5*X)*BESJ1DP(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 ')
        BESY1DP = 0.0
        RETURN
      ENDIF
    3 FORMAT('***** ERORR FROM BESY1DP, 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
      BESY1DP = 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'
      INCLUDE 'DPCOP2.INC'
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 CONTINUE
      HH= G*(EN*(EN*GG+PP)+A*C*QQ)
    8 CONTINUE
      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)
      QQ=QQ/(EN+A)
   10 CONTINUE
      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)
         HH=HH+YA1(ITEMP)
   14 CONTINUE
      BY(2)=-GG
      BY(1)=-HH*ZINV
      M=3
CCCCC IF(A) 40,40,60
      IF(A.LE.0.0)THEN
        GOTO40
      ELSE
        GOTO60
      ENDIF
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 CONTINUE
      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
        BY(N)=-CC*BY(N)-DD*HH
   24 CONTINUE
      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 CONTINUE
      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 CONTINUE
      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)
CCCCC IF(M-1) 36,36,38
      IF(M-1.LE.0)THEN
        GOTO36
      ELSE
        GOTO38
      ENDIF
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
      BY(N)=(ZINV*(A+REAL(N-3)))*BY(N-1)-BY(N-2)
   65 CONTINUE
   70 CONTINUE
      RETURN
   82 CONTINUE
      DO 83 L=N,MAXP
         BY(L) = (0.0, 0.0)
   83 CONTINUE
      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
      DOUBLE PRECISION FUNCTION betaln(a0,b0)
C-----------------------------------------------------------------------
C     EVALUATION OF THE LOGARITHM OF THE BETA FUNCTION
C-----------------------------------------------------------------------
C     E = 0.5*LN(2*PI)
C--------------------------
C     .. Scalar Arguments ..
      DOUBLE PRECISION a0,b0
C     ..
C     .. Local Scalars ..
      DOUBLE PRECISION a,b,c,e,h,u,v,w,z
      INTEGER i,n
C     ..
C     .. External Functions ..
      DOUBLE PRECISION algdiv,alnrel,bcorr,gamln,gsumln
      EXTERNAL algdiv,alnrel,bcorr,gamln,gsumln
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC dlog,dmax1,dmin1
C     ..
C     .. Data statements ..
      DATA e/.918938533204673D0/
C     ..
C     .. Executable Statements ..
C--------------------------
      a = dmin1(a0,b0)
      b = dmax1(a0,b0)
      IF (a.GE.8.0D0) GO TO 100
      IF (a.GE.1.0D0) GO TO 20
C-----------------------------------------------------------------------
C                   PROCEDURE WHEN A .LT. 1
C-----------------------------------------------------------------------
      IF (b.GE.8.0D0) GO TO 10
      betaln = gamln(a) + (gamln(b)-gamln(a+b))
      RETURN

   10 betaln = gamln(a) + algdiv(a,b)
      RETURN
C-----------------------------------------------------------------------
C                PROCEDURE WHEN 1 .LE. A .LT. 8
C-----------------------------------------------------------------------
   20 IF (a.GT.2.0D0) GO TO 40
      IF (b.GT.2.0D0) GO TO 30
      betaln = gamln(a) + gamln(b) - gsumln(a,b)
      RETURN

   30 w = 0.0D0
      IF (b.LT.8.0D0) GO TO 60
      betaln = gamln(a) + algdiv(a,b)
      RETURN
C
C                REDUCTION OF A WHEN B .LE. 1000
C
   40 IF (b.GT.1000.0D0) GO TO 80
      n = int(a - 1.0D0)
      w = 1.0D0
      DO 50 i = 1,n
          a = a - 1.0D0
          h = a/b
          w = w* (h/ (1.0D0+h))
   50 CONTINUE
      w = dlog(w)
      IF (b.LT.8.0D0) GO TO 60
      betaln = w + gamln(a) + algdiv(a,b)
      RETURN
C
C                 REDUCTION OF B WHEN B .LT. 8
C
   60 n = int(b - 1.0D0)
      z = 1.0D0
      DO 70 i = 1,n
          b = b - 1.0D0
          z = z* (b/ (a+b))
   70 CONTINUE
      betaln = w + dlog(z) + (gamln(a)+ (gamln(b)-gsumln(a,b)))
      RETURN
C
C                REDUCTION OF A WHEN B .GT. 1000
C
   80 n = int(a - 1.0D0)
      w = 1.0D0
      DO 90 i = 1,n
          a = a - 1.0D0
          w = w* (a/ (1.0D0+a/b))
   90 CONTINUE
      betaln = (dlog(w)-n*dlog(b)) + (gamln(a)+algdiv(a,b))
      RETURN
C-----------------------------------------------------------------------
C                   PROCEDURE WHEN A .GE. 8
C-----------------------------------------------------------------------
  100 w = bcorr(a,b)
      h = a/b
      c = h/ (1.0D0+h)
      u = - (a-0.5D0)*dlog(c)
      v = b*alnrel(h)
      IF (u.LE.v) GO TO 110
      betaln = (((-0.5D0*dlog(b)+e)+w)-v) - u
      RETURN

  110 betaln = (((-0.5D0*dlog(b)+e)+w)-u) - v
      RETURN

      END
      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                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
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
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      CDF=0.0
      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.LE.0.0)THEN
CCCCC   WRITE(ICOUT,301)X
CCCCC   CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9999
      ENDIF
      IF(X.GE.1.0)THEN
CCCCC   WRITE(ICOUT,401)X
CCCCC   CALL DPWRST('XXX','BUG ')
        CDF=1.0
        GOTO9999
      ENDIF
  101 FORMAT('***** ERROR IN BETCDF--EITHER THE ALPHA OR BETA IS ',
     1       'NON-POSITIVE.')
  103 FORMAT('      THE VALUE OF ALPHA IS ',G15.7)
  104 FORMAT('      THE VALUE OF BETA IS ',G15.7,'       ******')
CC301 FORMAT('***** ERROR--THE FIRST ARGUMENT TO BETCDF IS ',
CCCCC1       'NON-POSITIVE.  IT HAS THE VALUE ',G15.7)
CC401 FORMAT('***** ERROR--THE FIRST ARGUMENT TO BETCDF IS GREATER ',
CCCCC1       'THAN 1.  IT HAS THE VALUE ',G15.7)
C
      DX=DBLE(X)
      DALPHA=DBLE(ALPHA)
      DBETA=DBLE(BETA)
      DCDF=DBETAI(DX,DALPHA,DBETA)
      CDF=REAL(DCDF)
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE BETFUN (N, X, FVEC, IFLAG, XDATA, NOBS)
C
C     PURPOSE--THIS ROUTINE COMPUTES THE FUNCTIONS FOR THE
C              BETA MAXIMUM LIKELIHOOD EQUATIONS.
C
C              DIGAMMA(PHAT) - DIGAMMA(PHAT + QHAT) -
C                 SUM[I=1 TO N][LOG((X(I)-A)/(B-A))] = 0
C
C              DIGAMMA(QHAT) - DIGAMMA(PHAT + QHAT) -
C                 SUM[I=1 TO N][LOG((B - X(I))/(B-A))] = 0
C
C              WITH A AND B DENOTING THE LOWER AND UPPER LIMIT
C              PARAMETERS, RESPECTIVELY.
C
C              WE FOLLOW THE TECHNIQUE OF SETTING A AND B TO THE
C              DATA MINIMUM AND MAXIMUM, RESPECTIVELY AND TREATING
C              THEM AS "KNOWN" AS OPPOSSED TO THE FULL 4-PARAMETER
C              MAXIMUM LIKELIHOOD SOLUTION.
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 MAXIMUM LIKELIHOOD Y
C     REFERENCE--JOHNSON, KOTZ, AND BALAKRISHNAN (1994).  "CONTINUOUS
C                UNIVARIATE DISTRIBUTIONS: VOLUME 2", SECOND EDITION,
C                JOHN WILEY, P. 223.
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     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2003/11
C     ORIGINAL VERSION--NOVEMBER  2003.
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION X(*)
      DOUBLE PRECISION FVEC(*)
      REAL XDATA(*)
C
      DOUBLE PRECISION DPSI
      DOUBLE PRECISION DN
      DOUBLE PRECISION DX
      DOUBLE PRECISION DA
      DOUBLE PRECISION DB
      DOUBLE PRECISION DP
      DOUBLE PRECISION DQ
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DSUM2
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
      DOUBLE PRECISION DTERM4
      DOUBLE PRECISION DTERM5
C
C---------------------------------------------------------------------
C
      COMMON /BETMLE/ BETALL, BETAUL
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C  ALLOW FOR USER SPECIFIED LOWER/UPPER LIMITS, OTHERWISE USE DATA
C  MINIMUM AND MAXIMUM
C
      N=2
      IFLAG=0
C
      IF(BETALL.EQ.CPUMIN .OR. BETAUL.EQ.CPUMIN)THEN
        A=XDATA(1)
        B=XDATA(1)
        DO100I=1,NOBS
          IF(XDATA(I).LT.A)A=XDATA(I)
          IF(XDATA(I).GT.B)B=XDATA(I)
  100   CONTINUE
      ELSE
        A=BETALL
        B=BETAUL
      ENDIF
C
C  COMPUTE SOME SUMS
C
      DA=DBLE(A)
      DB=DBLE(B)
C
      DN=DBLE(NOBS)
      DSUM1=0.0D0
      DSUM2=0.0D0
      DP=DBLE(X(1))
      DQ=DBLE(X(2))
C
      DTERM1=DPSI(DP)
      DTERM2=DPSI(DQ)
      DTERM3=DPSI(DP+DQ)
C
C  IN ORDER TO AVOID LOG OF NON-POSITIVE NUMBER, EXCLUDE VALUES
C  THAT ARE EQUAL TO A OR B
C
      DSUM1=0.0D0
      DSUM2=0.0D0
      N1=0
      N2=0
      DO200I=1,NOBS
        DX=DBLE(XDATA(I))
        DTERM4=(DX - DA)/(DB - DA)
        DTERM5=(DB - DX)/(DB - DA)
        IF(DTERM4.GT.0.0D0)THEN
          DSUM1=DSUM1 + DLOG(DTERM4)
          N1=N1+1
        ENDIF
        IF(DTERM5.GT.0.0D0)THEN
          DSUM2=DSUM2 + DLOG(DTERM5)
          N2=N2+1
        ENDIF
  200 CONTINUE
C
      IF(N1.GT.0)THEN
        FVEC(1)=DTERM1 - DTERM3 - DSUM1/DBLE(N1)
      ELSE
        FVEC(1)=0.0
      ENDIF
      IF(N2.GT.0)THEN
        FVEC(2)=DTERM2 - DTERM3 - DSUM2/DBLE(N2)
      ELSE
        FVEC(2)=0.0
      ENDIF
C
CCCCC if(iflag.eq.0)then
CCCCC   print *,'nobs,a,b=',nobs,a,b
CCCCC   print *,'dp,dq=',dp,dq
CCCCC   print *,'dterm1,dterm2,dterm3=',dterm1,dterm2,dterm3
CCCCC   print *,'dsum1,dsum2=',dsum1,dsum2
CCCCC   print *,'fvec(1),fvec(2)=',fvec(1),fvec(2)
CCCCC endif
C
      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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
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
      INCLUDE 'DPCOP2.INC'
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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
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
      INCLUDE 'DPCOP2.INC'
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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
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
      INCLUDE 'DPCOBE.INC'
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      IF(ISUBG4.EQ.'TFU3')THEN
        WRITE(ICOUT,11)DX(1)
   11   FORMAT('**** AT THE BEGINNING OF BETFU3--DX(1) = ',G15.7)
        CALL DPWRST('XXX','WRIT')
      ENDIF
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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
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
      INCLUDE 'DPCOBE.INC'
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      IF(ISUBG4.EQ.'TFU3')THEN
        WRITE(ICOUT,11)DX(1)
   11   FORMAT('**** AT THE BEGINNING OF BETFU3--DX(1) = ',G15.7)
        CALL DPWRST('XXX','WRIT')
      ENDIF
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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
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
      INCLUDE 'DPCOP2.INC'
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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
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
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      CALL BETPPF(P,ALPHA,BETA,APPF)
      BETFU8=APPF
C
      RETURN
      END
      SUBROUTINE BETLI1(Y,N,NP,
     1                  A,B,ALPHA,BETA,
     1                  ALIK,AIC,AICC,BIC,
     1                  ISUBRO,IBUGA3,IERROR)
C
C     PURPOSE--THIS ROUTINE COMPUTES THE LOG-LIKIHOOD FUNCTION FOR
C              THE BETA DISTRIBUTION.  THIS IS FOR THE RAW
C              DATA CASE (I.E., NO GROUPING AND NO CENSORING).
C
C              NOTE THAT THE LOWER AND UPPER LIMITS MUST BE EXPLICITLY
C              GIVEN.  THE ARGUMENT NP SHOULD BE 2 FOR A 2-PARAMETER
C              BETA AND 4 FOR A 4-PARAMETER BETA.
C
C     REFERENCE--KARL BURY, "STATISTICAL DISTRIBUTIONS IN
C                ENGINEERING", CAMBRIDGE UNIVERSITY PRESS,
C                1999, CHAPTER 14.
C     WRITTEN BY--ALAN HECKERT
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     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2013/06
C     ORIGINAL VERSION--JUNE      2013.
C
      CHARACTER*4 ISUBRO
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 IWRITE
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 ISTEPN
C
      DOUBLE PRECISION DBETA
      EXTERNAL DBETA
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DA
      DOUBLE PRECISION DB
      DOUBLE PRECISION DALPHA
      DOUBLE PRECISION DBETAZ
      DOUBLE PRECISION DN
      DOUBLE PRECISION DNP
      DOUBLE PRECISION DLIK
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DSUM2
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
C
C---------------------------------------------------------------------
C
      DIMENSION Y(*)
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='BETL'
      ISUBN2='I1  '
C
      IWRITE='OFF'
      IERROR='NO'
      ALIK=CPUMIN
      AIC=CPUMIN
      AICC=CPUMIN
      BIC=CPUMIN
C
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'TLI1')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,51)
   51   FORMAT('**** AT THE BEGINNING OF BETLI1--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,52)IBUGA3,ISUBRO,N,A,B,ALPHA,BETA
   52   FORMAT('IBUGA3,ISUBRO,N,A,B,ALPHA,BETA = ',2(A4,2X),I8,4G15.7)
        CALL DPWRST('XXX','WRIT')
        DO56I=1,MIN(N,100)
          WRITE(ICOUT,57)I,Y(I)
   57     FORMAT('I,Y(I) = ',I8,G15.7)
          CALL DPWRST('XXX','WRIT')
   56   CONTINUE
      ENDIF
C
C               ******************************************
C               **  STEP 1--                            **
C               **  COMPUTE LIKELIHOOD FUNCTION         **
C               ******************************************
C
      ISTEPN='1'
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'TLI1')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      CALL MINIM(Y,N,IWRITE,YMIN,IBUGA3,IERROR)
      CALL MAXIM(Y,N,IWRITE,YMAX,IBUGA3,IERROR)
      IF(A.GE.YMIN .OR. B.LE.YMAX)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,101)
  101   FORMAT('**** ERROR IN BETA LOG-LIKELIHOOD--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,103)
  103   FORMAT('     INVALID LIMITS:')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,105)A
  105   FORMAT('     LOWER LIMIT    = ',G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,106)YMIN
  106   FORMAT('     DATA MINIMUM   = ',G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,107)B
  107   FORMAT('     UPPER LIMIT    = ',G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,108)YMAX
  108   FORMAT('     DATA MAXIMUM   = ',G15.7)
        CALL DPWRST('XXX','WRIT')
        IERROR='YES'
        GOTO9000
      ENDIF
C
C     THE LOG-LIKLIHOOD FUNCTION FOR THE BETA DISTRIBUTION IS:
C
C     (ALPHA-1)*SUM[LOG(Y(i) - A)] + (BETA-1)*SUM[LOG(B - Y(i))]  -
C     N*LOG(B'(2,BETA)) - N*(ALPHA+BETA-1)*LOG(B-A)
C
      DN=DBLE(N)
      DALPHA=DBLE(ALPHA)
      DBETAZ=DBLE(BETA)
      DA=DBLE(A)
      DB=DBLE(B)
C
      DTERM2=DBETA(DALPHA,DBETAZ)
      DTERM1=-DN*DLOG(DTERM2) - DN*(DALPHA+DBETAZ-1.0D0)*DLOG(DB-DA)
C
      DSUM1=0.0D0
      DSUM2=0.0D0
      DO1000I=1,N
        DX=DBLE(Y(I))
        DSUM1=DSUM1 + DLOG(DX - DA)
        DSUM2=DSUM2 + DLOG(DB - DX)
 1000 CONTINUE
C
      DLIK=(DALPHA-1.0D0)*DSUM1 + (DBETAZ-1.0D0)*DSUM2 + DTERM1
      ALIK=REAL(DLIK)
      IF(NP.EQ.2)THEN
        DNP=2.0D0
      ELSEIF(NP.EQ.4)THEN
        DNP=4.0D0
      ELSE
        DNP=4.0D0
      ENDIF
      AIC=REAL(-2.0D0*DLIK + 2.0D0*DNP)
      DTERM3=(2.0D0*DNP*(DNP+1.0D0))/(DN-DNP-1.0D0)
      AICC=REAL(-2.0D0*DLIK + 2.0D0*DNP + DTERM3)
      BIC=REAL(-2.0D0*DLIK + DNP*LOG(DN))
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'TLI1')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9011)
 9011   FORMAT('**** AT THE END OF BETLI1--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9055)DTERM1,DSUM1,DSUM2
 9055   FORMAT('DTERM1,DSUM1,DSUM2,DLIK = ',4G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9057)AIC,AICC,BIC
 9057   FORMAT('AIC,AICC,BIC = ',3G15.7)
        CALL DPWRST('XXX','WRIT')
      ENDIF
C
      RETURN
      END
      SUBROUTINE BETML1(Y,N,DTEMP1,MAXNXT,AUSER,BUSER,
     1                  XMIN,XMAX,XMEAN,XSD,XVAR,
     1                  A,B,
     1                  ALPHMO,BETAMO,
     1                  ALPHML,BETAML,
     1                  ISUBRO,IBUGA3,IERROR)
C
C     PURPOSE--THIS ROUTINE COMPUTES THE MAXIMUM LIKELIHOOD AND
C              METHOD OF MOMENT ESTIMATES FOR THE BETA DISTRIBUTION.
C              THIS IS FOR THE 2-PARAMETER CASE (I.E., THE LOWER
C              AND UPPER LIMITS ARE ASSUMED KNOWN AND FIXED).
C
C
C     EXAMPLE--BETA MAXIMUM LIKELIHOOD Y
C     REFERENCE--EVANS, HASTINGS, AND PEACOCK.  "STATISTICAL
C                DISTRIBUTIONS", THIRD EDITION, WILEY, 2000,
C                PP. 34-42.
C                JOHNSON, KOTZ, AND BALAKRISHNAN.  "CONTINUOUS
C                UNIVARIATE DISTRIBUTIONS, VOLUME II", SECOND
C                EDITION, WILEY, 1994.
C              --KARL BURY, "STATISTICAL DISTRIBUTIONS IN
C                ENGINEERING", CAMBRIDGE UNIVERSITY PRESS,
C                1999, CHAPTER 14.
C     WRITTEN BY--ALAN HECKERT
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     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2010/07
C     ORIGINAL VERSION--JULY      2010. EXTRACTED AS A SEPARATE
C                                       SUBROUTINE (FROM DPMLTO)
C
      CHARACTER*4 ISUBRO
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 IWRITE
      CHARACTER*40 IDIST
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 ISTEPN
C
      INTEGER IFLAG
C
      DOUBLE PRECISION TOL
      DOUBLE PRECISION XPAR(2)
      DOUBLE PRECISION FVEC(2)
CCCCC DOUBLE PRECISION DAE
CCCCC DOUBLE PRECISION DRE
CCCCC DOUBLE PRECISION DXSTRT
CCCCC DOUBLE PRECISION DXLOW
CCCCC DOUBLE PRECISION DXUP
C
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DPROD1
      DOUBLE PRECISION DPROD2
      DOUBLE PRECISION DN
C
      EXTERNAL BETFUN
      COMMON /BETMLE/ BETALL, BETAUL
C
C---------------------------------------------------------------------
C
      DIMENSION Y(*)
      DOUBLE PRECISION DTEMP1(*)
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='BETM'
      ISUBN2='L1  '
C
      IWRITE='OFF'
      IERROR='NO'
C
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'TML1')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,51)
   51   FORMAT('**** AT THE BEGINNING OF BETML1--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,52)IBUGA3,ISUBRO,N,MAXNXT
   52   FORMAT('IBUGA3,ISUBRO,N,MAXNXT = ',A4,2X,A4,2X,2I8)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,53)AUSER,BUSER
   53   FORMAT('AUSER,BUSER = ',2G15.7)
        CALL DPWRST('XXX','WRIT')
        DO56I=1,MIN(N,100)
          WRITE(ICOUT,57)I,Y(I)
   57     FORMAT('I,Y(I) = ',I8,G15.7)
          CALL DPWRST('XXX','WRIT')
   56   CONTINUE
      ENDIF
C
C               ******************************************
C               **  STEP 1--                            **
C               **  CARRY OUT CALCULATIONS              **
C               **  FOR BETA MLE ESTIMATE               **
C               ******************************************
C
      ISTEPN='1'
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'TML1')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IDIST='BETA'
      IFLAG=0
      CALL SORT(Y,N,Y)
      CALL SUMRAW(Y,N,IDIST,IFLAG,
     1            XMEAN,XVAR,XSD,XMIN,XMAX,
     1            ISUBRO,IBUGA3,IERROR)
      IF(IERROR.EQ.'YES')GOTO9000
C
C     NOTE 2013/06: IF NO USER LIMITS GIVEN, SET FUDGE FACTOR TO
C                   1% (INSTEAD OF A VERY SMALL FIXED EPSION VALUE).
C
      IF((AUSER.EQ.CPUMIN .OR. BUSER.EQ.CPUMIN) .OR.
     1   (AUSER.GE.XMIN .OR. BUSER.LE.XMAX))THEN
        IF((XMIN.GE.0.0 .AND. XMIN.LE.1.0) .AND.
     1     (XMAX.GE.0.0 .AND. XMAX.LE.1.0))THEN
          A=0.0
          B=1.0
        ELSE
          EPS=(XMAX - XMIN)*0.01
          A=XMIN - EPS
          B=XMAX + EPS
        ENDIF
        BETALL=A
        BETAUL=B
      ELSE
        BETALL=AUSER
        BETAUL=BUSER
        A=AUSER
        B=BUSER
      ENDIF
C
      XMEAN1=(XMEAN-A)/(B-A)
      VAR1=XVAR/((B-A)**2)
      ALPHMO=XMEAN1*(XMEAN1*(1.0-XMEAN1)/VAR1 - 1.0)
      BETAMO=(1.0-XMEAN1)*(XMEAN1*(1.0-XMEAN1)/VAR1 - 1.0)
C
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'TML1')THEN
        WRITE(ICOUT,1001)A,B,BETALL,BETAUL
 1001   FORMAT('A,B,BETALL,BETAUL = ',4G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,1003)XVAR,VAR1,XMEAN1,ALPHMO,BETAMO
 1003   FORMAT('XVAR,VAR1,XMEAN1,ALPHMO,BETAMO = ',5G15.7)
        CALL DPWRST('XXX','WRIT')
      ENDIF
C
      XPAR(1)=DBLE(ALPHMO)
      XPAR(2)=DBLE(BETAMO)
      DPROD1=1.0D0
      DPROD2=1.0D0
      DN=DBLE(N)
C
      DO3101I=1,N
        DTERM1=DBLE((B-Y(I))/(B-A))**(1.0D0/DN)
        DTERM2=DBLE( (Y(I)-A)/(B-A))**(1.0D0/DN)
        IF(DTERM1.NE.0.0D0)DPROD1=DPROD1*DTERM1
        IF(DTERM2.NE.0.0D0)DPROD2=DPROD2*DTERM2
 3101 CONTINUE
CCCCC XPAR(1)=0.5D0*(1.0D0 - DPROD1)/(1.0D0 - DPROD2 - DPROD1)
C
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'TML1')THEN
        WRITE(ICOUT,1011)DPROD1,DPROD2,XPAR(1)
 1011   FORMAT('DPROD1,DPROD2,XPAR(1) = ',3G15.7)
        CALL DPWRST('XXX','WRIT')
      ENDIF
C
      DO3103I=1,N
        DTERM1=DBLE((Y(I)-A)/(B-A))**(1.0D0/DN)
        DTERM2=DBLE( (B-Y(I))/(B-A))**(1.0D0/DN)
        IF(DTERM1.NE.0.0D0)DPROD1=DPROD1*DTERM1
        IF(DTERM2.NE.0.0D0)DPROD2=DPROD2*DTERM2
 3103 CONTINUE
CCCCC XPAR(2)=0.5D0*(1.0D0 - DPROD1)/(1.0D0 - DPROD1 - DPROD2)
C
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'TML1')THEN
        WRITE(ICOUT,1013)DPROD1,DPROD2,XPAR(2)
 1013   FORMAT('DPROD1,DPROD2,XPAR(2) = ',3G15.7)
        CALL DPWRST('XXX','WRIT')
      ENDIF
C
      IOPT=2
      TOL=1.0D-6
      NVAR=2
      NPRINT=-1
      INFO=0
      LWA=MAXNXT
      CALL DNSQE(BETFUN,JAC,IOPT,NVAR,XPAR,FVEC,TOL,NPRINT,INFO,
     1           DTEMP1,MAXNXT,Y,N)
C
      ALPHML=REAL(XPAR(1))
      BETAML=REAL(XPAR(2))
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'TML1')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9011)
 9011   FORMAT('**** AT THE END OF BETML1--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9055)N,XMEAN,XSD,XMIN,XMAX
 9055   FORMAT('N,XMEAN,XSD,XMIN,XMAX = ',I8,4G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9057)ALPHMO,BETAMO,ALPHML,BETAML
 9057   FORMAT('ALPHMO,BETAMO,ALPHML,BETAML = ',4G15.7)
        CALL DPWRST('XXX','WRIT')
      ENDIF
C
      RETURN
      END
      SUBROUTINE BETML4(Y,N,DTEMP1,MAXNXT,
     1                  XMIN,XMAX,XMEAN,XSD,XVAR,
     1                  AMOM,BMOM,ALPHMO,BETAMO,
     1                  AML,BML,ALPHML,BETAML,MLFLAG,
     1                  ISUBRO,IBUGA3,IERROR)
C
C     PURPOSE--THIS ROUTINE COMPUTES THE MAXIMUM LIKELIHOOD AND
C              METHOD OF MOMENT ESTIMATES FOR THE BETA DISTRIBUTION.
C              THIS IS FOR THE 4-PARAMETER CASE (I.E., THE LOWER
C              AND UPPER LIMITS ARE ESTIMATED FROM THE DATA).
C
C              NOTE THAT ML ESTIMATION CAN BE PROBLEMATIC FOR THE
C              4-PARAMETER BETA, PARTICULARLY FOR SMALL SAMPLES.
C              RETURN A FLAG THAT INDICATES WHETHER OR NOT ML
C              PROCEDURE CONVERGED.
C
C     EXAMPLE--4-PARAMETER BETA MAXIMUM LIKELIHOOD Y
C     REFERENCE--EVANS, HASTINGS, AND PEACOCK.  "STATISTICAL
C                DISTRIBUTIONS", THIRD EDITION, WILEY, 2000,
C                PP. 34-42.
C                JOHNSON, KOTZ, AND BALAKRISHNAN.  "CONTINUOUS
C                UNIVARIATE DISTRIBUTIONS, VOLUME II", SECOND
C                EDITION, WILEY, 1994.
C              --KARL BURY, "STATISTICAL DISTRIBUTIONS IN
C                ENGINEERING", CAMBRIDGE UNIVERSITY PRESS,
C                1999, CHAPTER 14.
C     WRITTEN BY--ALAN HECKERT
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     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2010/07
C     ORIGINAL VERSION--JULY      2010. EXTRACTED AS A SEPARATE
C                                       SUBROUTINE (FROM DPMLB4)
C     UPDATED         --JUNE      2013. IF "IDFTTY" IS SET TO MOMENTS,
C                                       THEN SKIP ML STEP
C
      CHARACTER*4 ISUBRO
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 IWRITE
      CHARACTER*40 IDIST
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 ISTEPN
C
      INTEGER IFLAG
C
      DOUBLE PRECISION TOL
      DOUBLE PRECISION XPAR(2)
      DOUBLE PRECISION FVEC(2)
CCCCC DOUBLE PRECISION DAE
CCCCC DOUBLE PRECISION DRE
CCCCC DOUBLE PRECISION DXSTRT
CCCCC DOUBLE PRECISION DXLOW
CCCCC DOUBLE PRECISION DXUP
C
      DOUBLE PRECISION BE4FUN
      EXTERNAL BE4FUN
      DOUBLE PRECISION BE4FU2
      EXTERNAL BE4FU2
C
CCCCC DOUBLE PRECISION DEPS
      DOUBLE PRECISION DN
CCCCC DOUBLE PRECISION DANS(10)
      DOUBLE PRECISION DA
      DOUBLE PRECISION DB
CCCCC DOUBLE PRECISION DC
CCCCC DOUBLE PRECISION DALPHA
CCCCC DOUBLE PRECISION DBETA
CCCCC DOUBLE PRECISION DALPBE
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
CCCCC DOUBLE PRECISION DTERM3
CCCCC DOUBLE PRECISION DTERM4
CCCCC DOUBLE PRECISION DTERM5
CCCCC DOUBLE PRECISION DTERM6
CCCCC DOUBLE PRECISION DTERM7
CCCCC DOUBLE PRECISION DTERM8
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DSUM2
      DOUBLE PRECISION DSUM3
      DOUBLE PRECISION DSUM4
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DM1
      DOUBLE PRECISION DM2
      DOUBLE PRECISION DM3
      DOUBLE PRECISION DM4
C
      DOUBLE PRECISION DM1P
      DOUBLE PRECISION DM2P
      DOUBLE PRECISION DM3P
      DOUBLE PRECISION DM4P
      COMMON /BET4ML/ DM2P, DM3P, DM4P
C
      DOUBLE PRECISION SIGMA
      DOUBLE PRECISION S5
      DOUBLE PRECISION S6
      DOUBLE PRECISION S7
      DOUBLE PRECISION S8
      DOUBLE PRECISION DXMIN
      DOUBLE PRECISION DXMAX
      COMMON /BET4M2/ S5, S6, S7, S8, SIGMA, DXMIN, DXMAX
C
C---------------------------------------------------------------------
C
      DIMENSION Y(*)
      DOUBLE PRECISION DTEMP1(*)
C
      INCLUDE 'DPCOST.INC'
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='BETM'
      ISUBN2='L4  '
C
      IWRITE='OFF'
      IERROR='NO'
C
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'TML4')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,51)
   51   FORMAT('**** AT THE BEGINNING OF BETML1--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,52)IBUGA3,ISUBRO,N,MAXNXT
   52   FORMAT('IBUGA3,ISUBRO,N,MAXNXT = ',A4,2X,A4,2X,2I8)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,53)AUSER,BUSER
   53   FORMAT('AUSER,BUSER = ',2G15.7)
        CALL DPWRST('XXX','WRIT')
        DO56I=1,MIN(N,100)
          WRITE(ICOUT,57)I,Y(I)
   57     FORMAT('I,Y(I) = ',I8,G15.7)
          CALL DPWRST('XXX','WRIT')
   56   CONTINUE
      ENDIF
C
C               ******************************************
C               **  STEP 1--                            **
C               **  CARRY OUT CALCULATIONS              **
C               **  FOR BETA MLE ESTIMATE               **
C               ******************************************
C
      ISTEPN='1'
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'TML4')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      AMOM=CPUMIN
      BMOM=CPUMIN
      ALPHMO=CPUMIN
      BETAMO=CPUMIN
      AML=CPUMIN
      BML=CPUMIN
      ALPHML=CPUMIN
      BETAML=CPUMIN
C
      IDIST='BETA'
      IFLAG=0
      CALL SORT(Y,N,Y)
      CALL SUMRAW(Y,N,IDIST,IFLAG,
     1            XMEAN,XVAR,XSD,XMIN,XMAX,
     1            ISUBRO,IBUGA3,IERROR)
      IF(IERROR.EQ.'YES')GOTO9000
C
      DN=DBLE(N)
      DSUM1=0.0D0
      DSUM2=0.0D0
      DSUM3=0.0D0
      DSUM4=0.0D0
      DO1010I=1,N
        DSUM1=DSUM1 + DBLE(Y(I))
        DSUM2=DSUM2 + DBLE(Y(I))**2
        DSUM3=DSUM3 + DBLE(Y(I))**3
        DSUM4=DSUM4 + DBLE(Y(I))**4
 1010 CONTINUE
      DM1=DSUM1/DN
      DM2=DSUM2/DN
      DM3=DSUM3/DN
      DM4=DSUM4/DN
      DM1P=DM1
      DM2P=DM2 - DM1**2
      DM3P=DM3 - 3.0D0*DM1*DM2 + 2.0D0*(DM1**3)
      DM4P=DM4 - 4.0D0*DM1*DM3 + 6.0D0*(DM1**2)*DM2 - 3.0D0*(DM1**4)
C
      XPAR(1)=1.0D0
      XPAR(2)=1.0D0
C
      IOPT=2
      TOL=1.0D-6
      NVAR=2
      NPRINT=-1
      INFO=0
      LWA=MAXNXT
      CALL DNSQE(BE4FUN,JAC,IOPT,NVAR,XPAR,FVEC,TOL,NPRINT,INFO,
     1           DTEMP1,MAXNXT,Y,N)
C
      ALPHMO=REAL(XPAR(1))
      BETAMO=REAL(XPAR(2))
C
      EPS=DBLE(XMAX - XMIN)*0.001D0
      DA=DBLE(ALPHMO)
      DB=DBLE(BETAMO)
      DTERM1=DA*(DA+DB+1.0D0)
      DTERM2=DB
      AMOM=DM1 - DSQRT(DM2P)*DSQRT(DTERM1/DTERM2)
      DTERM1=DB*(DA+DB+1.0D0)
      DTERM2=DA
      BMOM=DM1 + DSQRT(DM2P)*DSQRT(DTERM1/DTERM2)
      IF(AMOM.GE.XMIN)AMOM=XMIN - EPS
      IF(BMOM.LE.XMAX)BMOM=XMAX + EPS
C
C     NOW ATTEMPT ML ESTIMATION
C
      IF(IDFTTY.EQ.'MOME')THEN
        AML=CPUMIN
        BML=CPUMIN
        ALPHML=CPUMIN
        BETAML=CPUMIN
        GOTO9000
      ENDIF
C
      XPAR(1)=DBLE(AMOM)
      XPAR(2)=DBLE(BMOM)
C
      DXMIN=DBLE(XMIN)
      DXMAX=DBLE(XMAX)
C
      IF(DA.GE.DXMIN)THEN
        XPAR(1)=DXMIN - 0.1*(DXMAX-DXMIN)
      ENDIF
      IF(DB.LE.DXMAX)THEN
        XPAR(2)=DXMAX + 0.1*(DXMAX-DXMIN)
      ENDIF
C
      IOPT=2
      TOL=1.0D-5
      NVAR=2
      NPRINT=-1
      INFO=0
      LWA=MAXNXT
      CALL DNSQE(BE4FU2,JAC,IOPT,NVAR,XPAR,FVEC,TOL,NPRINT,INFO,
     1           DTEMP1,MAXNXT,Y,N)
C
      IF(INFO.NE.1)THEN
        MLFLAG=1
        GOTO4099
      ELSE
        MLFLAG=0
      ENDIF
      AML=REAL(XPAR(1))
      BML=REAL(XPAR(2))
C
C     SOMETIMES WE CAN GET "CONVERGENCE" TO AN UNREASONABLE VALUE.
C     CHECK THAT LOWER/UPPER LIMITS WITHIN 3 TIMES THE WIDTH
C     OF THE DATA.
C
      XWIDTH=XMAX - XMIN
      XUPP=XMAX + 3.0*XWIDTH
      XLOW=XMIN - 3.0*XWIDTH
      IF(AML.LT.XLOW .OR. BML.GT.XUPP)THEN
        MLFLAG=1
        GOTO4099
      ENDIF
C
      ALPHML=REAL(S5*(SIGMA*S6-1.0D0)/(S6*(SIGMA*S5-1.0D0)-S5))
      BETAML=REAL(S6*(SIGMA*S5-1.0D0)/(S6*(SIGMA*S5-1.0D0)-S5))
C
 4099 CONTINUE
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'TML4')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9011)
 9011   FORMAT('**** AT THE END OF BETML1--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9055)N,XMEAN,XSD,XMIN,XMAX
 9055   FORMAT('N,XMEAN,XSD,XMIN,XMAX = ',I8,4G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9056)AMON,BMOM,ALPHMO,BETAMO
 9056   FORMAT('AMON,BMOM,ALPHMO,BETAMO = ',4G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9057)MLFLAG,AML,BML,ALPHML,BETAML
 9057   FORMAT('MLFLAG,AML,BML,ALPHML,BETAML = ',I5,4G15.7)
        CALL DPWRST('XXX','WRIT')
      ENDIF
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                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
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
      INCLUDE 'DPCOP2.INC'
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,103)ALPHA
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,104)BETA
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
C
C     IF ALPHA < 1, UNDEFINED AT 0
C     IF BETA  < 1, UNDEFINED AT 1
C
      IF(ALPHA.LT.1.0 .AND. BETA.LT.1.0)THEN
        IF(X.LE.0.0)THEN
          WRITE(ICOUT,301)X
          CALL DPWRST('XXX','BUG ')
          PDF=0.0
          GOTO9999
        ELSEIF(X.GE.1.0)THEN
          WRITE(ICOUT,402)X
          CALL DPWRST('XXX','BUG ')
          PDF=0.0
          GOTO9999
        ENDIF
      ELSEIF(ALPHA.LT.1.0)THEN
        IF(X.LE.0.0)THEN
          WRITE(ICOUT,301)X
          CALL DPWRST('XXX','BUG ')
          PDF=0.0
          GOTO9999
        ENDIF
        IF(X.GT.1.0)THEN
          WRITE(ICOUT,401)X
          CALL DPWRST('XXX','BUG ')
          PDF=0.0
          GOTO9999
        ENDIF
      ELSEIF(BETA.LT.1.0)THEN
        IF(X.LT.0.0)THEN
          WRITE(ICOUT,302)X
          CALL DPWRST('XXX','BUG ')
          PDF=0.0
          GOTO9999
        ENDIF
        IF(X.GE.1.0)THEN
          WRITE(ICOUT,402)X
          CALL DPWRST('XXX','BUG ')
          PDF=0.0
          GOTO9999
        ENDIF
      ENDIF
  101 FORMAT('***** ERROR IN BETCDF--EITHER THE ALPHA OR BETA IS ',
     1       'NON-POSITIVE.')
  103 FORMAT('      THE VALUE OF ALPHA IS ',G15.7)
  104 FORMAT('      THE VALUE OF BETA IS  ',G15.7)
  301 FORMAT('***** ERROR--THE FIRST ARGUMENT TO BETPDF IS ',
     1       'NON-POSITIVE.  IT HAS THE VALUE ',G15.7)
  302 FORMAT('***** ERROR--THE FIRST ARGUMENT TO BETPDF IS ',
     1       'NEGATIVE.  IT HAS THE VALUE ',G15.7)
  401 FORMAT('***** ERROR--THE FIRST ARGUMENT TO BETPDF IS GREATER ',
     1       'THAN 1.  IT HAS THE VALUE ',G15.7)
  402 FORMAT('***** ERROR--THE FIRST ARGUMENT TO BETPDF IS GREATER ',
     1       'THAN OR EQUAL TO 1.  IT HAS THE VALUE ',G15.7)
C
CCCCC IF(X.LE.0.0.OR.X.GE.1.0)GOTO900
      IF(X.LE.0.0)THEN
        IF(ALPHA.EQ.1.0 .AND. BETA.EQ.1.0)THEN
          PDF=1.0
        ELSE
          PDF=0.0
        ENDIF
      ELSEIF(X.GE.1.0)THEN
        IF(ALPHA.EQ.1.0 .AND. BETA.EQ.1.0)THEN
          PDF=1.0
        ELSE
          PDF=0.0
        ENDIF
      ELSE
        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)
      ENDIF
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                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
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
      INCLUDE 'DPCOP2.INC'
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('***** ERROR--THE FIRST ARGUMENT TO ',
     1       'BETPPF IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL')
   11 FORMAT('***** ERROR--THE SECOND ARGUMENT TO ',
     1       'BETPPF IS NON-POSITIVE')
   25 FORMAT('***** ERROR--THE THIRD ARGUMENT TO ',
     1       'BETPPF IS NON-POSITIVE')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
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 INSTITUTE OF STANDARDS AND TECHNOLOGY APPLIED MATHEMATICS
C                 SERIES 55, 1964, PAGE 952.
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-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1966)
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
      INCLUDE 'DPCOP2.INC'
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
      SUBROUTINE BE4FUN (N,X,FVEC,IFLAG,XDATA,NOBS)
C
C     PURPOSE--THIS ROUTINE COMPUTES THE FUNCTIONS FOR THE
C              FOUR-PARAMETER BETA METHOD OF MOMENT EQUATIONS
C              TO ESTIMATE THE ALPHA AND BETA SHAPE PARAMETERS:
C
C              {2*(BETA-ALPHA)/(ALPHA+BETA+2)}*
C              SQRT((ALPHA+BETA+1)/(ALPHA*BETA)) - M3/M2**(3/2)=0
C
C              3*(ALPHA+BETA+1)*[2*(ALPHA+BETA)**2 +
C              ALPHA*APHA2*(ALPHA+BETA-6)]/
C              {ALPHA*BETA*(ALPHA+BETA+2)*(ALPHA+BETA+3)} -
C              M4/M2**2 = 0
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 MAXIMUM LIKELIHOOD Y
C     REFERENCE--KARL BURY, "STATISTICAL DISTRIBUTIONS IN
C                ENGINEERING", CAMBRIDGE UNIVERSITY PRESS,
C                1999, CHAPTER 14.
C     WRITTEN BY--ALAN HECKERT
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     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2007/6
C     ORIGINAL VERSION--JUNE      2007.
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION X(*)
      DOUBLE PRECISION FVEC(*)
      REAL XDATA(*)
C
      DOUBLE PRECISION DA
      DOUBLE PRECISION DB
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
      DOUBLE PRECISION DTERM4
      DOUBLE PRECISION DTERM5
      DOUBLE PRECISION DTERM6
      DOUBLE PRECISION DTERM7
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DM2, DM3, DM4
      COMMON /BET4ML/ DM2, DM3, DM4
C
      INCLUDE 'DPCOBE.INC'
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      N=2
      IFLAG=0
C
      IF(ISUBG4.EQ.'4FUN')THEN
        WRITE(ICOUT,52)NOBS,XDATA(1)
   52   FORMAT('NOBS,XDATA(1) = ',I8,G15.7)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      DA=X(1)
      DB=X(2)
C
      DTERM1=2.0D0*(DB-DA)/(DA+DB+2.0D0)
      DTERM2=DSQRT((DA+DB+1.0D0)/(DA*DB))
      DTERM3=DM3/(DM2**1.5)
C
      DTERM4=3.0D0*(DA+DB+1.0D0)
      DTERM5=2.0D0*(DA+DB)**2 + DA*DB*(DA+DB-6.0D0)
      DTERM6=DA*DB*(DA+DB+2.0D0)*(DA+DB+3.0D0)
      DTERM7=DM4/(DM2**2)
C
      FVEC(1)=(DTERM1*DTERM2) - DTERM3
      FVEC(2)=(DTERM4*DTERM5/DTERM6) - DTERM7
C
      RETURN
      END
      SUBROUTINE BE4FU2 (N, X, FVEC, IFLAG, XDATA, NOBS)
C
C     PURPOSE--THIS ROUTINE COMPUTES THE FUNCTIONS FOR THE
C              FOUR-PARAMETER BETA MAXIMUM LIKELIHOOD EQUATIONS
C              TO ESTIMATE THE A AND B LOWER AND UPPER LIMIT
C              PARAMETERS:
C
C              PSI(S5*(SIGMA*S6-1)/(S6*(SIGMA*S5-1)-S5)) -
C              PSI(1 + S5*SIGMA*S6/(S6*(SIGMA*S5-1)-S5)) -
C              S7 - LOG(SIGMA) = 0
C
C              PSI(S6*(SIGMA*S5-1)/(S6*(SIGMA*S5-1)-S5)) -
C              PSI(1 + S5*SIGMA*S6/(S6*(SIGMA*S5-1)-S5)) -
C              S8 - LOG(SIGMA) = 0
C
C              WHERE
C
C              PSI = DIGAMMA FUNCTION
C              S5 = (1/N)*SUM[1/(X(I) - A)]
C              S6 = (1/N)*SUM[1/(X(I) - B)]
C              S7 = (1/N)*SUM[LOG(X(I) - A)]
C              S8 = (1/N)*SUM[LOG(B - X(I))]
C              SIGMA = B - A
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--FOUR PARAMETER BETA MAXIMUM LIKELIHOOD Y
C     REFERENCE--KARL BURY, "STATISTICAL DISTRIBUTIONS IN
C                ENGINEERING", CAMBRIDGE UNIVERSITY PRESS,
C                1999, CHAPTER 14.
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     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2007/6
C     ORIGINAL VERSION--JUNE      2007.
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION X(*)
      DOUBLE PRECISION FVEC(*)
      REAL XDATA(*)
C
      DOUBLE PRECISION DA
      DOUBLE PRECISION DB
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
      DOUBLE PRECISION DENOM
      DOUBLE PRECISION DX
      DOUBLE PRECISION DN
      DOUBLE PRECISION DLGSIG
      DOUBLE PRECISION DPSI
C
      EXTERNAL DPSI
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION SIGMA
      DOUBLE PRECISION S5
      DOUBLE PRECISION S6
      DOUBLE PRECISION S7
      DOUBLE PRECISION S8
      DOUBLE PRECISION DXMIN
      DOUBLE PRECISION DXMAX
      COMMON /BET4M2/ S5, S6, S7, S8, SIGMA, DXMIN, DXMAX
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      N=2
      IFLAG=0
C
      DA=X(1)
      DB=X(2)
      SIGMA=DB - DA
      DLGSIG=DLOG(SIGMA)
      DN=DBLE(NOBS)
      IF(DA.GE.DXMIN .OR. DB.LE.DXMAX) THEN
        FVEC(1)=99.0D0
        FVEC(2)=99.0D0
        GOTO9000
      ENDIF
C
      S5=0.0D0
      S6=0.0D0
      S7=0.0D0
      S8=0.0D0
C
      DO100I=1,NOBS
        DX=DBLE(XDATA(I))
        S5=S5 + 1.0D0/(DX-DA)
        S6=S6 + 1.0D0/(DB-DX)
        S7=S7 + DLOG(DX-DA)
        S8=S8 + DLOG(DB-DX)
  100 CONTINUE
      S5=S5/DN
      S6=S6/DN
      S7=S7/DN
      S8=S8/DN
C
      DENOM=S6*(SIGMA*S5 - 1.0D0) - S5
      DTERM1=S5*(SIGMA*S6 - 1.0D0)
      DTERM2=DPSI(DTERM1/DENOM)
      DTERM3=DPSI(1.0D0 + (SIGMA*S5*S6/DENOM))
      FVEC(1)=DTERM2 - DTERM3 - S7 + DLGSIG
C
      DTERM1=S6*(SIGMA*S5 - 1.0D0)
      DTERM2=DPSI(DTERM1/DENOM)
      DTERM3=DPSI(1.0D0 + (SIGMA*S5*S6/DENOM))
      FVEC(2)=DTERM2 - DTERM3 - S8 + DLGSIG
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'
      INCLUDE 'DPCOP2.INC'
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'
      INCLUDE 'DPCOP2.INC'
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
      DOUBLE PRECISION FUNCTION bfrac(a,b,x,y,lambda,eps)
C-----------------------------------------------------------------------
C     CONTINUED FRACTION EXPANSION FOR IX(A,B) WHEN A,B .GT. 1.
C     IT IS ASSUMED THAT  LAMBDA = (A + B)*Y - B.
C-----------------------------------------------------------------------
C     .. Scalar Arguments ..
      DOUBLE PRECISION a,b,eps,lambda,x,y
C     ..
C     .. Local Scalars ..
      DOUBLE PRECISION alpha,an,anp1,beta,bn,bnp1,c,c0,c1,e,n,p,r,r0,s,
     +                 t,w,yp1
C     ..
C     .. External Functions ..
      DOUBLE PRECISION brcomp
      EXTERNAL brcomp
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC abs
C     ..
C     .. Executable Statements ..
C--------------------
      bfrac = brcomp(a,b,x,y)
      IF (bfrac.EQ.0.0D0) RETURN
C
      c = 1.0D0 + lambda
      c0 = b/a
      c1 = 1.0D0 + 1.0D0/a
      yp1 = y + 1.0D0
C
      n = 0.0D0
      p = 1.0D0
      s = a + 1.0D0
      an = 0.0D0
      bn = 1.0D0
      anp1 = 1.0D0
      bnp1 = c/c1
      r = c1/c
C
C        CONTINUED FRACTION CALCULATION
C
   10 n = n + 1.0D0
      t = n/a
      w = n* (b-n)*x
      e = a/s
      alpha = (p* (p+c0)*e*e)* (w*x)
      e = (1.0D0+t)/ (c1+t+t)
      beta = n + w/s + e* (c+n*yp1)
      p = 1.0D0 + t
      s = s + 2.0D0
C
C        UPDATE AN, BN, ANP1, AND BNP1
C
      t = alpha*an + beta*anp1
      an = anp1
      anp1 = t
      t = alpha*bn + beta*bnp1
      bn = bnp1
      bnp1 = t
C
      r0 = r
      r = anp1/bnp1
      IF (abs(r-r0).LE.eps*r) GO TO 20
C
C        RESCALE AN, BN, ANP1, AND BNP1
C
      an = an/bnp1
      bn = bn/bnp1
      anp1 = r
      bnp1 = 1.0D0
      GO TO 10
C
C                 TERMINATION
C
   20 bfrac = bfrac*r
      RETURN

      END
      SUBROUTINE BFRCDF(X,ALPHA,BETA,R,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE BRITTLE FRACTURE DISTRIBUTION
C              WITH DOUBLE PRECISION SHAPE PARAMETERS ALPHA, BETA,
C              AND R.  THE BRITTLE FRACTURE DISTRIBUTION HAS
C              THE CUMULATIVE DISTRIBUTION FUNCTION
C
C              F(X;ALPHA,BETA,R) = 1 - EXP(-ALPHA*X**(2*R)*
C                                  EXP(-BETA/X**2))
C                                  X > 0; ALPHA, R > 0; BETA >= 0
C
C     INPUT  ARGUMENTS--X      = THE DOUBLE PRECISION VALUE
C                                AT WHICH THE CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C                     --ALPHA  = THE DOUBLE PRECISION VALUE
C                                OF THE FIRST SHAPE PARAMETER.
C                     --BETA   = THE DOUBLE PRECISION VALUE
C                                OF THE SECOND SHAPE PARAMETER.
C                     --R      = THE DOUBLE PRECISION VALUE
C                                OF THE THIRD 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 FOR THE BRITTLE FRACTURE
C             DISTRIBUTION WITH SHAPE PARAMETERS ALPHA, BETA AND R.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--ALPHA AND R SHOULD BE POSITIVE AND BETA SHOULD BE
C                   NON-NEGATIVE.
C                 --X SHOULD BE POSITIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--EXP.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN.
C     REFERENCES--BLACK, DURHAM, AND PADGETT (1990), "PARAMETER
C                 ESTIMATION FOR A NEW DISTRIBUTION FOR THE STRENGTH
C                 OF BRITTLE FIBERS: A SIMULATION STUDY",
C                 COMMUNICATIONS IN STATISTICS--SIMULATION AND
C                 COMPUTATION, VOL. 19, PP. 809-825
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE:  301-975-2855
C     ORIGINAL VERSION--MARCH     2008.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      INCLUDE 'DPCOP2.INC'
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      CDF=0.0D0
      IF(X.LE.0.0D0)THEN
        GOTO9000
      ELSEIF(ALPHA.LE.0.0D0)THEN
        WRITE(ICOUT,15)
   15   FORMAT('***** ERROR--THE SECOND ARGUMENT TO BFRCDF IS ',
     1       'NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ALPHA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(BETA.LT.0.0D0)THEN
        WRITE(ICOUT,25)
   25   FORMAT('***** ERROR--THE THIRD ARGUMENT TO BFRCDF IS ',
     1       'NEGATIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)BETA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(R.LE.0.0D0)THEN
        WRITE(ICOUT,35)
   35   FORMAT('***** ERROR--THE FOURTH ARGUMENT TO BFRCDF IS ',
     1       'NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)R
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
C
C-----START POINT-----------------------------------------------------
C
      DTERM1=DEXP(-BETA/X**2)
      DTERM2=DEXP(-ALPHA*X**(2.0D0*R)*DTERM1)
      CDF=1.0D0 - DTERM2
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE BFRCHA(X,ALPHA,BETA,R,HAZ)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE HAZARD
C              FUNCTION VALUE FOR THE BRITTLE FRACTURE DISTRIBUTION
C              WITH DOUBLE PRECISION SHAPE PARAMETERS ALPHA, BETA,
C              AND R.  THE BRITTLE FRACTURE DISTRIBUTION HAS
C              THE CUMULATIVE HAZARD FUNCTION
C
C              H(X;ALPHA,BETA,R) = -ALPHA*X**(2*R)*EXP(-BETA/X**2)
C                                  X > 0; ALPHA, R > 0; BETA >= 0
C
C     INPUT  ARGUMENTS--X      = THE DOUBLE PRECISION VALUE
C                                AT WHICH THE CUMULATIVE HAZARD
C                                FUNCTION IS TO BE EVALUATED.
C                     --ALPHA  = THE DOUBLE PRECISION VALUE
C                                OF THE FIRST SHAPE PARAMETER.
C                     --BETA   = THE DOUBLE PRECISION VALUE
C                                OF THE SECOND SHAPE PARAMETER.
C                     --R      = THE DOUBLE PRECISION VALUE
C                                OF THE THIRD SHAPE PARAMETER.
C     OUTPUT ARGUMENTS--HAZ    = THE DOUBLE PRECISION CUMULATIVE
C                                HAZARD FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION CUMULATIVE HAZARD
C             FUNCTION VALUE HAZ FOR THE BRITTLE FRACTURE
C             DISTRIBUTION WITH SHAPE PARAMETERS ALPHA, BETA AND R.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--ALPHA AND R SHOULD BE POSITIVE AND BETA SHOULD BE
C                   NON-NEGATIVE.
C                 --X SHOULD BE POSITIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--EXP.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN.
C     REFERENCES--BLACK, DURHAM, AND PADGETT (1990), "PARAMETER
C                 ESTIMATION FOR A NEW DISTRIBUTION FOR THE STRENGTH
C                 OF BRITTLE FIBERS: A SIMULATION STUDY",
C                 COMMUNICATIONS IN STATISTICS--SIMULATION AND
C                 COMPUTATION, VOL. 19, PP. 809-825
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE:  301-975-2855
C     ORIGINAL VERSION--MARCH     2008.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      INCLUDE 'DPCOP2.INC'
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      HAZ=0.0D0
      IF(X.LE.0.0D0)THEN
        GOTO9000
      ELSEIF(ALPHA.LE.0.0D0)THEN
        WRITE(ICOUT,15)
   15   FORMAT('***** ERROR--THE SECOND ARGUMENT TO BFRCHAZ IS ',
     1       'NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ALPHA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(BETA.LT.0.0D0)THEN
        WRITE(ICOUT,25)
   25   FORMAT('***** ERROR--THE THIRD ARGUMENT TO BFRCHAZ IS ',
     1       'NEGATIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)BETA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(R.LE.0.0D0)THEN
        WRITE(ICOUT,35)
   35   FORMAT('***** ERROR--THE FOURTH ARGUMENT TO BFRCHAZ IS ',
     1       'NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)R
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
C
C-----START POINT-----------------------------------------------------
C
CCCCC DTERM1=DEXP(-BETA/X**2)
CCCCC HAZ=ALPHA*X**(2.0D0*R)*DTERM1
      DTERM1=DLOG(ALPHA) + (2.0D0*R)*DLOG(X) - BETA/X**2
      HAZ=DEXP(DTERM1)
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE BFRFUN (N, X, FVEC, IFLAG, XDATA, NOBS)
C
C     PURPOSE-THIS ROUTINE COMPUTES THE FUNCTIONS FOR THE
C             BRITTLE FRACTURE MAXIMUM LIKELIHOOD EQUATIONS.
C             SPECIFICALLY IT SOLVES FOR BETA AND R BY
C             SOLVING THE EQUATIONS:
C
C             0 = (ANUM/ADEN) + SUM[i=1 to N][1/(r*X(i)**2 + BETA) -
C                 SUM[i=1 to N][X(i)**2]
C
C                 ANUM = N*SUM[i=1 TO N][X(i)**2**(2*R-2)*
C                        EXP(-BETA/X(i)**2)
C                 ADEN = SUM[i=1 TO N][X(i)**(2*R)*EXP(-BETA/X(i)**2)]
C
C             0 = 2*SUM[i=1 TO N][LOG(X(i))] +
C                 SUM[i=1 TO N][1/(R + BETA/X(i)**2)] - (ANUM/ADEN)
C
C                 ANUM = 2*SUM[i=1 TO N][LOG(X(i))*X(i)**(2*R)*
C                        EXP(-BETA/X(i)**2)]
C                 ADEN = SUM[i=1 TO N][X(i)**(2*R)*EXP(-BETA/X(i)**2)]
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--BRITTLE FRACTURE MAXIMUM LIKELIHOOD Y
C     REFERENCES--BLACK, DURHAM, AND PADGETT (1990), "PARAMETER
C                 ESTIMATION FOR A NEW DISTRIBUTION FOR THE STRENGTH
C                 OF BRITTLE FIBERS: A SIMULATION STUDY",
C                 COMMUNICATIONS IN STATISTICS--SIMULATION AND
C                 COMPUTATION, VOL. 19, PP. 809-825
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     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2008/3
C     ORIGINAL VERSION--MARCH     2008.
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION X(*)
      DOUBLE PRECISION FVEC(*)
      REAL XDATA(*)
C
      DOUBLE PRECISION DBETA
      DOUBLE PRECISION DR
      DOUBLE PRECISION DN
      DOUBLE PRECISION DX
      DOUBLE PRECISION DX2
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DSUM2
      DOUBLE PRECISION DSUM3
      DOUBLE PRECISION DSUM4
      DOUBLE PRECISION DSUM5
      DOUBLE PRECISION DSUM6
      DOUBLE PRECISION DSUM7
      DOUBLE PRECISION DSUM8
      DOUBLE PRECISION DTERM1
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C  COMPUTE SOME SUMS
C
      N=2
      IFLAG=0
C
      DN=DBLE(NOBS)
      DBETA=DBLE(X(1))
      DR=DBLE(X(2))
C
      DSUM1=0.0D0
      DSUM2=0.0D0
      DSUM3=0.0D0
      DSUM4=0.0D0
      DSUM5=0.0D0
      DSUM6=0.0D0
      DSUM7=0.0D0
      DSUM8=0.0D0
C
      DO200I=1,NOBS
C
        DX=DBLE(XDATA(I))
        DX2=DX*DX
        DTERM1=DEXP(-DBETA/DX2)
C
        DSUM1=DSUM1 + DX**(2.0D0*DR - 2.0D0)*DTERM1
        DSUM2=DSUM2 + DX**(2.0D0*DR)*DTERM1
        DSUM3=DSUM3 + 1.0D0/(DR*DX2 + DBETA)
        DSUM4=DSUM4 + DX2
C
        DSUM5=DSUM5 + DLOG(DX)
        DSUM6=DSUM6 + 1.0D0/(DR + DBETA/DX2)
        DSUM7=DSUM7 + DLOG(DX)*DX**(2.0D0*DR)*DTERM1
        DSUM8=DSUM8 + DX**(2.0D0*DR)*DTERM1
C
  200 CONTINUE
C
      FVEC(1)=DN*(DSUM1/DSUM2) + DSUM3 - DSUM4
      FVEC(2)=2.0D0*DSUM5 + DSUM6 - (2.0D0*DN*DSUM7/DSUM8)
C
      RETURN
      END
      SUBROUTINE BFRHAZ(X,ALPHA,BETA,R,HAZ)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE HAZARD
C              FUNCTION VALUE FOR THE BRITTLE FRACTURE DISTRIBUTION
C              WITH DOUBLE PRECISION SHAPE PARAMETERS ALPHA, BETA,
C              AND R.  THE BRITTLE FRACTURE DISTRIBUTION HAS
C              THE HAZARD FUNCTION
C
C              h(X;ALPHA,BETA,R) = f(x;ALPHA,BETA,R)/
C                                  (1 - F(X;ALPHA,BETA,R)
C                                  X > 0; ALPHA, R > 0; BETA >= 0
C              WITH f AND F DENOTING THE BRITTLE FRACTURE
C              PROBABILITY DENISTY AND CUMULATIVE DISTRIBUTION
c              FUNCTIONS, RESPECTIVELY.
C
C     INPUT  ARGUMENTS--X      = THE DOUBLE PRECISION VALUE
C                                AT WHICH THE HAZARD
C                                FUNCTION IS TO BE EVALUATED.
C                     --ALPHA  = THE DOUBLE PRECISION VALUE
C                                OF THE FIRST SHAPE PARAMETER.
C                     --BETA   = THE DOUBLE PRECISION VALUE
C                                OF THE SECOND SHAPE PARAMETER.
C                     --R      = THE DOUBLE PRECISION VALUE
C                                OF THE THIRD SHAPE PARAMETER.
C     OUTPUT ARGUMENTS--HAZ    = THE DOUBLE PRECISION HAZARD
C                                FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION HAZARD
C             FUNCTION VALUE HAZ FOR THE BRITTLE FRACTURE
C             DISTRIBUTION WITH SHAPE PARAMETERS ALPHA, BETA AND R.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--ALPHA AND R SHOULD BE POSITIVE AND BETA SHOULD BE
C                   NON-NEGATIVE.
C                 --X SHOULD BE POSITIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--EXP.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN.
C     REFERENCES--BLACK, DURHAM, AND PADGETT (1990), "PARAMETER
C                 ESTIMATION FOR A NEW DISTRIBUTION FOR THE STRENGTH
C                 OF BRITTLE FIBERS: A SIMULATION STUDY",
C                 COMMUNICATIONS IN STATISTICS--SIMULATION AND
C                 COMPUTATION, VOL. 19, PP. 809-825
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE:  301-975-2855
C     ORIGINAL VERSION--MARCH     2008.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      INCLUDE 'DPCOP2.INC'
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      HAZ=0.0D0
      IF(X.LE.0.0D0)THEN
        WRITE(ICOUT,5)
    5   FORMAT('***** ERROR--THE FIRST ARGUMENT TO BFRHAZ IS ',
     1       'NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(ALPHA.LE.0.0D0)THEN
        WRITE(ICOUT,15)
   15   FORMAT('***** ERROR--THE SECOND ARGUMENT TO BFRHAZ IS ',
     1       'NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ALPHA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(BETA.LT.0.0D0)THEN
        WRITE(ICOUT,25)
   25   FORMAT('***** ERROR--THE THIRD ARGUMENT TO BFRHAZ IS ',
     1       'NEGATIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)BETA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(R.LE.0.0D0)THEN
        WRITE(ICOUT,35)
   35   FORMAT('***** ERROR--THE FOURTH ARGUMENT TO BFRHAZ IS ',
     1       'NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)R
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
C
C-----START POINT-----------------------------------------------------
C
      DTERM1=DLOG(2.0D0) + DLOG(ALPHA) + (2.0D0*R - 1.0D0)*DLOG(X)
      DTERM2=DLOG((BETA/X**2) + R)
      DTERM3=-(BETA/X**2) - ALPHA*X**(2.0D0*R)*EXP(-BETA/X**2)
      PDFLOG=DTERM1 + DTERM2 + DTERM3
C
      DTERM1=DEXP(-BETA/X**2)
      CDFLOG=-ALPHA*X**(2.0D0*R)*DTERM1
C
      HAZ=DEXP(PDFLOG - CDFLOG)
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE BFRLI1(Y,N,
     1                  ALPHA,BETA,R,
     1                  ALIK,AIC,AICC,BIC,
     1                  ISUBRO,IBUGA3,IERROR)
C
C     PURPOSE--THIS ROUTINE COMPUTES THE LIKELIHOOD FUNCTION FOR THE
C              BRITTLE FRACTURE DISTRIBUTION.  THIS IS FOR THE RAW DATA
C              CASE (I.E., NO GROUPING AND NO CENSORING).
C
C              IT IS ASSUMED THAT BASIC ERROR CHECKING HAS ALREADY BEEN
C              PERFORMED.
C
C     REFERENCES--BLACK, DURHAM, AND PADGETT (1990), "PARAMETER
C                 ESTIMATION FOR A NEW DISTRIBUTION FOR THE STRENGTH
C                 OF BRITTLE FIBERS: A SIMULATION STUDY",
C                 COMMUNICATIONS IN STATISTICS--SIMULATION AND
C                 COMPUTATION, VOL. 19, PP. 809-825
C     WRITTEN BY--ALAN HECKERT
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     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2010/8
C     ORIGINAL VERSION--AUGUST    2010.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 ISUBRO
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 IWRITE
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 ISTEPN
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DA
      DOUBLE PRECISION DB
      DOUBLE PRECISION DR
      DOUBLE PRECISION DN
      DOUBLE PRECISION DNP
      DOUBLE PRECISION DLIK
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DSUM2
      DOUBLE PRECISION DSUM3
      DOUBLE PRECISION DSUM4
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
C
C---------------------------------------------------------------------
C
      DIMENSION Y(*)
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='BFRL'
      ISUBN2='I1  '
C
      IERROR='NO'
C
      ALIK=-99.0
      AIC=-99.0
      AICC=-99.0
      BIC=-99.0
C
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'RLI1')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,51)
   51   FORMAT('**** AT THE BEGINNING OF BFRLI1--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,52)IBUGA3,ISUBRO,N,ALPHA,BETA,R
   52   FORMAT('IBUGA3,ISUBRO,N,ALPHA,BETA,R = ',2(A4,2X),I8,3G15.7)
        CALL DPWRST('XXX','WRIT')
        DO56I=1,MIN(N,100)
          WRITE(ICOUT,57)I,Y(I)
   57     FORMAT('I,Y(I) = ',I8,G15.7)
          CALL DPWRST('XXX','WRIT')
   56   CONTINUE
      ENDIF
C
C               ******************************************
C               **  STEP 1--                            **
C               **  COMPUTE LIKELIHOOD FUNCTION         **
C               ******************************************
C
      ISTEPN='1'
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'RLI1')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IERFLG=0
      IERROR='NO'
      IWRITE='OFF'
C
C     LOG-LIKELIHOOD FUNCTION IS:
C
C     N*LOG(2) + N*LOG(ALPHA) +
C     (2*R-1)*SUM[i=1 to N][LOG(X(i))] +
C     SUM[i=1 to N][LOG(R + B/X(i)**2)] -
C     BETA*SUM[i=1 to N][X(i)**-2] -
C     ALPHA*SUM[i=1 to N][X(i)**(2*R)*EXP(-BETA/X(i)**2)]
C
      DN=DBLE(N)
      DR=DBLE(R)
      DB=DBLE(BETA)
      DA=DBLE(ALPHA)
      DTERM1=DN*DLOG(2.0D0) + DN*DLOG(DA)
      DTERM2=2.D0*DR - 1.0D0
      DSUM1=0.0D0
      DSUM2=0.0D0
      DSUM3=0.0D0
      DSUM4=0.0D0
      DO1000I=1,N
        DX=DBLE(Y(I))
        DSUM1=DSUM1 + DLOG(DX)
        DSUM2=DSUM2 + DLOG(DR + (DB/DX**2))
        DSUM3=DSUM3 + 1.0D0/DX**2
        DSUM4=DSUM4 + DX**(2.0D0*DR)*DEXP(-DB/DX**2)
 1000 CONTINUE
C
      DLIK=DTERM1 + DTERM2*DSUM1 + DSUM2 - DB*DSUM3 - DA*DSUM4
      ALIK=REAL(DLIK)
      DNP=3.0D0
      AIC=REAL(-2.0D0*DLIK + 2.0D0*DNP)
      DTERM3=(2.0D0*DNP*(DNP+1.0D0))/(DN-DNP-1.0D0)
      AICC=REAL(-2.0D0*DLIK + 2.0D0*DNP + DTERM3)
      BIC=REAL(-2.0D0*DLIK + DNP*LOG(DN))
C
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'RLI1')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9011)
 9011   FORMAT('**** AT THE END OF BFRLI1--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9012)DSUM1,DSUM2,DSUM3,DSUM4
 9012   FORMAT('DSUM1,DSUM2,DSUM3,DSUM4 = ',4G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9013)DTERM1,DTERM2,DTERM3
 9013   FORMAT('DTERM1,DTERM2,DTERM3 = ',3G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9014)ALIK,AIC,AICC,BIC
 9014   FORMAT('ALIK,AIC,AICC,BIC = ',4G15.7)
        CALL DPWRST('XXX','WRIT')
      ENDIF
C
      RETURN
      END
      SUBROUTINE BFRPDF(X,ALPHA,BETA,R,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE BRITTLE FRACTURE DISTRIBUTION
C              WITH DOUBLE PRECISION SHAPE PARAMETERS ALPHA, BETA,
C              AND R.  THE BRITTLE FRACTURE DISTRIBUTION HAS
C              THE PROBABILITY DENSITY FUNCTION
C
C              f(X;ALPHA,BETA,R) = 2*ALPHA*X**(2*R-1)*
C                                  (BETA/X**2 + R)*
C                                  EXP[-(BETA/X**2)-ALPHA*X**(2*R)*
C                                  EXP(-BETA/X**2)]
C                                 X > 0; ALPHA, R > 0; BETA >= 0
C
C     INPUT  ARGUMENTS--X      = THE DOUBLE PRECISION VALUE
C                                AT WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C                     --ALPHA  = THE DOUBLE PRECISION VALUE
C                                OF THE FIRST SHAPE PARAMETER.
C                     --BETA   = THE DOUBLE PRECISION VALUE
C                                OF THE SECOND SHAPE PARAMETER.
C                     --R      = THE DOUBLE PRECISION VALUE
C                                OF THE THIRD 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 FOR THE BRITTLE FRACTURE
C             DISTRIBUTION WITH SHAPE PARAMETERS ALPHA, BETA AND R.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--ALPHA AND R SHOULD BE POSITIVE AND BETA SHOULD BE
C                   NON-NEGATIVE.
C                 --X SHOULD BE POSITIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--EXP.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN.
C     REFERENCES--BLACK, DURHAM, AND PADGETT (1990), "PARAMETER
C                 ESTIMATION FOR A NEW DISTRIBUTION FOR THE STRENGTH
C                 OF BRITTLE FIBERS: A SIMULATION STUDY",
C                 COMMUNICATIONS IN STATISTICS--SIMULATION AND
C                 COMPUTATION, VOL. 19, PP. 809-825
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE:  301-975-2855
C     ORIGINAL VERSION--MARCH     2008.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      INCLUDE 'DPCOP2.INC'
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      PDF=0.0D0
      IF(X.LE.0.0D0)THEN
        WRITE(ICOUT,5)
    5   FORMAT('***** ERROR--THE FIRST ARGUMENT TO BFRPDF IS ',
     1       'NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(ALPHA.LE.0.0D0)THEN
        WRITE(ICOUT,15)
   15   FORMAT('***** ERROR--THE SECOND ARGUMENT TO BFRPDF IS ',
     1       'NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ALPHA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(BETA.LT.0.0D0)THEN
        WRITE(ICOUT,25)
   25   FORMAT('***** ERROR--THE THIRD ARGUMENT TO BFRPDF IS ',
     1       'NEGATIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)BETA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(R.LE.0.0D0)THEN
        WRITE(ICOUT,35)
   35   FORMAT('***** ERROR--THE FOURTH ARGUMENT TO BFRPDF IS ',
     1       'NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)R
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
C
C-----START POINT-----------------------------------------------------
C
      DTERM1=DLOG(2.0D0) + DLOG(ALPHA) + (2.0D0*R - 1.0D0)*DLOG(X)
      DTERM2=DLOG((BETA/X**2) + R)
      DTERM3=-(BETA/X**2) - ALPHA*X**(2.0D0*R)*EXP(-BETA/X**2)
      PDF=DEXP(DTERM1 + DTERM2 + DTERM3)
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE BFRPPF(DP,DALPHA,DBETA,DR,DPPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE BRITTLE FRACTURE DISTRIBTION.
C              THE CUMULATIVE DISTRIBUTION FUNCTION IS:
C
C              F(X;ALPHA,BETA,R) = 1 - EXP(-ALPHA*X**2*EXP(-BETA/X**2))
C                                X > 0; ALPHA, R > 0; BETA >= 0
C
C              THE PERCENT POINT FUNCTION IS COMPUTED BY
C              NUMERICALLY INVERTING THE CDF FUNCTION.
C
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                     --DR     = THE THIRD SHAPE PARAMETER
C     OUTPUT ARGUMENTS--DPPF   = THE DOUBLE PRECISION PERCENT POINT
C                                FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION PERCENT POINT
C             FUNCTION VALUE PPF FOR THE BRITTLE FRACTURE DISTRIBUTION
C             WITH SHAPE PARAMETERS ALPHA, BETA, AND R.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--BFRCDF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
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     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2008/3
C     ORIGINAL VERSION--MARCH     2008.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
      DATA EPS /1.0D-9/
      DATA SIG /1.0D-8/
      DATA ZERO /0.D0/
      DATA MAXIT /1000/
CCCCC DATA EPS2 /1.0D-12/
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      DPPF=0.0D0
C
      IF(DP.LE.0.0D0 .OR. DP.GE.1.0D0)THEN
        WRITE(ICOUT,11)
   11   FORMAT('***** ERROR--THE FIRST ARGUMENT TO BFRPPF IS ',
     1         'OUTSIDE THE ALLOWABLE (0,1) INTERVAL')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)DP
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(DALPHA.LE.0.0D0)THEN
        WRITE(ICOUT,15)
   15   FORMAT('***** ERROR--THE SECOND ARGUMENT TO BFRPPF IS ',
     1       'NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)DALPHA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(DBETA.LT.0.0D0)THEN
        WRITE(ICOUT,25)
   25   FORMAT('***** ERROR--THE THIRD ARGUMENT TO BFRPPF IS ',
     1       'NEGATIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)BETA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(DR.LE.0.0D0)THEN
        WRITE(ICOUT,35)
   35   FORMAT('***** ERROR--THE FOURTH ARGUMENT TO BFRPPF IS ',
     1       'NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)DR
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
   46 FORMAT('****** THE VALUE OF THE ARGUMENT IS ',G15.7)
C
      XL = 0.0D0
      XR = 10.0D0
      ICOUNT=0
      MAXCNT=10000
      DINC=10.0D0
C
   91 CONTINUE
      IF(XL.LE.0.0D0)XL=0.0D0
      IF(XR.LE.0.0D0)XR=XL+DINC
      CALL BFRCDF(XL,DALPHA,DBETA,DR,CDFL)
      CALL BFRCDF(XR,DALPHA,DBETA,DR,CDFR)
      IF(CDFL.LT.DP .AND. CDFR.LT.DP)THEN
        XL=XR
        XR=XL+DINC
      ELSEIF(CDFL.GT.DP .AND. CDFR.GT.DP)THEN
        XL=XL-DINC
        IF(XL.LT.0.0D0)XL=0.0D0
      ELSE
        GOTO99
      ENDIF
      ICOUNT=ICOUNT+1
      IF(ICOUNT.GT.MAXCNT)THEN
        WRITE(ICOUT,96)
        CALL DPWRST('XXX','BUG ')
        PPF=0.0
        GOTO9000
      ENDIF
   96 FORMAT('***** ERROR--BFRPPF UNABLE TO FIND BRACKETING INTERVAL.')
      GOTO91
C
C
C  BISECTION METHOD
C
   99 CONTINUE
      IC = 0
      FXL=-DP
      FXR=1.0D0 - DP
C
  105 CONTINUE
      DX = (XL+XR)*0.5D0
      CALL BFRCDF(DX,DALPHA,DBETA,DR,DCDF)
      P1=DCDF
      DPPF=DX
      FCS = P1 - DP
      IF(FCS*FXL.GT.ZERO)GOTO110
      XR = DX
      FXR = FCS
      GOTO115
  110 CONTINUE
      XL = DX
      FXL = FCS
  115 CONTINUE
      XRML = XR - XL
      IF(XRML.LE.SIG .AND. ABS(FCS).LE.EPS)GOTO9000
      IC = IC + 1
      IF(IC.LE.MAXIT)GOTO105
      WRITE(ICOUT,130)
  130 FORMAT('***** ERROR--BFRPPF ROUTINE DID NOT CONVERGE.')
      CALL DPWRST('XXX','BUG ')
      GOTO9000
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE BFRRAN(N,ALPHA,BETA,R,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE BRITTLE FRACTURE DISTRIBUTION WITH SHAPE
C              PARAMETERS ALPHA, BETA, AND R.
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER RMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --ALPHA  = THE SINGLE PRECISION VALUE OF THE
C                                FIRST SHAPE PARAMETER.
C                     --A      = THE SINGLE PRECISION VALUE
C                                OF THE SECOND SHAPE PARAMETER.
C                     --R      = THE SINGLE PRECISION VALUE OF THE
C                                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
C             FROM THE BRITTLE FRACTURE DISTRIBUTION
C             WITH SHAPE PARAMETERS ALPHA, BETA, AND R.
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 R SHOULD BE POSITIVE, BETA SHOULD BE
C                   NON-NEGATIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN, BFRPPF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--BLACK, DURHAM, AND PADGETT (1990), "PARAMETER
C                 ESTIMATION FOR A NEW DISTRIBUTION FOR THE STRENGTH
C                 OF BRITTLE FIBERS: A SIMULATION STUDY",
C                 COMMUNICATIONS IN STATISTICS--SIMULATION AND
C                 COMPUTATION, VOL. 19, PP. 809-825
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     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION RMBER--2008.3
C     ORIGINAL VERSION--MARCH     2008.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
      DOUBLE PRECISION DTEMP
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)THEN
        WRITE(ICOUT, 5)
    5   FORMAT('***** ERROR--THE REQUESTED NUMBER OF BRITTLE ',
     1         'FRACTURE RANDOM NUMBERS IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(ALPHA.LE.0.0)THEN
        WRITE(ICOUT,15)
   15   FORMAT('***** ERROR--THE SECOND ARGUMENT TO BFRRAN IS ',
     1         'NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ALPHA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(BETA.LT.0.0)THEN
        WRITE(ICOUT,25)
   25   FORMAT('***** ERROR--THE THIRD ARGUMENT TO BFRRAN ',
     1         'IS NEGATIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)BETA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(R.LE.0.0)THEN
        WRITE(ICOUT,35)
   35   FORMAT('***** ERROR--THE FOURTH ARGUMENT TO BFRRAN IS ',
     1         'NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)R
        CALL DPWRST('XXX','BUG ')
      ENDIF
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8)
C
      CALL UNIRAN(N,ISEED,X)
C
      DO100I=1,N
        CALL BFRPPF(DBLE(X(I)),DBLE(ALPHA),DBLE(BETA),DBLE(R),DTEMP)
        X(I)=REAL(DTEMP)
  100 CONTINUE
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE BFWCDF(X,GAMMA,AL,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE BRITTLE FIBER WEIBULL
C              DISTRIBUTION WITH TAIL LENGTH PARAMETER GAMMA AND
C              GAUGE LENGTH PARAMETER L.
C
C              THE BRITTLE FIBER WEIBULL DISTRIBUTION USED HEREIN IS
C              DEFINED FOR ALL POSITIVE X AND HAS THE
C              CUMULATIVE DISTRIBUTION FUNCTION
C
C                 F(P;GAMMA,L,SCALE) = 1 - EXP[-L*(X/SCALE)**GAMMA]
C
C              THE SCALE PARAMETER IS SET TO 1 IN THIS ROUTINE.
C     INPUT  ARGUMENTS--X      = THE VALUE AT WHICH THE CUMULATIVE
C                                DISTRIBUTION FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE NON-NEGATIVE.
C                     --GAMMA  = THE SHAPE PARAMETER GAMMA.
C                     --AL     = THE GAUGE LENGTH PARAMETER L.
C     OUTPUT ARGUMENTS--CDF    = THE CUMULATIVE DISTRIBUTION FUNCTION
C                                VALUE.
C     OUTPUT--THE DOUBLE PRECISION CUMULATIVE DISTRIBUTION
C             FUNCTION VALUE CDF FOR THE BRITTLE FIBER WEIBULL
C             DISTRIBUTION WITH TAIL LENGTH PARAMETER GAMMA AND
C             GAUGE LENGTH PARAMETER L.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE NON-NEGATIVE.
C                 --GAMMA AND AL SHOULD BE POSITIVE.
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--STONER, EDIE, AND DURHAM (1994), "AN END-EFFECT MODEL
C                 FOR THE SINGLE-FILAMENT TENSILE TEST", JOURNAL OF
C                 OF MATERIALS SCIENCE, 29, PP. 6561-6574.
C               --NEWELL AND SAGENDORF (1999), "EXPERIMENTAL VERIFICATION
C                 OF THE END-EFFECT WEIBULL MODEL AS A PREDICTOR OF THE
C                 TENSILE STRENGTH OF KEVLAR-29 (POLY
C                 p-PHENYLENETEREPHTHALAMIDE) FIBRES AT DIFFERENCE GAUGE
C                 LENGTHS", HIGH PERFORMANCE POLYMERS, 11, PP. 297-305.
C     WRITTEN BY--ALAN HECKERT
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     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2010.8
C     ORIGINAL VERSION--AUGUST    2010.
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION X
      DOUBLE PRECISION AL
      DOUBLE PRECISION GAMMA
      DOUBLE PRECISION CDF
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      CDF=0.0D0
      IF(GAMMA.LE.0.0D0)THEN
        WRITE(ICOUT,15)
   15   FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO BFWCDF IS ',
     1         'NON-POSITIVE')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)GAMMA
   46   FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(AL.LE.0.0D0)THEN
        WRITE(ICOUT,25)
   25   FORMAT('***** ERROR--THE THIRD INPUT ARGUMENT TO BFWCDF IS ',
     1         'NON-POSITIVE')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)AL
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
      IF(X.GT.0.0D0)THEN
        CDF=1.0D0 - DEXP(-AL*(X**GAMMA))
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE BFWCD2(X,NX,LI,PI,NI,GAMMA,ALOC,SCALE,
     1                  CDF,
     1                  ISUBRO,IBUGA2,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE BRITTLE FIBER WEIBULL
C              DISTRIBUTION WITH TAIL LENGTH PARAMETER = GAMMA AND
C              GAUGE LENGTH PARAMETER L.
C
C              THE BRITTLE FIBER WEIBULL DISTRIBUTION USED HEREIN IS
C              HAS THE CUMULATIVE DISTRIBUTION FUNCTION
C
C              F(P;GAMMA,L,SCALE) = 1 - EXP[-L*(X/SCALE)**GAMMA]
C
C              THE BFWCDF ROUTINE COMPUTES THIS FUNCTION FOR A SINGLE
C              VALUE OF L.  THIS ROUTINE COMPUTES THIS FUNCTION FOR
C              MULTIPLE VALUES OF L.  IT DOES THIS USING A MIXTURE
C              APPROACH.  THAT IS
C
C              F(X;GAMMA,L,LOC,SCALE) = SUM[i=1 to NI]
C                  [p(i)*BFWCDF(X;GAMMA,L(i),LOC,SCALE)]
C
C              WHERE NI IS THE NUMBER OF DISTINCT VALUES FOR L.
C
C              THIS ROUTINE ASSUMES THAT THE LOCATION/SCALE/SHAPE
C              PARAMETERS ARE FIXED (I.E., ONLY L VARIES).
C
C              CURRENTLY, WE RESTRICT L TO A MAXIMUM OF 10 DISTINCT
C              LEVELS.
C
C     INPUT  ARGUMENTS--X      = A VARIABLE CONTAINING THE VALUES AT WHICH
C                                THE CUMULATIVE DISTRIBUTION FUNCTION IS
C                                TO BE EVALUATED.
C                     --NX     = A PARAMETER THAT SPECIFIES THE NUMBER
C                                OF VALUES FOR X.
C                     --LI     = A VARIABLE CONTAINING THE GAUGE LENGTH
C                                PARAMETER L.
C                     --PI     = A VARIABLE CONTAINING THE "MIXING"
C                                PROPORTIONS FOR LI.
C                     --NI     = A PARAMETER THAT SPECIFIES THE NUMBER
C                                OF VALUES FOR LI AND PI.
C                     --GAMMA  = THE SHAPE PARAMETER GAMMA.
C                     --ALOC   = THE LOCATION PARAMETER.
C                     --SCALE  = THE SCALE PARAMETER.
C     OUTPUT ARGUMENTS--CDF    = A VARIABLE CONTAINING THE CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUES.
C     OUTPUT--THE DOUBLE PRECISION CUMULATIVE DISTRIBUTION FUNCTION
C             VALUES.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     OTHER DATAPAC   SUBROUTINES NEEDED--BFWCDF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--STONER, EDIE, AND DURHAM (1994), "AN END-EFFECT MODEL
C                 FOR THE SINGLE-FILAMENT TENSILE TEST", JOURNAL OF
C                 OF MATERIALS SCIENCE, 29, PP. 6561-6574.
C               --NEWELL AND SAGENDORF (1999), "EXPERIMENTAL VERIFICATION
C                 OF THE END-EFFECT WEIBULL MODEL AS A PREDICTOR OF THE
C                 TENSILE STRENGTH OF KEVLAR-29 (POLY
C                 p-PHENYLENETEREPHTHALAMIDE) FIBRES AT DIFFERENCE GAUGE
C                 LENGTHS", HIGH PERFORMANCE POLYMERS, 11, PP. 297-305.
C     WRITTEN BY--ALAN HECKERT
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     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2010.8
C     ORIGINAL VERSION--OCTOBER   2010.
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION X(*)
      DOUBLE PRECISION LI(*)
      DOUBLE PRECISION PI(*)
      DOUBLE PRECISION CDF(*)
      DOUBLE PRECISION GAMMA
      DOUBLE PRECISION ALOC
      DOUBLE PRECISION SCALE
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
C
      CHARACTER*4 ISUBRO
      CHARACTER*4 IBUGA2
      CHARACTER*4 IERROR
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'WCD2')THEN
        WRITE(ICOUT,31)IBUGA2,ISUBRO
   31   FORMAT('AT THE BEGINNING OF BFWCD2')
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      IF(NX.LT.1)THEN
        WRITE(ICOUT,1)
    1   FORMAT('***** ERROR IN BRITTLE FIBER WEIBULL CDF--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,3)
    3   FORMAT('      THE NUMBER OF REQUESTED CDF VALUES IS ',
     1         'NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,5)NX
    5   FORMAT('      THE NUMBER OF REQUESTED CDF VALUES  = ',I8)
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        GOTO9000
      ELSEIF(NI.LT.1)THEN
        WRITE(ICOUT,1)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,13)
   13   FORMAT('      THE NUMBER OF DISTINCT GAUGE LENGTH (L) VALUES ',
     1         'IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,15)NI
   15   FORMAT('      THE NUMBER OF REQUESTED L VALUES  = ',I8)
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        GOTO9000
      ELSEIF(NI.GT.10)THEN
        WRITE(ICOUT,1)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,18)
   18   FORMAT('      THE NUMBER OF DISTINCT GAUGE LENGTH (L) VALUES ',
     1         'IS GREATER THAN 10.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,15)NI
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        GOTO9000
      ELSEIF(GAMMA.LE.0.0D0)THEN
        WRITE(ICOUT,1)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,23)
   23   FORMAT('      THE VALUE OF THE SHAPE PARAMETER (GAMMA) ',
     1         'IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,25)GAMMA
   25   FORMAT('      THE VALUE OF GAMMA  = ',G15.7)
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        GOTO9000
      ELSEIF(SCALE.LE.0.0D0)THEN
        WRITE(ICOUT,1)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,33)
   33   FORMAT('      THE VALUE OF THE SCALE PARAMETER IS ',
     1         'NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,35)SCALE
   35   FORMAT('      THE VALUE OF THE SCALE PARAMETER  = ',G15.7)
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        GOTO9000
      ENDIF
C
      DSUM1=0.0D0
      DO50I=1,NI
        IF(LI(I).LE.0.0D0)THEN
          WRITE(ICOUT,1)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,52)I
   52     FORMAT('      FOR ROW ',I8,' THE VALUE OF THE GAUGE LENGTH ',
     1           'ARGUMENT (L) IS NON-POSITIVE.')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,54)LI(I)
   54     FORMAT('      THE VALUE OF L(I)  = ',G15.7)
          CALL DPWRST('XXX','BUG ')
          GOTO9000
          IERROR='YES'
        ELSEIF(PI(I).LE.0.0D0 .OR. PI(I).GT.1.0D0)THEN
          WRITE(ICOUT,1)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,57)I
   57     FORMAT('      FOR ROW ',I8,' THE VALUE OF THE MIXING ',
     1           'ARGUMENT (P)')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,58)
   58     FORMAT('      OUTSIDE THE (0,1) INTERVAL).')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,59)PI(I)
   59     FORMAT('      THE VALUE OF P(I)  = ',G15.7)
          CALL DPWRST('XXX','BUG ')
          GOTO9000
          IERROR='YES'
        ENDIF
        DSUM1=DSUM1 + PI(I)
   50 CONTINUE
C
C     CHECK THAT MIXING PROPORTIONS SUM TO 1
C
      IF(ABS(DSUM1 - 1.0D0).GT.0.000001D0)THEN
        WRITE(ICOUT,1)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,63)
   63   FORMAT('      THE MIXING PROPORTIONS DO NOT SUM TO ONE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,65)REAL(DSUM1)
   65   FORMAT('      THE SUM OF THE MIXING PROPORTIONS  = ',G15.7)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
C     NOW COMPUTE THE CDF BY SUMMING OVER THE L(I) CASES
C
      DO100I=1,NX
        DSUM1=0.0D0
        DO200J=1,NI
          DTERM1=(X(I)-ALOC)/SCALE
          CALL BFWCDF(DTERM1,GAMMA,LI(J),DTERM2)
          DSUM1=DSUM1 + PI(J)*DTERM2
  200   CONTINUE
        CDF(I)=DSUM1
  100 CONTINUE
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE BFWFUN (N, X, FVEC, IFLAG, XDATA, NOBS)
C
C     PURPOSE--THIS ROUTINE COMPUTES THE FUNCTIONS FOR THE
C              BRITTLE FIBER WEIBULL MAXIMUM LIKELIHOOD
C              EQUATIONS.
C
C              SIGMA - (SUM[i=1 to N][L(i)*X(i)**G]/N)**(1/G)
C
C              N/G - N*LOG(SIGMA) + SUM[i=1 to n][LOG(X(i))] -
C                    SUM[i=1 to n][L(i)*(X(i)/G)**G*LOG(X(i)/G]
C
C              WITH G AND SIGMA DENOTING THE SHAPE PARAMETER GAMMA AND
C              SCALE PARAMETER SIGMA, RESPECTIVELY.
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
C              THE L(i) ARE THE GAUGE LENGTHS.  THESE CAN EITHER
C              BE CONSTANT (I.E., WE ARE FITTING A SINGLE LEVEL OF
C              L) OR VARIABLE.  THE L VALUES ARE STORED IN THE UPPER
C              HALF OF THE DATA ARRAY.
C
C     EXAMPLE--BRITTLE FIBER WEIBULL MAXIMUM LIKELIHOOD Y L
C     REFERENCES--STONER, EDIE, AND DURHAM (1994), "AN END-EFFECT MODEL
C                 FOR THE SINGLE-FILAMENT TENSILE TEST", JOURNAL OF
C                 OF MATERIALS SCIENCE, 29, PP. 6561-6574.
C               --NEWELL AND SAGENDORF (1999), "EXPERIMENTAL VERIFICATION
C                 OF THE END-EFFECT WEIBULL MODEL AS A PREDICTOR OF THE
C                 TENSILE STRENGTH OF KEVLAR-29 (POLY
C                 p-PHENYLENETEREPHTHALAMIDE) FIBRES AT DIFFERENCE GAUGE
C                 LENGTHS", HIGH PERFORMANCE POLYMERS, 11, PP. 297-305.
C     WRITTEN BY--ALAN HECKERT
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBUG, MD 20899-8980
C                 PHONE--301-975-2899
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2010/11
C     ORIGINAL VERSION--NOVEMBER  2010.
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION X(*)
      DOUBLE PRECISION FVEC(*)
      REAL XDATA(*)
C
      DOUBLE PRECISION DN
      DOUBLE PRECISION DX
      DOUBLE PRECISION DG
      DOUBLE PRECISION DS
      DOUBLE PRECISION DL
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DSUM2
      DOUBLE PRECISION DSUM3
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C  COMPUTE SOME SUMS
C
      N=2
      IFLAG=0
C
      DG=X(1)
      DS=X(2)
      DN=DBLE(NOBS)
C
      DTERM1=(DN/DG) - DN*DLOG(DS)
      DSUM1=0.0D0
      DSUM2=0.0D0
      DSUM3=0.0D0
C
      DO200I=1,NOBS
        DX=DBLE(XDATA(I))
        DL=DBLE(XDATA(NOBS+I))
        DTERM2=DLOG(DX)
        DTERM3=DX/DS
        DSUM1=DSUM1+DLOG(DX)
        DSUM2=DSUM2 + DL*(DTERM3**DG)*DLOG(DTERM3)
        DSUM3=DSUM3 + DL*(DX**DG)
  200 CONTINUE
C
      FVEC(1)=DTERM1 + DSUM1 - DSUM2
      FVEC(2)=(DSUM3/DS**DG) - DN
C
      RETURN
      END
      SUBROUTINE BFWLI1(Y,XL,N,ICASPL,MINMAX,ALOC,SCALE,SHAPE,
     1                  ALIK,AIC,AICC,BIC,
     1                  ISUBRO,IBUGA3,IERROR)
C
C     PURPOSE--THIS ROUTINE COMPUTES THE LIKELIHOOD FUNCTION FOR
C              THE 3-PARAMETER BRITTLE FIBER WEIBULL DISTRIBUTION.
C              THIS IS FOR THE RAW DATA CASE (I.E., NO GROUPING AND
C              NO CENSORING).
C
C              IT IS ASSUMED THAT BASIC ERROR CHECKING HAS ALREADY BEEN
C              PERFORMED.
C
C              THE BRITTLE FIBER DISTRIBUTION IS A RE-PARAMETERIZED
C              VERSION OF THE WEIBULL DISTRIBUTION.  IT INCLUDES A
C              GAUGE LENGTH PARAMETER (ASSUMED KNOWN).
C
C     REFERENCES--STONER, EDIE, AND DURHAM (1994), "AN END-EFFECT MODEL
C                 FOR THE SINGLE-FILAMENT TENSILE TEST", JOURNAL OF
C                 OF MATERIALS SCIENCE, 29, PP. 6561-6574.
C               --NEWELL AND SAGENDORF (1999), "EXPERIMENTAL VERIFICATION
C                 OF THE END-EFFECT WEIBULL MODEL AS A PREDICTOR OF THE
C                 TENSILE STRENGTH OF KEVLAR-29 (POLY
C                 p-PHENYLENETEREPHTHALAMIDE) FIBRES AT DIFFERENCE GAUGE
C                 LENGTHS", HIGH PERFORMANCE POLYMERS, 11, PP. 297-305.
C              --KARL BURY, "STATISTICAL DISTRIBUTIONS IN ENGINEERING",
C                CAMBRIDGE UNIVERSITY PRESS, 1999, CHAPTER 17.
C     WRITTEN BY--ALAN HECKERT
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     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2010/9
C     ORIGINAL VERSION--SEPTEMBER 2010.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 ICASPL
      CHARACTER*4 ISUBRO
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 IWRITE
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 ISTEPN
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DL
      DOUBLE PRECISION DS
      DOUBLE PRECISION DU
      DOUBLE PRECISION DG
      DOUBLE PRECISION DN
      DOUBLE PRECISION DNP
      DOUBLE PRECISION DLIK
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DSUM2
      DOUBLE PRECISION DSUM3
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM3
C
C---------------------------------------------------------------------
C
      DIMENSION Y(*)
      DIMENSION XL(*)
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='BFWL'
      ISUBN2='I1  '
      IERROR='NO'
C
      ALIK=-99.0
      AIC=-99.0
      AICC=-99.0
      BIC=-99.0
C
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'WLI1')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,51)
   51   FORMAT('**** AT THE BEGINNING OF BFWLI1--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,52)IBUGA3,ISUBRO,MINMAX
   52   FORMAT('IBUGA3,ISUBRO,MINMAX = ',2(A4,2X),I8)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,55)N,ALOC,SCALE
   55   FORMAT('N,ALOC,SCALE = ',I8,2G15.7)
        CALL DPWRST('XXX','WRIT')
        DO56I=1,MIN(N,100)
          WRITE(ICOUT,57)I,Y(I),XL(I)
   57     FORMAT('I,Y(I),XL(I) = ',I8,2G15.7)
          CALL DPWRST('XXX','WRIT')
   56   CONTINUE
      ENDIF
C
C               ******************************************
C               **  STEP 1--                            **
C               **  COMPUTE LIKELIHOOD FUNCTION         **
C               ******************************************
C
      ISTEPN='1'
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'WLI1')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IERFLG=0
      IERROR='NO'
      IWRITE='OFF'
      IF(ICASPL.EQ.'BFWE')ALOC=0.0
C
C     LOG-LIKELIHOOD FUNCTION IS:
C
C     SUM[i=1 to n][LOG(L(i)] +
C     N*(LOG(SHAPE) - SHAPE*LOG(SCALE)) +
C     (SHAPE-1)*SUM[i=1 to n][LOG(X(i) - LOC] -
C     SUM[i=1 to n][-L(i)*((X(i) - LOC)/SCALE)**SHAPE]
C
C     L IS THE GAUGE LENGTH PARAMETER.  THE "XL" ARRAY ALLOWS
C     DIFFERENT VALUES OF L
C
      DN=DBLE(N)
      DS=DBLE(SCALE)
      DU=DBLE(ALOC)
      DG=DBLE(SHAPE)
      DTERM1=DN*(DLOG(DG) - DG*DLOG(DS))
      DSUM1=0.0D0
      DSUM2=0.0D0
      DSUM3=0.0D0
      DO1000I=1,N
        DX=DBLE(Y(I))
        DL=DBLE(XL(I))
        DSUM1=DSUM1 + DLOG(DX - DU)
        DSUM2=DSUM2 + DL*((DX-DU)/DS)**DG
        DSUM3=DSUM3 + DLOG(DL)
 1000 CONTINUE
C
      DLIK=DTERM1 + (DG-1.0D0)*DSUM1 - DSUM2
      ALIK=REAL(DLIK)
      DNP=2.0D0
      IF(ICASPL.EQ.'3BFW')DNP=3.0
      AIC=REAL(-2.0D0*DLIK + 2.0D0*DNP)
      DTERM3=(2.0D0*DNP*(DNP+1.0D0))/(DN-DNP-1.0D0)
      AICC=REAL(-2.0D0*DLIK + 2.0D0*DNP + DTERM3)
      BIC=REAL(-2.0D0*DLIK + DNP*LOG(DN))
C
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'WLI1')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9011)
 9011   FORMAT('**** AT THE END OF BFWLI1--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9013)DSUM1,DSUM2,DTERM1,DTERM3
 9013   FORMAT('DSUM1,DSUM2,DTERM1,DTERM3 = ',3G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9014)ALIK,AIC,AICC,BIC
 9014   FORMAT('ALIK,AIC,AICC,BIC = ',4G15.7)
        CALL DPWRST('XXX','WRIT')
      ENDIF
C
      RETURN
      END
      SUBROUTINE BFWML1(Y,AL,N,MAXNXT,
     1                  TEMP1,TEMP2,DTEMP1,
     1                  XMEAN,XSD,XVAR,XMIN,XMAX,
     1                  SCALSV,SHAPSV,SCALML,SHAPML,
     1                  ISUBRO,IBUGA3,IERROR)
C
C     PURPOSE--THIS ROUTINE COMPUTES THE MAXIMUM LIKELIHOOD ESTIMATES
C              FOR THE 2-PARAMETER BRITTLE FIBER WEIBULL DISTRIBUTION FOR
C              THE RAW DATA CASE (I.E., NO CENSORING AND NO GROUPING).
C              THIS ROUTINE CURRENTLY RETURNS ONLY THE POINT ESTIMATES.
C
C              IT IS ASSUMED THAT BASIC ERROR CHECKING HAS ALREADY BEEN
C              PERFORMED.
C
C              PUT THIS IN A SEPARATE ROUTINE AS IT MAY BE CALLED
C              FROM MULTIPLE PLACES (DPMBFW WILL GENERATE THE OUTPUT
C              FOR THE BRITTLE FIBER WEIBULL MLE COMMAND).
C
C              THE MLE ESTIMATES ARE THE SOLUTION TO THE FOLLOWING
C              TWO SIMULTANEOUS NON-LINEAR EQUATIONS:
C
C              SIGMA - (SUM[i=1 to N][L(i)*X(i)**G]/N)**(1/G)
C
C              N/G - N*LOG(SIGMA) + SUM[i=1 to n][LOG(X(i))] -
C                    SUM[i=1 to n][L(i)*(X(i)/G)**G*LOG(X(i)/G]
C
C              WITH G AND SIGMA DENOTING THE SHAPE PARAMETER GAMMA AND
C              SCALE PARAMETER SIGMA, RESPECTIVELY.
C
C              THE L(i) ARE THE GAUGE LENGTHS.  THESE CAN EITHER
C              BE CONSTANT (I.E., WE ARE FITTING A SINGLE LEVEL OF
C              L) OR VARIABLE.  THE L VALUES ARE STORED IN THE UPPER
C              HALF OF THE DATA ARRAY.
C
C     REFERENCES--STONER, EDIE, AND DURHAM (1994), "AN END-EFFECT MODEL
C                 FOR THE SINGLE-FILAMENT TENSILE TEST", JOURNAL OF
C                 OF MATERIALS SCIENCE, 29, PP. 6561-6574.
C               --NEWELL AND SAGENDORF (1999), "EXPERIMENTAL VERIFICATION
C                 OF THE END-EFFECT WEIBULL MODEL AS A PREDICTOR OF THE
C                 TENSILE STRENGTH OF KEVLAR-29 (POLY
C                 p-PHENYLENETEREPHTHALAMIDE) FIBRES AT DIFFERENCE GAUGE
C                 LENGTHS", HIGH PERFORMANCE POLYMERS, 11, PP. 297-305.
C     WRITTEN BY--ALAN HECKERT
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     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2010/11
C     ORIGINAL VERSION--NOVEMBER  2010.
C     UPDATED         --JUNE      2011. MODIFIED ALGORITHM FOR
C                                       DETERMINING STARTING VALUES
C     UPDATED         --MAY       2012. MODIFIED ALGORITHM FOR
C                                       DETERMINING STARTING VALUES
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DIMENSION Y(*)
      DIMENSION AL(*)
      DIMENSION TEMP1(*)
      DIMENSION TEMP2(*)
      DOUBLE PRECISION DTEMP1(*)
C
      DOUBLE PRECISION TOL
      DOUBLE PRECISION XPAR(2)
      DOUBLE PRECISION FVEC(2)
C
      EXTERNAL BFWFUN
C
      CHARACTER*4 ISUBRO
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*40 IDIST
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 ISTEPN
      CHARACTER*4 IWEIBC
      CHARACTER*4 IWEIFL
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='BFWM'
      ISUBN2='L1  '
      IERROR='NO'
C
      DO11I=1,MAXNXT
        TEMP1(I)=0.0
        TEMP2(I)=0.0
   11 CONTINUE
C
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'WML1')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,51)
   51   FORMAT('**** AT THE BEGINNING OF BFWML1--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,52)IBUGA3,ISUBRO,IERROR,N
   52   FORMAT('IBUGA3,ISUBRO,IERROR,N = ',3(A4,2X),I8)
        CALL DPWRST('XXX','WRIT')
        DO56I=1,MIN(N,100)
          WRITE(ICOUT,57)I,Y(I),AL(I)
   57     FORMAT('I,Y(I),AL(I) = ',I8,2G15.7)
          CALL DPWRST('XXX','WRIT')
   56   CONTINUE
      ENDIF
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      ISTEPN='1'
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'WML1')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
C               *****************************************************
C               **  STEP 2--                                       **
C               **  CARRY OUT CALCULATIONS                         **
C               **  FOR BRITTLE FIBER WEIBULL MLE ESTIMATE         **
C               *****************************************************
C
      ISTEPN='2'
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'WML1')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IDIST='2-PARAMETER BRITTLE FIBER WEIBULL'
C
      IFLAG=2
      CALL SUMRAW(Y,N,IDIST,IFLAG,
     1            XMEAN,XVAR,XSD,XMIN,XMAX,
     1            ISUBRO,IBUGA3,IERROR)
C
      SHAPML=CPUMIN
      SCALML=CPUMIN
C
      IF(SHAPSV.GT.0.0 .AND. SCALSV.GT.0.0)THEN
        XPAR(1)=DBLE(SHAPSV)
        XPAR(2)=DBLE(SCALSV)
      ELSE
C
C       IF NO STARTING VALUES SPECIFIED, COMPUTE STARTING
C       VALUES BASED ON STANDARD 2-PARAMETER WEIBULL.
C
C       THIS IS NOT REALLY SATISFACTORY AS THE "L" PARAMETER
C       MAY DISTORT THE SCALE PARAMETER.
C
C       2011/6: MODIFY ALGORITHM FOR STARTING VALUES.  USE
C
C               1) ESTIMATE SHAPE BASED ON THE STANDARD WEIBULL
C                  SINCE THE SHAPE PARAMETER FOR STANDARD WEIBULL
C                  AND BRITTLE FIBER WEIBULL SHOULD BASICALLY BE
C                  EQUIVALENT.
C
C               2) BASED ON THIS ESTIMATE OF GAMMA, GENERATE
C                  A PROBABILITY PLOT AND USE THE ESTIMATE OF
C                  SCALE (PPA1) FROM THIS.
C
C                  NOTE: 2012/5 - JUST USE THE EQUATION
C
C                        SIGMA = (SUM[i=1 to N][L(i)*X(i)**G]/N)**(1/G)
C
        IWEIBC='OFF'
        IWEIFL='WEIB'
        MINMAX=1
        CALL WEIML1(Y,N,IWEIBC,IWEIFL,MINMAX,
     1              TEMP1,DTEMP1,
     1              XMEAN,XSD,XVAR,XMIN,XMAX,
     1              ZMEAN,ZSD,
     1              SCALML,SCALSE,GHAT,SHAPSE,
     1              SHAPBC,SHABSE,COVSE,COVBSE,
     1              ISUBRO,IBUGA3,IERROR)
C
CCCCC   IWRITE='OFF'
CCCCC   AN=REAL(N)
CCCCC   CALL MEAN(AL,N,IWRITE,ALMEAN,IBUGA3,IERROR)
C
CCCCC   CALL SORT(Y,N,Y)
CCCCC   CALL UNIMED(N,TEMP1)
CCCCC   DO120I=1,N
CCCCC     CALL BFWPPF(DBLE(TEMP1(I)),DBLE(GHAT),DBLE(ALMEAN),DWOUT)
CCCCC     TEMP1(I)=REAL(DWOUT)
CC120   CONTINUE
CCCCC   CALL LINFIT(Y,TEMP1,N,
CCCCC1              PPA0,PPA1,XRESSD,XRESDF,PPCC,SDPPA0,SDPPA,CCALBE,
CCCCC1              ISUBRO,IBUGA3,IERROR)
C
        DSUM1=0.0D0
        DO120I=1,N
          DSUM1=DSUM1 + DBLE(AL(I))*DBLE(Y(I))**DBLE(GHAT)
  120   CONTINUE
        DSCALE=(DSUM1/DBLE(N))**(1.0D0/DBLE(GHAT))
C
        XPAR(1)=DBLE(GHAT)
CCCCC   XPAR(2)=DBLE(PPA1)
        XPAR(2)=DSCALE
      ENDIF
C
      DO1010I=1,N
        IINDX=I+N
        IF(IINDX.GT.MAXNXT)THEN
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,1111)
 1111     FORMAT('**** ERROR IN 2-PARAMETER BRITTLE FIBER WEIBULL ',
     1           'MAXIMUM LIKELIHOOD')
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,1113)MAXNXT/2
 1113     FORMAT('     MAXIMUM NUMBER OF ROWS (',I8,') EXCEEDED.')
          CALL DPWRST('XXX','WRIT')
          SHAPML=CPUMIN
          SCALML=CPUMIN
          IERROR='YES'
          GOTO9000
        ENDIF
        Y(I+N)=AL(I)
 1010 CONTINUE
C
      IOPT=2
      TOL=1.0D-6
      NVAR=2
      NPRINT=-1
      INFO=0
      LWA=MAXNXT
      CALL DNSQE(BFWFUN,JAC,IOPT,NVAR,XPAR,FVEC,TOL,NPRINT,INFO,
     1           DTEMP1,MAXNXT,Y,N)
C
      SHAPML=REAL(XPAR(1))
      SCALML=REAL(XPAR(2))
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'WML1')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9011)
 9011   FORMAT('**** AT THE END OF BFWML1--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9013)N,XMEAN,XSD,XMIN,XMAX
 9013   FORMAT('N,XMEAN,XSD,XMIN,XMAX = ',I8,4G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9017)SHAPSV,SCALSV,SHAPML,SCALML
 9017   FORMAT('SHAPSV,SCALSV,SHAPML,SCALML =  ',4G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9019)XPAR(1),XPAR(2),INFO
 9019   FORMAT('XPAR(1),XPAR(2),INFO =  ',2G15.7,I8)
        CALL DPWRST('XXX','WRIT')
      ENDIF
C
      RETURN
      END
      SUBROUTINE BFWPDF(X,GAMMA,AL,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE BRITTLE FIBER WEIBULL
C              DISTRIBUTION WITH TAIL LENGTH PARAMETER = GAMMA AND
C              GAUGE LENGTH PARAMETER L.
C
C              THE BRITTLE FIBER WEIBULL DISTRIBUTION USED HEREIN IS
C              DEFINED FOR ALL POSITIVE X AND HAS THE
C              PROBABILITY DENSITY FUNCTION
C
C              f(X;GAMMA,L,SCALE) = L*GAMMA*(X**(GAMMA-1))*
C                                   EXP(-L*((X/SCALE)**GAMMA))/
C                                   (SCALE**GAMMA)
C
C              THE S PARAMETER IS THE SCALE PARAMETER AND IS SET TO
C              1 FOR THIS SUBROUTINE.
C     INPUT  ARGUMENTS--X      = THE VALUE AT WHICH THE
C                                PROBABILITY DENSITY FUNCTION IS TO
C                                BE EVALUATED.  X SHOULD BE NON-NEGATIVE.
C                     --GAMMA  = THE SHAPE PARAMETER GAMMA.
C                     --AL     = THE GAUGE LENGTH PARAMETER L.
C     OUTPUT ARGUMENTS--PDF    = THE PROBABILITY DENSITY FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION PROBABILITY DENSITY FUNCTION VALUE
C             PDF FOR THE BRITTLE FIBER WEIBULL DISTRIBUTION WITH
C             TAIL LENGTH PARAMETER = GAMMA AND GAUGE LENGTH PARAMETER L.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE NON-NEGATIVE.
C                 --GAMMA AND AL SHOULD BE POSITIVE.
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--STONER, EDIE, AND DURHAM (1994), "AN END-EFFECT MODEL
C                 FOR THE SINGLE-FILAMENT TENSILE TEST", JOURNAL OF
C                 OF MATERIALS SCIENCE, 29, PP. 6561-6574.
C               --NEWELL AND SAGENDORF (1999), "EXPERIMENTAL VERIFICATION
C                 OF THE END-EFFECT WEIBULL MODEL AS A PREDICTOR OF THE
C                 TENSILE STRENGTH OF KEVLAR-29 (POLY
C                 p-PHENYLENETEREPHTHALAMIDE) FIBRES AT DIFFERENCE GAUGE
C                 LENGTHS", HIGH PERFORMANCE POLYMERS, 11, PP. 297-305.
C     WRITTEN BY--ALAN HECKERT
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     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2010.8
C     ORIGINAL VERSION--AUGUST    2010.
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION X
      DOUBLE PRECISION AL
      DOUBLE PRECISION GAMMA
      DOUBLE PRECISION PDF
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      PDF=0.0D0
      IF(X.LT.0.0D0)THEN
        WRITE(ICOUT,5)
    5   FORMAT('***** ERROR--THE FIRST ARGUMENT TO BFWPDF IS ',
     1         'NEGATIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)GAMMA
   46   FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(X.EQ.0.0D0)THEN
        IF(GAMMA.EQ.1.0D0)THEN
          PDF=1.0D0
          GOTO9000
        ELSEIF(GAMMA.GT.1.0D0)THEN
          PDF=0.0D0
          GOTO9000
        ELSE
          WRITE(ICOUT,7)
    7     FORMAT('***** ERROR--THE FIRST ARGUMENT TO BFWPDF IS ',
     1           'ZERO.')
          CALL DPWRST('XXX','BUG ')
          GOTO9000
        ENDIF
      ELSEIF(GAMMA.LE.0.0D0)THEN
        WRITE(ICOUT,15)
   15   FORMAT('***** ERROR--THE SECOND ARGUMENT TO BFWPDF IS ',
     1         'NON-POSITIVE')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)GAMMA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(AL.LE.0.0D0)THEN
        WRITE(ICOUT,25)
   25   FORMAT('***** ERROR--THE THIRD ARGUMENT TO BFWPDF IS ',
     1         'NON-POSITIVE')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)AL
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
      DTERM1=AL*GAMMA*(X**(GAMMA-1.0))
      DTERM2=DEXP(-AL*(X**GAMMA))
      PDF=DTERM1*DTERM2
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE BFWPD2(X,NX,LI,PI,NI,GAMMA,ALOC,SCALE,
     1                  PDF,
     1                  ISUBRO,IBUGA2,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE BRITTLE FIBER WEIBULL
C              DISTRIBUTION WITH TAIL LENGTH PARAMETER = GAMMA AND
C              GAUGE LENGTH PARAMETER L.
C
C              THE BRITTLE FIBER WEIBULL DISTRIBUTION USED HEREIN IS
C              HAS THE PROBABILITY DENSITY FUNCTION
C
C              f(X;GAMMA,L,SCALE) = L*GAMMA*(X**(GAMMA-1))*
C                                   EXP(-L*((X/SCALE)**GAMMA))/
C                                   (SCALE**GAMMA)
C
C              THE BFWPDF ROUTINE COMPUTES THIS FUNCTION FOR A SINGLE
C              VALUE OF L.  THIS ROUTINE COMPUTES THIS FUNCTION FOR
C              MULTIPLE VALUES OF L.  IT DOES THIS USING A MIXTURE
C              APPROACH.  THAT IS
C
C              f(X;GAMMA,L,LOC,SCALE) = SUM[i=1 to NI]
C                  [p(i)*BFWPDF(X;GAMMA,L(i),LOC,SCALE)]
C
C              WHERE NI IS THE NUMBER OF DISTINCT VALUES FOR L.
C
C              THIS ROUTINE ASSUMES THAT THE LOCATION/SCALE/SHAPE
C              PARAMETERS ARE FIXED (I.E., ONLY L VARIES).
C
C              CURRENTLY, WE RESTRICT L TO A MAXIMUM OF 10 DISTINCT
C              LEVELS.
C
C     INPUT  ARGUMENTS--X      = A VARIABLE CONTAINING THE VALUES AT WHICH
C                                THE PROBABILITY DENSITY FUNCTION IS TO
C                                BE EVALUATED.
C                     --NX     = A PARAMETER THAT SPECIFIES THE NUMBER
C                                OF VALUES FOR X.
C                     --LI     = A VARIABLE CONTAINING THE GAUGE LENGTH
C                                PARAMETER L.
C                     --PI     = A VARIABLE CONTAINING THE "MIXING"
C                                PROPORTIONS FOR LI.
C                     --NI     = A PARAMETER THAT SPECIFIES THE NUMBER
C                                OF VALUES FOR LI AND PI.
C                     --GAMMA  = THE SHAPE PARAMETER GAMMA.
C                     --ALOC   = THE LOCATION PARAMETER.
C                     --SCALE  = THE SCALE PARAMETER.
C     OUTPUT ARGUMENTS--PDF    = A VARIABLE CONTAINING THE PROBABILITY
C                                DENSITY FUNCTION VALUES.
C     OUTPUT--THE DOUBLE PRECISION PROBABILITY DENSITY FUNCTION VALUES.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE NON-NEGATIVE.
C                 --GAMMA AND AL SHOULD BE POSITIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--BFWPDF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--STONER, EDIE, AND DURHAM (1994), "AN END-EFFECT MODEL
C                 FOR THE SINGLE-FILAMENT TENSILE TEST", JOURNAL OF
C                 OF MATERIALS SCIENCE, 29, PP. 6561-6574.
C               --NEWELL AND SAGENDORF (1999), "EXPERIMENTAL VERIFICATION
C                 OF THE END-EFFECT WEIBULL MODEL AS A PREDICTOR OF THE
C                 TENSILE STRENGTH OF KEVLAR-29 (POLY
C                 p-PHENYLENETEREPHTHALAMIDE) FIBRES AT DIFFERENCE GAUGE
C                 LENGTHS", HIGH PERFORMANCE POLYMERS, 11, PP. 297-305.
C     WRITTEN BY--ALAN HECKERT
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     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2010.8
C     ORIGINAL VERSION--OCTOBER   2010.
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION X(*)
      DOUBLE PRECISION LI(*)
      DOUBLE PRECISION PI(*)
      DOUBLE PRECISION PDF(*)
      DOUBLE PRECISION GAMMA
      DOUBLE PRECISION ALOC
      DOUBLE PRECISION SCALE
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
C
      CHARACTER*4 ISUBRO
      CHARACTER*4 IBUGA2
      CHARACTER*4 IERROR
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'WCD2')THEN
        WRITE(ICOUT,31)IBUGA2,ISUBRO
   31   FORMAT('AT THE BEGINNING OF BFWCD2')
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      IF(NX.LT.1)THEN
        WRITE(ICOUT,1)
    1   FORMAT('***** ERROR IN BRITTLE FIBER WEIBULL PDF--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,3)
    3   FORMAT('      THE NUMBER OF REQUESTED PDF VALUES IS ',
     1         'NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,5)NX
    5   FORMAT('      THE NUMBER OF REQUESTED PDF VALUES  = ',I8)
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        GOTO9000
      ELSEIF(NI.LT.1)THEN
        WRITE(ICOUT,1)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,13)
   13   FORMAT('      THE NUMBER OF DISTINCT GAUGE LENGTH (L) VALUES ',
     1         'IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,15)NI
   15   FORMAT('      THE NUMBER OF REQUESTED L VALUES  = ',I8)
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        GOTO9000
      ELSEIF(NI.GT.10)THEN
        WRITE(ICOUT,1)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,18)
   18   FORMAT('      THE NUMBER OF DISTINCT GAUGE LENGTH (L) VALUES ',
     1         'IS GREATER THAN 10.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,15)NI
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        GOTO9000
      ELSEIF(GAMMA.LE.0.0D0)THEN
        WRITE(ICOUT,1)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,23)
   23   FORMAT('      THE VALUE OF THE SHAPE PARAMETER (GAMMA) ',
     1         'IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,25)GAMMA
   25   FORMAT('      THE VALUE OF GAMMA  = ',G15.7)
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        GOTO9000
      ELSEIF(SCALE.LE.0.0D0)THEN
        WRITE(ICOUT,1)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,33)
   33   FORMAT('      THE VALUE OF THE SCALE PARAMETER IS ',
     1         'NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,35)SCALE
   35   FORMAT('      THE VALUE OF THE SCALE PARAMETER  = ',G15.7)
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        GOTO9000
      ENDIF
C
      DO40I=1,NX
        IF((GAMMA.GE.1.0D0 .AND. X(I).LT.ALOC) .OR.
     1     (GAMMA.LT.1.0D0 .AND. X(I).LE.ALOC))THEN
          WRITE(ICOUT,1)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,45)I
   45     FORMAT('      FOR ROW ',I8,' THE VALUE OF THE INPUT ',
     1           'ARGUMENT IS ')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,47)
   47     FORMAT('      LESS THAN OR EQUAL TO THE LOCATION PARAMETER.')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,48)X(I)
   48     FORMAT('      THE VALUE OF X(I)                    = ',G15.7)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,49)ALOC
   49     FORMAT('      THE VALUE OF THE LOCATION PARAMETER  = ',G15.7)
          CALL DPWRST('XXX','BUG ')
          GOTO9000
          IERROR='YES'
        ENDIF
   40 CONTINUE
C
      DSUM1=0.0D0
      DO50I=1,NI
        IF(LI(I).LE.0.0D0)THEN
          WRITE(ICOUT,1)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,52)I
   52     FORMAT('      FOR ROW ',I8,' THE VALUE OF THE GAUGE LENGTH ',
     1           'ARGUMENT (L) IS NON-POSITIVE.')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,54)LI(I)
   54     FORMAT('      THE VALUE OF L(I)  = ',G15.7)
          CALL DPWRST('XXX','BUG ')
          GOTO9000
          IERROR='YES'
        ELSEIF(PI(I).LE.0.0D0 .OR. PI(I).GT.1.0D0)THEN
          WRITE(ICOUT,1)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,57)I
   57     FORMAT('      FOR ROW ',I8,' THE VALUE OF THE MIXING ',
     1           'ARGUMENT (P)')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,58)
   58     FORMAT('      OUTSIDE THE (0,1) INTERVAL).')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,59)PI(I)
   59     FORMAT('      THE VALUE OF P(I)  = ',G15.7)
          CALL DPWRST('XXX','BUG ')
          GOTO9000
          IERROR='YES'
        ENDIF
        DSUM1=DSUM1 + PI(I)
   50 CONTINUE
C
C     CHECK THAT MIXING PROPORTIONS SUM TO 1
C
      IF(ABS(DSUM1 - 1.0D0).GT.0.000001D0)THEN
        WRITE(ICOUT,1)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,63)
   63   FORMAT('      THE MIXING PROPORTIONS DO NOT SUM TO ONE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,65)REAL(DSUM1)
   65   FORMAT('      THE SUM OF THE MIXING PROPORTIONS  = ',G15.7)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
C     NOW COMPUTE THE PDF BY SUMMING OVER THE L(I) CASES
C
      DO100I=1,NX
        DSUM1=0.0D0
        DO200J=1,NI
          DTERM1=(X(I)-ALOC)/SCALE
          CALL BFWPDF(DTERM1,GAMMA,LI(J),DTERM2)
          DSUM1=DSUM1 + PI(J)*(DTERM2/SCALE)
  200   CONTINUE
        PDF(I)=DSUM1
  100 CONTINUE
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE BFWPPF(P,GAMMA,AL,PPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE BRITTLE FIBER WEIBULL
C              DISTRIBUTION WITH TAIL LENGTH PARAMETER GAMMA AND
C              GAUGE LENGTH PARAMETER L.
C
C              THE BRITTLE FIBER WEIBULL DISTRIBUTION USED HEREIN IS
C              DEFINED FOR ALL POSITIVE X AND HAS THE PERCENT POINT
C              FUNCTION
C
C                 G(P;GAMMA,L) = [LOG(1/(1-P))/L]**(1/GAMMA)
C
C     INPUT  ARGUMENTS--P      = THE VALUE AT WHICH THE PERCENT POINT
C                                FUNCTION IS TO BE EVALUATED.  P SHOULD
C                                BE IN THE INTERVAL (0,1).
C                     --GAMMA  = THE SHAPE PARAMETER GAMMA.
C                     --AL     = THE GAUGE LENGTH PARAMETER L.
C     OUTPUT ARGUMENTS--PPF    = THE PERCENT POINT FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION PERCENT POINT
C             FUNCTION VALUE PPF FOR THE BRITTLE FIBER WEIBULL
C             DISTRIBUTION WITH TAIL LENGTH PARAMETER GAMMA AND
C             GAUGE LENGTH PARAMETER L.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--P SHOULD BE IN THE INTERVAL (0,1).
C                 --GAMMA AND AL SHOULD BE POSITIVE.
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--STONER, EDIE, AND DURHAM (1994), "AN END-EFFECT MODEL
C                 FOR THE SINGLE-FILAMENT TENSILE TEST", JOURNAL OF
C                 OF MATERIALS SCIENCE, 29, PP. 6561-6574.
C               --NEWELL AND SAGENDORF (1999), "EXPERIMENTAL VERIFICATION
C                 OF THE END-EFFECT WEIBULL MODEL AS A PREDICTOR OF THE
C                 TENSILE STRENGTH OF KEVLAR-29 (POLY
C                 p-PHENYLENETEREPHTHALAMIDE) FIBRES AT DIFFERENCE GAUGE
C                 LENGTHS", HIGH PERFORMANCE POLYMERS, 11, PP. 297-305.
C     WRITTEN BY--ALAN HECKERT
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     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2010.8
C     ORIGINAL VERSION--AUGUST    2010.
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION P
      DOUBLE PRECISION AL
      DOUBLE PRECISION GAMMA
      DOUBLE PRECISION PPF
      DOUBLE PRECISION DTERM1
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      PPF=0.0D0
      IF(P.LT.0.0D0 .OR. P.GE.1.0D0)THEN
        WRITE(ICOUT,5)
    5   FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO BFWPPF IS ',
     1         'OUTSIDE THE (0,1) INTERVAL.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)P
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(1.0D0 - P.LE.0.0D0)THEN
        WRITE(ICOUT,8)
    8   FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO BFWPPF IS ',
     1         'TOO CLOSE TO 1 TO COMPUTE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)P
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(GAMMA.LE.0.0D0)THEN
        WRITE(ICOUT,15)
   15   FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO BFWPPF IS ',
     1         'NON-POSITIVE')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)GAMMA
   46   FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(AL.LE.0.0D0)THEN
        WRITE(ICOUT,25)
   25   FORMAT('***** ERROR--THE THIRD INPUT ARGUMENT TO BFWPPF IS ',
     1         'NON-POSITIVE')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)AL
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
      IF(P.EQ.0.0D0)THEN
        PPF=0.0D0
      ELSE
        DTERM1=DLOG(1.0D0/(1.0D0 - P))
        PPF=(DTERM1/AL)**(1.0D0/GAMMA)
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE BFWPP2(P,NX,LI,PI,NI,GAMMA,ALOC,SCALE,
     1                  PPF,
     1                  ISUBRO,IBUGA2,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE BRITTLE FIBER WEIBULL
C              DISTRIBUTION.
C
C              THE BFWPPF ROUTINE COMPUTES THIS FUNCTION FOR A SINGLE
C              VALUE OF L.  THIS ROUTINE COMPUTES THIS FUNCTION FOR
C              MULTIPLE VALUES OF L.  IT DOES THIS USING A MIXTURE
C              APPROACH.  ALTHOUGH BFWPPF COMPUTES THIS USING AN
C              CLOSED FORMULA, BFWPP2 NEEDS TO COMPUTE IT BY
C              NUMERICALLY INVERTING THE CUMULATIVE DISTRIBUTION
C              FUNCTION.
C
C              THIS ROUTINE ASSUMES THAT THE LOCATION/SCALE/SHAPE
C              PARAMETERS ARE FIXED (I.E., ONLY L VARIES).
C
C              CURRENTLY, WE RESTRICT L TO A MAXIMUM OF 10 DISTINCT
C              LEVELS.
C
C     INPUT  ARGUMENTS--P      = A VARIABLE CONTAINING THE VALUES AT WHICH
C                                THE PERCENT POINT FUNCTION IS
C                                TO BE EVALUATED.
C                     --NX     = A PARAMETER THAT SPECIFIES THE NUMBER
C                                OF VALUES FOR P.
C                     --LI     = A VARIABLE CONTAINING THE GAUGE LENGTH
C                                PARAMETER L.
C                     --PI     = A VARIABLE CONTAINING THE "MIXING"
C                                PROPORTIONS FOR LI.
C                     --NI     = A PARAMETER THAT SPECIFIES THE NUMBER
C                                OF VALUES FOR LI AND PI.
C                     --GAMMA  = THE SHAPE PARAMETER GAMMA.
C                     --ALOC   = THE LOCATION PARAMETER.
C                     --SCALE  = THE SCALE PARAMETER.
C     OUTPUT ARGUMENTS--PPF    = A VARIABLE CONTAINING THE CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUES.
C     OUTPUT--THE DOUBLE PRECISION PERCENT POINT FUNCTION VALUES.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     OTHER DATAPAC   SUBROUTINES NEEDED--BFWCD2.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--STONER, EDIE, AND DURHAM (1994), "AN END-EFFECT MODEL
C                 FOR THE SINGLE-FILAMENT TENSILE TEST", JOURNAL OF
C                 OF MATERIALS SCIENCE, 29, PP. 6561-6574.
C               --NEWELL AND SAGENDORF (1999), "EXPERIMENTAL VERIFICATION
C                 OF THE END-EFFECT WEIBULL MODEL AS A PREDICTOR OF THE
C                 TENSILE STRENGTH OF KEVLAR-29 (POLY
C                 p-PHENYLENETEREPHTHALAMIDE) FIBRES AT DIFFERENCE GAUGE
C                 LENGTHS", HIGH PERFORMANCE POLYMERS, 11, PP. 297-305.
C     WRITTEN BY--ALAN HECKERT
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     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2010.8
C     ORIGINAL VERSION--OCTOBER   2010.
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION P(*)
      DOUBLE PRECISION LI(*)
      DOUBLE PRECISION PI(*)
      DOUBLE PRECISION PPF(*)
      DOUBLE PRECISION GAMMA
      DOUBLE PRECISION ALOC
      DOUBLE PRECISION SCALE
C
      DOUBLE PRECISION DCDF(1)
      DOUBLE PRECISION DX(1)
C
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DP
      DOUBLE PRECISION DP1
      DOUBLE PRECISION DPPF
      DOUBLE PRECISION DCDFL
      DOUBLE PRECISION DCDFR
      DOUBLE PRECISION DXL
      DOUBLE PRECISION DXR
      DOUBLE PRECISION DFXL
      DOUBLE PRECISION DFXR
      DOUBLE PRECISION DFCS
      DOUBLE PRECISION DXRML
      DOUBLE PRECISION DSIG
      DOUBLE PRECISION DEPS
      DOUBLE PRECISION LMIN
      DOUBLE PRECISION LMAX
C
      CHARACTER*4 ISUBRO
      CHARACTER*4 IBUGA2
      CHARACTER*4 IERROR
C
      INCLUDE 'DPCOP2.INC'
C
      DATA DEPS /1.0D-14/
      DATA DSIG /1.0D-14/
      DATA MAXIT /1000/
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'WCD2')THEN
        WRITE(ICOUT,31)IBUGA2,ISUBRO
   31   FORMAT('AT THE BEGINNING OF BFWCD2')
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      IF(NX.LT.1)THEN
        WRITE(ICOUT,1)
    1   FORMAT('***** ERROR IN BRITTLE FIBER WEIBULL PPF--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,3)
    3   FORMAT('      THE NUMBER OF REQUESTED PPF VALUES IS ',
     1         'NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,5)NX
    5   FORMAT('      THE NUMBER OF REQUESTED PPF VALUES  = ',I8)
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        GOTO9000
      ELSEIF(NI.LT.1)THEN
        WRITE(ICOUT,1)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,13)
   13   FORMAT('      THE NUMBER OF DISTINCT GAUGE LENGTH (L) VALUES ',
     1         'IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,15)NI
   15   FORMAT('      THE NUMBER OF REQUESTED L VALUES  = ',I8)
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        GOTO9000
      ELSEIF(NI.GT.10)THEN
        WRITE(ICOUT,1)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,18)
   18   FORMAT('      THE NUMBER OF DISTINCT GAUGE LENGTH (L) VALUES ',
     1         'IS GREATER THAN 10.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,15)NI
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        GOTO9000
      ELSEIF(GAMMA.LE.0.0D0)THEN
        WRITE(ICOUT,1)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,23)
   23   FORMAT('      THE VALUE OF THE SHAPE PARAMETER (GAMMA) ',
     1         'IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,25)GAMMA
   25   FORMAT('      THE VALUE OF GAMMA  = ',G15.7)
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        GOTO9000
      ELSEIF(SCALE.LE.0.0D0)THEN
        WRITE(ICOUT,1)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,33)
   33   FORMAT('      THE VALUE OF THE SCALE PARAMETER IS ',
     1         'NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,35)SCALE
   35   FORMAT('      THE VALUE OF THE SCALE PARAMETER  = ',G15.7)
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        GOTO9000
      ENDIF
C
      DSUM1=0.0D0
      DO50I=1,NI
        IF(LI(I).LE.0.0D0)THEN
          WRITE(ICOUT,1)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,52)I
   52     FORMAT('      FOR ROW ',I8,' THE VALUE OF THE GAUGE LENGTH ',
     1           'ARGUMENT (L) IS NON-POSITIVE.')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,54)LI(I)
   54     FORMAT('      THE VALUE OF L(I)  = ',G15.7)
          CALL DPWRST('XXX','BUG ')
          GOTO9000
          IERROR='YES'
        ELSEIF(PI(I).LE.0.0D0 .OR. PI(I).GT.1.0D0)THEN
          WRITE(ICOUT,1)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,57)I
   57     FORMAT('      FOR ROW ',I8,' THE VALUE OF THE MIXING ',
     1           'ARGUMENT (P)')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,58)
   58     FORMAT('      OUTSIDE THE (0,1) INTERVAL).')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,59)PI(I)
   59     FORMAT('      THE VALUE OF P(I)  = ',G15.7)
          CALL DPWRST('XXX','BUG ')
          GOTO9000
          IERROR='YES'
        ENDIF
        DSUM1=DSUM1 + PI(I)
   50 CONTINUE
C
C     CHECK THAT MIXING PROPORTIONS SUM TO 1
C
      IF(ABS(DSUM1 - 1.0D0).GT.0.000001D0)THEN
        WRITE(ICOUT,1)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,63)
   63   FORMAT('      THE MIXING PROPORTIONS DO NOT SUM TO ONE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,65)REAL(DSUM1)
   65   FORMAT('      THE SUM OF THE MIXING PROPORTIONS  = ',G15.7)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
C     NOW COMPUTE THE PPF BY NUMERICALLY INVERTING THE CDF FUNCTION
C
      NTEMP=1
      LMIN=LI(1)
      LMAX=LI(1)
      DO90I=1,NI
        IF(LI(I).LT.LMIN)LMIN=LI(I)
        IF(LI(I).GT.LMAX)LMAX=LI(I)
   90 CONTINUE
C
      DO100I=1,NX
        DP=P(I)
C
        IF(DP.LT.0.0D0 .OR. DP.GE.1.0D0)THEN
          WRITE(ICOUT,1)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,105)I
  105     FORMAT('      FOR ROW ',I8,' THE PROBABILITY PARAMETER (P) ',
     1           'IS OUTSIDE THE (0,1) INTERVAL.')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,106)DP
  106     FORMAT('      THE VALUE OF P  = ',G15.7)
          CALL DPWRST('XXX','BUG ')
          IERROR='YES'
          GOTO9000
        ELSEIF(1.0D0 - DP.LE.0.0D0)THEN
          WRITE(ICOUT,1)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,108)I
  108     FORMAT('      FOR ROW ',I8,' THE PROBABILITY PARAMETER (P) ',
     1           'IS TOO CLOSE TO 1 TO COMPUTE.')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,106)DP
          CALL DPWRST('XXX','BUG ')
          IERROR='YES'
          GOTO9000
        ENDIF
        IF(DP.EQ.0.0D0)THEN
          PPF(I)=ALOC
          GOTO100
        ENDIF
C
C       STEP 1: FIND BRACKETING INTERVAL
C
        CALL BFWPPF(DP,GAMMA,LMIN,DTERM1)
        DTERM1=ALOC + SCALE*DTERM1
        CALL BFWPPF(DP,GAMMA,LMAX,DTERM2)
        DTERM2=ALOC + SCALE*DTERM2
        DXL=MIN(DTERM1,DTERM2)
        DXR=MAX(DTERM1,DTERM2)
        IF(DXL.EQ.DXR)THEN
          PPF(I)=DXL
          GOTO100
        ENDIF
        NTEMP=1
        DX(1)=DXL
        CALL BFWCD2(DX,NTEMP,LI,PI,NI,GAMMA,ALOC,SCALE,DCDF,
     1              ISUBRO,IBUGA2,IERROR)
        DCDFL=DCDF(1)
        DX(1)=DXR
        CALL BFWCD2(DX,NTEMP,LI,PI,NI,GAMMA,ALOC,SCALE,DCDF,
     1              ISUBRO,IBUGA2,IERROR)
        DCDFR=DCDF(1)
C
        IF(DCDFL.LT.DP .AND. DCDFR.LT.DP)THEN
          PPF(I)=CPUMIN
          GOTO100
        ELSEIF(DCDFL.GT.DP .AND. DCDFR.GT.DP)THEN
          PPF(I)=CPUMIN
          GOTO100
        ENDIF
C
C       STEP 2: BISECTION METHOD
C
        IC = 0
        DFXL = -DP
        DFXR = 1.0D0 - DP
  205   CONTINUE
        DX(1)=(DXL+DXR)*0.5D0
        CALL BFWCD2(DX,NTEMP,LI,PI,NI,GAMMA,ALOC,SCALE,DCDF,
     1              ISUBRO,IBUGA2,IERROR)
        DP1=DCDF(1)
        DPPF=DX(1)
        DFCS = DP1 - DP
C
        IF(DFCS*DFXL.GT.0.0D0)THEN
          DXL = DX(1)
          DFXL = DFCS
        ELSE
          DXR = DX(1)
          DFXR = DFCS
        ENDIF
C
        DXRML = DXR - DXL
        IF(DXRML.LE.DSIG .AND. DABS(DFCS).LE.DEPS)THEN
          PPF(I)=DPPF
          GOTO100
        ENDIF
C
C       STEP 3: ERROR MESSAGE FOR NO CONVERGENCE
C
        IC = IC + 1
        IF(IC.LE.MAXIT)GOTO205
        WRITE(ICOUT,1)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,230)I,DP
  230   FORMAT('      FOR ROW ',I8,' (P = ',G15.7,'), THERE WAS ',
     1         'NO CONVERGENCE')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,233)
  233   FORMAT('      LAST VALUE OBTAINED WILL BE USED.')
        CALL DPWRST('XXX','BUG ')
        PPF(I)=DPPF
        GOTO100
C
  100 CONTINUE
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE BFWRAN(N,GAMMA,AL,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE BRITTLE FIBER WEIBULL DISTRIBUTION
C              WITH TAIL LENGTH PARAMETER VALUE = GAMMA.  NOT THAT THE
C              "GAUGE LENGTH" PARAMETER, L, IS ASSUMED FIXED AND KNOWN.
C              THIS IS ESSENTIALLY A RE-PARAMETERIZED WEIBULL
C              DISTRIBUTION THAT HAS THE PROBABILITY DENSITY FUNCTION
C
C              F(X;GAMMA,L,SCALE) = L*GAMMA*(X**(GAMMA-1))*
C                                   EXP(-L*((X/SCALE)**GAMMA))/
C                                   (SCALE**GAMMA)
C
C              SCALE IS SET TO 1 IN THIS ROUTINE.
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --GAMMA  = THE SINGLE PRECISION VALUE OF THE
C                                TAIL LENGTH PARAMETER.
C                                GAMMA SHOULD BE POSITIVE.
C                     --AL     = THE SINGLE PRECISION VALUE THAT SPECIEIS
C                                THE GAUGE LENGTH 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 BRITTLE FRACTURE WEIBULL
C             DISTRIBUTION WITH TAIL LENGTH PARAMETER VALUE = GAMMA.
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                 --GAMMA SHOULD BE POSITIVE.
C                 --AL    SHOULD BE POSITIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN, BFWPPF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--STONER, EDIE, AND DURHAM (1994), "AN END-EFFECT MODEL
C                 FOR THE SINGLE-FILAMENT TENSILE TEST", JOURNAL OF
C                 OF MATERIALS SCIENCE, 29, PP. 6561-6574.
C               --NEWELL AND SAGENDORF (1999), "EXPERIMENTAL VERIFICATION
C                 OF THE END-EFFECT WEIBULL MODEL AS A PREDICTOR OF THE
C                 TENSILE STRENGTH OF KEVLAR-29 (POLY
C                 p-PHENYLENETEREPHTHALAMIDE) FIBRES AT DIFFERENCE GAUGE
C                 LENGTHS", HIGH PERFORMANCE POLYMERS, 11, PP. 297-305.
C     WRITTEN BY--ALAN HECKERT
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     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2010.8
C     ORIGINAL VERSION--AUGUST    2010.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
C
      DOUBLE PRECISION DPPF
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)THEN
        WRITE(ICOUT, 5)
    5   FORMAT('***** ERROR--THE REQUESTED NUMBER OF BRITTLE FIBER ',
     1         'WEIBULL RANDOM NUMBERS IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
   47   FORMAT('***** THE REQUESTED NUMBER OF RANDOM NUMBERS IS ',I8)
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(GAMMA.LE.0.0)THEN
        WRITE(ICOUT,15)
   15   FORMAT('***** ERROR--THE VALUE OF THE SHAPE PARAMETER (GAMMA) ',
     1         'FOR THE BRITTLE FIBER WEIBULL')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,17)
   17   FORMAT('      RANDOM NUMBERS IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)GAMMA
   46   FORMAT('***** THE VALUE OF GAMMA IS ',G15.7)
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(AL.LE.0.0)THEN
        WRITE(ICOUT,25)
   25   FORMAT('***** ERROR--THE VALUE OF THE GAUGE LENGTH PARAMETER ',
     1         '(L) FOR THE BRITTLE FIBER WEIBULL')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,27)
   27   FORMAT('      RANDOM NUMBERS IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,45)AL
   45   FORMAT('***** THE VALUE OF L IS ',G15.7)
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
C     GENERATE N UNIFORM (0,1) RANDOM NUMBERS;
C
      CALL UNIRAN(N,ISEED,X)
C
C     GENERATE N BRITTLE FIBER WEIBULL DISTRIBUTION RANDOM NUMBERS
C     USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD.
C
      DO100I=1,N
        CALL BFWPPF(DBLE(X(I)),DBLE(GAMMA),DBLE(AL),DPPF)
        X(I)=REAL(DPPF)
  100 CONTINUE
C
 9000 CONTINUE
      RETURN
      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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
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 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
      INCLUDE 'DPCOP2.INC'
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)
   11   FORMAT('***** ERROR--THE SECOND ARGUMENT TO BGECDF ',
     1        ' BGECDF 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 ')
        GOTO9999
      ELSEIF(BETA.LE.0.0)THEN
        WRITE(ICOUT,12)
   12   FORMAT('***** ERROR--THE THIRD ARGUMENT TO BGECDF ',
     1         'IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)BETA
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
C
      INTX=INT(X+0.5)
      FINTX=REAL(INTX)
      IF(INTX.LT.1)THEN
        CDF=0.0
        GOTO9999
      ENDIF
C
      DX=DBLE(FINTX)
      IF(DX.GT.DBLE(I1MACH(9)))THEN
        WRITE(ICOUT,55)
   55   FORMAT('***** ERROR--THE FIRST ARGUMENT TO BGECDF IS GREATER ',
     1         'THAN THE LARGEST MACHINE INTEGER.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
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 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
      INCLUDE 'DPCOP2.INC'
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)
   11   FORMAT('***** ERROR--THE SECOND ARGUMENT TO BG2CDF ',
     1         '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 ')
        GOTO9999
      ELSEIF(BETA.LE.0.0)THEN
        WRITE(ICOUT,12)
   12   FORMAT('***** ERROR--THE THIRD ARGUMENT TO BG2CDF ',
     1         'IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)BETA
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
C
      INTX=INT(X+0.5)
      FINTX=REAL(INTX)
      IF(INTX.LT.0)THEN
        CDF=0.0
        GOTO9999
      ENDIF
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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
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
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C  COMPUTE SOME SUMS
C
      N=2
      IFLAG=0
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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
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
      INCLUDE 'DPCOP2.INC'
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)
   11   FORMAT('***** ERROR--THE SECOND ARGUMENT TO BGEPDF ',
     1         '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 ')
        GOTO9999
      ELSEIF(BETA.LE.0.0)THEN
        WRITE(ICOUT,12)
   12   FORMAT('***** ERROR--THE THIRD ARGUMENT TO BGEPDF ',
     1         'IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)BETA
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
C
      INTX=INT(X+0.5)
      FINTX=REAL(INTX)
      IF(INTX.LT.1)THEN
        WRITE(ICOUT,5)
    5   FORMAT('***** ERROR--THE FIRST ARGUMENT TO BGEPDF ',
     1         'IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ENDIF
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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
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
      INCLUDE 'DPCOP2.INC'
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)
   11   FORMAT('***** ERROR--THE SECOND ARGUMENT TO THE ',
     1' BG2PDF 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 ')
        GOTO9999
      ELSEIF(BETA.LE.0.0)THEN
        WRITE(ICOUT,12)
   12   FORMAT('***** ERROR--THE THIRD ARGUMENT TO BG2PDF ',
     1         'IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)BETA
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
C
      INTX=INT(X+0.5)
      FINTX=REAL(INTX)
      IF(INTX.LT.0)THEN
        WRITE(ICOUT,5)
    5   FORMAT('***** ERROR--THE FIRST ARGUMENT TO BG2PDF ',
     1         'IS NEGATIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ENDIF
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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
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
CCCCC DOUBLE PRECISION DX
      DOUBLE PRECISION DP
      DOUBLE PRECISION DALPHA
      DOUBLE PRECISION DBETA
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
      DOUBLE PRECISION DLBETA
      DOUBLE PRECISION DSUM
      DOUBLE PRECISION DPDF
      DOUBLE PRECISION DPDFSV
      DOUBLE PRECISION DEPS
C
      INCLUDE 'DPCOMC.INC'
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
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)
   11   FORMAT('***** ERROR--THE SECOND ARGUMENT TO BGEPPF ',
     1         '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 ')
        GOTO9999
      ELSEIF(BETA.LE.0.0)THEN
        WRITE(ICOUT,12)
   12   FORMAT('***** ERROR--THE THIRD ARGUMENT TO BGEPPF ',
     1         'IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)BETA
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ELSEIF(P.LT.0.0.OR.P.GE.1.0)THEN
        WRITE(ICOUT,1)
    1   FORMAT('***** ERROR--THE FIRST ARGUMENT TO BGEPPF ',
     1         'IS OUTSIDE THE ALLOWABLE (0,1] INTERVAL.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)P
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      DALPHA=DBLE(ALPHA)
      DBETA=DBLE(BETA)
      DSUM=0.0D0
      DP=DBLE(P)
      DEPS=1.0D-6
C
C     COMPUTE PDF FOR X = 1
C
      IF(P.EQ.0.0)THEN
        PPF=0.0
        GOTO9999
      ENDIF
C
      DTERM1=DLBETA(DALPHA+1.0D0,DBETA)
      DTERM2=DLBETA(DALPHA,DBETA)
      DTERM3=DTERM1-DTERM2
      DPDFSV=DEXP(DTERM3)
      DSUM=DPDFSV
      IF(DSUM.GE.DP-DEPS)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-DEPS)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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
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
CCCCC DOUBLE PRECISION DX
      DOUBLE PRECISION DP
      DOUBLE PRECISION DALPHA
      DOUBLE PRECISION DBETA
      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
      INCLUDE 'DPCOP2.INC'
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)
   11   FORMAT('***** ERROR--THE SECOND ARGUMENT TO BG2PPF ',
     1         '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 ')
        GOTO9999
      ELSEIF(BETA.LE.0.0)THEN
        WRITE(ICOUT,12)
   12   FORMAT('***** ERROR--THE THIRD ARGUMENT TO BG2PPF ',
     1         'IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)BETA
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ELSEIF(P.LT.0.0.OR.P.GE.1.0)THEN
        WRITE(ICOUT,1)
    1   FORMAT('***** ERROR--THE FIRST ARGUMENT TO BG2PPF ',
     1         'IS OUTSIDE THE ALLOWABLE (0,1] INTERVAL.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)P
        CALL DPWRST('XXX','BUG ')
      ENDIF
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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
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
      INCLUDE 'DPCOP2.INC'
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 bgrat(a,b,x,y,w,eps,ierr)
C-----------------------------------------------------------------------
C     ASYMPTOTIC EXPANSION FOR IX(A,B) WHEN A IS LARGER THAN B.
C     THE RESULT OF THE EXPANSION IS ADDED TO W. IT IS ASSUMED
C     THAT A .GE. 15 AND B .LE. 1.  EPS IS THE TOLERANCE USED.
C     IERR IS A VARIABLE THAT REPORTS THE STATUS OF THE RESULTS.
C-----------------------------------------------------------------------
C     .. Scalar Arguments ..
      DOUBLE PRECISION a,b,eps,w,x,y
      INTEGER ierr
C     ..
C     .. Local Scalars ..
      DOUBLE PRECISION bm1,bp2n,cn,coef,dj,j,l,lnx,n2,nu,p,q,r,s,sum,t,
     +                 t2,u,v,z
      INTEGER i,n,nm1
C     ..
C     .. Local Arrays ..
      DOUBLE PRECISION c(30),d(30)
C     ..
C     .. External Functions ..
      DOUBLE PRECISION algdiv,alnrel,gam1
      EXTERNAL algdiv,alnrel,gam1
C     ..
C     .. External Subroutines ..
      EXTERNAL grat1
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC abs,dlog,exp
C     ..
C     .. Executable Statements ..
C
      bm1 = (b-0.5D0) - 0.5D0
      nu = a + 0.5D0*bm1
      IF (y.GT.0.375D0) GO TO 10
      lnx = alnrel(-y)
      GO TO 20

   10 lnx = dlog(x)
   20 z = -nu*lnx
      IF (b*z.EQ.0.0D0) GO TO 70
C
C                 COMPUTATION OF THE EXPANSION
C                 SET R = EXP(-Z)*Z**B/GAMMA(B)
C
      r = b* (1.0D0+gam1(b))*exp(b*dlog(z))
      r = r*exp(a*lnx)*exp(0.5D0*bm1*lnx)
      u = algdiv(b,a) + b*dlog(nu)
      u = r*exp(-u)
      IF (u.EQ.0.0D0) GO TO 70
      CALL grat1(b,z,r,p,q,eps)
C
      v = 0.25D0* (1.0D0/nu)**2
      t2 = 0.25D0*lnx*lnx
      l = w/u
      j = q/r
      sum = j
      t = 1.0D0
      cn = 1.0D0
      n2 = 0.0D0
      DO 50 n = 1,30
          bp2n = b + n2
          j = (bp2n* (bp2n+1.0D0)*j+ (z+bp2n+1.0D0)*t)*v
          n2 = n2 + 2.0D0
          t = t*t2
          cn = cn/ (n2* (n2+1.0D0))
          c(n) = cn
          s = 0.0D0
          IF (n.EQ.1) GO TO 40
          nm1 = n - 1
          coef = b - n
          DO 30 i = 1,nm1
              s = s + coef*c(i)*d(n-i)
              coef = coef + b
   30     CONTINUE
   40     d(n) = bm1*cn + s/n
          dj = d(n)*j
          sum = sum + dj
          IF (sum.LE.0.0D0) GO TO 70
          IF (abs(dj).LE.eps* (sum+l)) GO TO 60
   50 CONTINUE
C
C                    ADD THE RESULTS TO W
C
   60 ierr = 0
      w = w + u*sum
      RETURN
C
C               THE EXPANSION CANNOT BE COMPUTED
C
   70 ierr = 1
      RETURN

      END
      SUBROUTINE BILINR(Z,Y,X,N,Y2,X2,N2,IWRITE,Z2,
     1                  YTEMP,XTEMP,YDIST,XDIST,
     1                  ZDIST,ZTEMP2,ZTEMP,
     1                  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                                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                 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     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--94/5
C     ORIGINAL VERSION--MAY       1994.
C     UPDATED         --JUNE      2019. DIMENSIONING OF SCRATCH
C                                       ARRAYS IN CALLING ROUTINE
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
      DIMENSION Z(*)
      DIMENSION Y(*)
      DIMENSION X(*)
      DIMENSION X2(*)
      DIMENSION Y2(*)
      DIMENSION Z2(*)
C
      DIMENSION YTEMP(*)
      DIMENSION XTEMP(*)
      DIMENSION YDIST(*)
      DIMENSION XDIST(*)
      DIMENSION ZDIST(*)
      DIMENSION ZTEMP2(*)
      DIMENSION ZTEMP(*)
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='BILI'
      ISUBN2='NR  '
      IERROR='NO'
C
      ISTART=0
      ILAST=0
C
      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'LINR')THEN
        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,N2
   52   FORMAT('N,N2 = ',2I8)
        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,3G15.7)
          CALL DPWRST('XXX','BUG ')
   55   CONTINUE
        DO65I=1,N2
          WRITE(ICOUT,66)I,Y2(I),X2(I)
   66     FORMAT('I,Y2(I),X2(I) = ',I8,2G15.7)
          CALL DPWRST('XXX','BUG ')
   65   CONTINUE
      ENDIF
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.GT.0)THEN
          DO1215I2=1,NDISTX
           IF(X(I).EQ.XDIST(I2))GOTO1210
 1215     CONTINUE
        ENDIF
        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.GT.0)THEN
          DO1315I2=1,NDISTY
            IF(Y(I).EQ.YDIST(I2))GOTO1310
 1315     CONTINUE
        ENDIF
        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,
     1            IBUGG3,ISUBRO,IERROR)
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'LINR')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9011)
 9011   FORMAT('***** AT THE END       OF BILINR--')
        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,3G15.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,3G15.7)
            CALL DPWRST('XXX','BUG ')
 9054     CONTINUE
 9052   CONTINUE
      ENDIF
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                 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     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
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='BILI'
      ISUBN2='N2  '
      IERROR='NO'
C
      IY1=0
      IY2=0
      IX1=0
      IX2=0
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 DOUBLE PRECISION VALUE X FOR THE
C              BINOMIAL DISTRIBUTION WITH DOUBLE PRECISION 'BERNOULLI
C              PROBABILITY' PARAMETER = P, AND INTEGER 'NUMBER OF
C              BERNOULLI TRIALS' PARAMETER = N.  THE BINOMIAL
C              DISTRIBUTION USED HEREIN HAS MEAN = N*P AND
C              STANDARD DEVIATION = SQRT(N*P*(1-P)).  THIS DISTRIBUTION
C              IS DEFINED FOR ALL DISCRETE INTEGER X BETWEEN 0
C              (INCLUSIVELY) AND N (INCLUSIVELY).
C              THIS DISTRIBUTION HAS THE PROBABILITY FUNCTION
C
C                 p(X;P,N) = C(N,X) * P**X * (1-P)**(N-X).
C
C              WHERE C(N,X) IS THE COMBINATORIAL FUNCTION
C              EQUALING THE NUMBER OF COMBINATIONS OF N ITEMS
C              TAKEN X AT A TIME.  THE BINOMIAL DISTRIBUTION IS THE
C              DISTRIBUTION OF THE NUMBER OF SUCCESSES IN N BERNOULLI
C              (0,1) TRIALS WHERE THE PROBABILITY OF SUCCESS
C              IN A SINGLE TRIAL = P.
C     INPUT  ARGUMENTS--X      = THE DOUBLE PRECISION VALUE AT WHICH
C                                THE CUMULATIVE DISTRIBUTION FUNCTION
C                                IS TO BE EVALUATED.  X SHOULD BE
C                                INTEGRAL-VALUED, AND BETWEEN 0.0
C                                AND N (INCLUSIVELY).
C                     --P      = THE DOUBLE PRECISION VALUE OF THE
C                                'BERNOULLI PROBABILITY' PARAMETER FOR
C                                THE BINOMIAL DISTRIBUTION.  P SHOULD BE
C                                BETWEEN 0.0 (INCLUSIVELY) AND
C                                1.0 (INCLUSIVELY).
C                     --N      = THE INTEGER VALUE OF THE 'NUMBER OF
C                                BERNOULLI TRIALS' PARAMETER.
C                                N SHOULD BE A POSITIVE INTEGER.
C     OUTPUT ARGUMENTS--CDF    = THE DOUBLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION CUMULATIVE DISTRIBUTION
C             FUNCTION VALUE CDF 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, AND BETWEEN 0.0
C                  (INCLUSIVELY) AND N (INCLUSIVELY).
C                 --P SHOULD BE BETWEEN 0.0 (EXCLUSIVELY) AND 1.0
C                   (INCLUSIVELY).
C                 --N SHOULD BE A POSITIVE INTEGER.
C     OTHER DATAPAC   SUBROUTINES NEEDED--DBETAI.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
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                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--82/7
C     ORIGINAL VERSION--NOVEMBER  1975.
C     UPDATED         --MAY       1977.
C     UPDATED         --DECEMBER  1981.
C     UPDATED         --MAY       1982.
C     UPDATED         --MARCH     2009. USE DBETAI FUNCTION
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      EXTERNAL DBETAI
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      CDF=0.0D0
      DN=DBLE(N)
C
      IF(P.LT.0.0D0 .OR. P.GT.1.0D0)THEN
        WRITE(ICOUT,11)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)P
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(N.LT.0)THEN
        WRITE(ICOUT,25)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(X.LT.0.0D0 .OR. X.GT.DN)THEN
        WRITE(ICOUT,4)N
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        IF(X.LT.0.0D0)CDF=0.0D0
        IF(X.GT.DN)CDF=1.0D0
        GOTO9000
      ENDIF
    4 FORMAT('***** WARNING--THE FIRST ARGUMENT TO BINCDF IS OUTSIDE ',
     1       'THE (0,N) = (0,',I8,') INTERVAL')
   11 FORMAT('***** ERROR--THE SECOND ARGUMENT TO BINCDF IS OUTSIDE ',
     1       'THE ALLOWABLE (0,1) INTERVAL')
   25 FORMAT('***** ERROR--THE THIRD ARGUMENT TO BINCDF IS ',
     1       'NON-POSITIVE')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I10)
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=INT(X+0.0001D0)
      DX=DBLE(INTX)
C
      IF(INTX.EQ.N)THEN
        CDF=1.0D0
      ELSEIF(P.EQ.0.0D0)THEN
        CDF=1.0D0
      ELSEIF(P.EQ.1.0D0 .AND. INTX.GE.N)THEN
        CDF=1.0D0
      ELSEIF(P.EQ.1.0D0 .AND. INTX.LT.N)THEN
        CDF=0.0
      ELSE
        CDF=1.0D0 - DBETAI(DBLE(P),DX+1.0D0,DN-DX)
      ENDIF
C
 9000 CONTINUE
      RETURN
      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     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
      DOUBLE PRECISION DCDF
C
      COMMON/BINCOM/X,CONST,N
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      CALL BINCDF(DBLE(X),DBLE(P),N,DCDF)
      BINFUN=REAL(DCDF) - CONST
C
      RETURN
      END
      SUBROUTINE BINMAT(Y1,Y2,N,ICASL7,IWRITE,XIDTEM,STAT,
     1                  ISUBRO,IBUGA3,IERROR)
C
C     PURPOSE--GIVEN TWO BINARY RESPONSE VARIABLES (BINARY IN THE
C              SENSE OF BEING EITHER 0 OR 1 VALUES), COMPUTE
C              VARIOUS SIMILARITY, DISSIMILARITY AND INDEX VALUES.
C
C              THIS IS SPECIFICALLY FOR THE 2X2 CASE.  THAT IS,
C              EACH VARIABLE HAS TWO MUTUALLY EXCLUSIVE
C              CHOICES CODED AS 1 (FOR SUCCESS) OR 0 (FOR
C              FAILURE).  A FALSE POSITIVE IS DEFINED AS THE
C              ERROR WHERE THE SECOND VARIABLE IS 1 AND THE FIRST
C              VARIABLE IS A 0.  THIS DEFINES THE FOLLOWING
C              CONTNGENCY TABLE:
C
C                                    RESPONSE VARIABLE 2
C                                             0      1
C                                       -----------------
C                 RESPONSE VARIABLE 1:  0  |  A      B   |
C                                       1  |  C      D   |
C                                       -----------------
C
C              WHERE A, B, C, AND D DENOTE THE COUNTS FOR EACH
C              OF THESE CATEGORIES.
C
C              ROUSSEEUW AND KAUFFMAN DOCUMENT THE FOLLOWING
C              MATCHING SCORES THAT ARE OFTEN USED IN CLUSTERING
C              APPLICATIONS:
C
C              SYMMETRIC BINARY VARIABLES
C                 SIMILARITY:
C                 MATCHING COEFFICIENT:    (A+D)/(A+B+C+D)
C                 ROGERS AND TANIMOTO:     (A+D)/((A+D) + 2*(B+C))
C                 SOKAL AND SNEATH:        2*(A+D)/(2*(A+D) + (B+C))
C                 YULES Q                  (A*D - B*C)/(A*D + B*C)
C
C                 DISSIMILARITY:
C                 MATCHING COEFFICIENT:    (B+C)/(A+B+C+D)
C                 ROGERS AND TANIMOTO:     2*(B+C)/((A+D) + 2*(B+C))
C                 SOKAL AND SNEATH:        (B+C)/(2*(A+D) + (B+C))
C
C              ASYMMETRIC BINARY VARIABLES (MOST IMPORTANT VALUE
C              CODED AS 1)
C                 SIMILARITY:
C                 JACCARD COEFFICIENT:    A/(A+B+C)
C                 DICE COEFFICIENT:       2*A/(2*A+B+C)
C                 SOKAL COEFFICIENT:      A/(A+2(B+C))
C
C
C                 DISSIMILARITY:
C                 JACCARD COEFFICIENT:    (A+D)/(A+B+C+D)
C                 DICE COEFFICIENT:       (B+C)/(2*A+B+C)
C                 SOKAL COEFFICIENT:      2*(B+C)/(A+2(B+C))
C
C              ASYMMETRIC COEFFICIENTS ARE TYPICALLY USED WHEN
C              ONE OUTCOME IS RARE (E.G., MATCHING A RARE OUTCOME
C              IS THE IMPORTANT EVENT).
C
C              YOUDEN'S INDEX IS DEFINED AS
C
C                  J = (A*D - B*C)/((A+B)*(C+D))
C
C               YOUDEN'S INDEX IS TYPICALLY USED IN THE CONTEXT
C               OF ASSESSING THE PERFORMANCE OF A DIAGNOSTIC TEST
C               RATHER THAN AS A SIMILARITY OR DISSIMILARITY
C               MEASURE.  SPECIFICALLY, 0 INDICATES A TEST WITH
C               NO USEFUL INFORMATION WHILE 1 INDICATES A TEST WITH
C               NO FALSE POSITIVE AND NO FALSE NEGATIVES.
C
C              YULE'S Q (WHICH IS EQUIVALENT TO THE KRUSKAL GOODMAN
C              GAMMA COEFFICIENT FOR THIS CASE) IS DEFINED AS
C
C                  Q = (A*D - B*C)/(A*D + B*C)
C
C               YULE'S Y IS DEFINED IN TERMS OF THE YULE'S Q AS:
C
C                  Y = (1 - SQRT(1 - Q**2))/Q
C
C               OR DIRECTLY AS:
C
C                  {SQRT(A*D) - SQRT(B*C)}/{SQRT(A*D) + SQRT(B*C)}
C
C     INPUT  ARGUMENTS--Y1     = THE SINGLE PRECISION VECTOR OF
C                                (UNSORTED) OBSERVATIONS
C                                WHICH CONSTITUTE THE FIRST SET
C                                OF DATA.
C                     --Y2     = THE SINGLE PRECISION VECTOR OF
C                                (UNSORTED) OBSERVATIONS
C                                WHICH CONSTITUTE THE SECOND SET
C                                OF DATA.
C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTOR X, OR EQUIVALENTLY,
C                                THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTOR Y.
C     OUTPUT ARGUMENTS--STAT   = THE SINGLE PRECISION VALUE OF THE
C                                COMPUTED FALSE POSITIVE PROPORTION
C                                BETWEEN THE 2 SETS OF DATA
C                                IN THE INPUT VECTORS X AND Y.
C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE SAMPLE
C             MATCHING COEFFICIENT OF DATA IN THE INPUT VECTORS Y1
C             AND Y2.
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--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCE--KAUFMAN AND ROUSSEEUW (1990), "FINDING GROUPS IN DATA:
C                AN INTRODUCTION TO CLUSTER ANALYSIS", WILEY.
C              --YOUDEN (1950), "INDEX FOR RATING DIAGNOSTIC TESTS",
C                CANCER, 3, PP. 32-35.
C     WRITTEN BY--ALAN HECKERT
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTIUTE 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     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2017/08
C     ORIGINAL VERSION--AUGUST    2017.
C     UPDATED         --JANUARY   2019. YOUDEN INDEX
C     UPDATED         --AUGUST    2019. GAMMA COEFFICIENT FOR 2X2 CASE
C     UPDATED         --AUGUST    2019. YULE'S Y
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 ICASL7
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGA3
      CHARACTER*4 ISUBRO
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISTEPN
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*33 ISTAT
C
C---------------------------------------------------------------------
C
      DIMENSION Y1(*)
      DIMENSION Y2(*)
      DIMENSION XIDTEM(*)
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='BINM'
      ISUBN2='AT  '
      IERROR='NO'
C
C
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'NMAT')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,51)
   51   FORMAT('***** AT THE BEGINNING OF BINMAT--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,52)IBUGA3,ISUBRO,ICASL7,N
   52   FORMAT('IBUGA3,ISUBRO,ICASL7,N = ',3(A4,2X),I8)
        CALL DPWRST('XXX','BUG ')
        DO55I=1,N
          WRITE(ICOUT,56)I,Y1(I),Y2(I)
   56     FORMAT('I,Y1(I),Y2(I) = ',I8,2G15.7)
          CALL DPWRST('XXX','BUG ')
   55   CONTINUE
      ENDIF
C
C               ********************************************
C               **  STEP 21--                             **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      ISTEPN='21'
      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(N.LT.1)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,1201)
 1201   FORMAT('***** ERROR IN THE BINARY MATCHING ROUTINE--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,1203)
 1203   FORMAT('      THE NUMBER OF OBSERVATIONS FOR THE RESPONSE ',
     1         'VARIABLES IS LESS THAN ONE.')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,1205)N
 1205   FORMAT('SAMPLE SIZE = ',I8)
        CALL DPWRST('XXX','WRIT')
        IERROR='YES'
        GOTO9000
      ENDIF
C
C               ********************************************
C               **  STEP 22--                             **
C               **  CHECK THAT THE VARIABLES HAVE AT MOST **
C               **  TWO DISTINCT VALUES (1 INDICATES A    **
C               **  SUCCESS, 0 INDICATES A FAILURE).      **
C               ********************************************
C
      ISTEPN='22'
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'NMAT')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
C     NOTE: CHECK FOR SPECIAL CASE N = 2.  IN THIS CASE,
C           ASSUME WE HAVE A 2X2 TABLE OF COUNTS INSTEAD
C           OF RAW DATA.
C
      IF(N.EQ.2)THEN
        A=Y1(1)
        B=Y2(1)
        C=Y1(2)
        D=Y2(2)
C
C       CHECK IF ALL ENTRIES 0 OR 1. IF SO, ASSUME
C       RAW DATA CASE.
C
        IF((A.EQ.0.0 .OR. A.EQ.1.0) .AND.
     1     (B.EQ.0.0 .OR. B.EQ.1.0) .AND.
     1     (C.EQ.0.0 .OR. C.EQ.1.0) .AND.
     1     (D.EQ.0.0 .OR. D.EQ.1.0)) GOTO3000
C
        IF(A.LT.0.0)THEN
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,1201)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,1311)
 1311     FORMAT('      ROW 1 COLUMN 1 OF THE COUNTS TABLE IS ',
     1           'NEGATIVE.')
          CALL DPWRST('XXX','BUG ')
        ELSEIF(B.LT.0.0)THEN
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,1201)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,1321)
 1321     FORMAT('      ROW 2 COLUMN 1 OF THE COUNTS TABLE IS ',
     1           'NEGATIVE.')
          CALL DPWRST('XXX','BUG ')
        ELSEIF(C.LT.0.0)THEN
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,1201)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,1331)
 1331     FORMAT('      ROW 1 COLUMN 2 OF THE COUNTS TABLE IS ',
     1           'NEGATIVE.')
          CALL DPWRST('XXX','BUG ')
        ELSEIF(D.LT.0.0)THEN
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,1201)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,1341)
 1341     FORMAT('      ROW 2 COLUMN 2 OF THE COUNTS TABLE IS ',
     1           'NEGATIVE.')
          CALL DPWRST('XXX','BUG ')
        ENDIF
C
      ENDIF
C
      CALL DISTIN(Y1,N,IWRITE,XIDTEM,NDIST,IBUGA3,IERROR)
      IF(NDIST.EQ.1)THEN
        AVAL=XIDTEM(1)
        IF(ABS(AVAL).LE.0.5)THEN
          AVAL=0.0
        ELSE
          AVAL=1.0
        ENDIF
        DO2202I=1,N
          Y1(I)=1.0
 2202   CONTINUE
      ELSEIF(NDIST.EQ.2)THEN
        IF(XIDTEM(1).EQ.1.0 .OR. XIDTEM(2).EQ.1.0)THEN
          DO2203I=1,N
            IF(Y1(I).NE.1.0)Y1(I)=0.0
 2203     CONTINUE
        ELSE
          ATEMP1=MIN(XIDTEM(1),XIDTEM(2))
          ATEMP2=MAX(XIDTEM(1),XIDTEM(2))
          DO2208I=1,N
            IF(Y1(I).EQ.ATEMP1)Y1(I)=0.0
            IF(Y1(I).EQ.ATEMP2)Y1(I)=1.0
 2208     CONTINUE
        ENDIF
      ELSE
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,1201)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,2211)
 2211   FORMAT('      RESPONSE VARIABLE ONE SHOULD CONTAIN AT MOST')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,2213)
 2213   FORMAT('      TWO DISTINCT VALUES.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,2215)NDIST
 2215   FORMAT('      ',I8,' DISTINCT VALUES FOUND.')
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        GOTO9000
      ENDIF
C
      CALL DISTIN(Y2,N,IWRITE,XIDTEM,NDIST,IBUGA3,IERROR)
      IF(NDIST.EQ.1)THEN
        AVAL=XIDTEM(1)
        IF(ABS(AVAL).LE.0.5)THEN
          AVAL=0.0
        ELSE
          AVAL=1.0
        ENDIF
        DO2302I=1,N
          Y2(I)=1.0
 2302   CONTINUE
      ELSEIF(NDIST.EQ.2)THEN
        IF(XIDTEM(1).EQ.1.0 .OR. XIDTEM(2).EQ.1.0)THEN
          DO2303I=1,N
            IF(Y2(I).NE.1.0)Y2(I)=0.0
 2303     CONTINUE
        ELSE
          ATEMP1=MIN(XIDTEM(1),XIDTEM(2))
          ATEMP2=MAX(XIDTEM(1),XIDTEM(2))
          DO2308I=1,N
            IF(Y2(I).EQ.ATEMP1)Y2(I)=0.0
            IF(Y2(I).EQ.ATEMP2)Y2(I)=1.0
 2308     CONTINUE
        ENDIF
      ELSE
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,1201)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,2311)
 2311   FORMAT('      RESPONSE VARIABLE TWO SHOULD CONTAIN AT MOST')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,2313)
 2313   FORMAT('      TWO DISTINCT VALUES.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,2315)NDIST
 2315   FORMAT('      ',I8,' DISTINCT VALUES FOUND.')
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        GOTO9000
      ENDIF
C
      A=0.0
      B=0.0
      C=0.0
      D=0.0
      DO2410I=1,N
        IF(Y1(I).EQ.1.0 .AND. Y2(I).EQ.1.0)THEN
          D=D+1.0
        ELSEIF(Y1(I).EQ.0.0 .AND. Y2(I).EQ.0.0)THEN
          A=A+1.0
        ELSEIF(Y1(I).EQ.1.0 .AND. Y2(I).EQ.0.0)THEN
          C=C+1.0
        ELSEIF(Y1(I).EQ.0.0 .AND. Y2(I).EQ.1.0)THEN
          B=B+1.0
        ENDIF
 2410 CONTINUE
C
 3000 CONTINUE
C
      IF(ICASL7.EQ.'BMDI')THEN
        STAT=(B+C)/(A+B+C+D)
        ISTAT='MATCHING DISSIMILARITY'
      ELSEIF(ICASL7.EQ.'BMSI')THEN
        STAT=(A+D)/(A+B+C+D)
        ISTAT='MATCHING SIMILARITY'
      ELSEIF(ICASL7.EQ.'BMRD')THEN
        ANUM=2.0*(B+C)
        DENOM=(A+D) + 2.0*(B+C)
        STAT=ANUM/DENOM
        ISTAT='ROGERS AND TANIMOTO DISSIMILARITY'
      ELSEIF(ICASL7.EQ.'BMRS')THEN
        ANUM=A+D
        DENOM=(A+D) + 2.0*(B+C)
        STAT=ANUM/DENOM
        ISTAT='ROGERS AND TANIMOTO SIMILARITY'
      ELSEIF(ICASL7.EQ.'BMSD')THEN
        ANUM=B+C
        DENOM=2.0*(A+D) + (B+C)
        STAT=ANUM/DENOM
        ISTAT='SOKAL AND SNEATH DISSIMILARITY'
      ELSEIF(ICASL7.EQ.'BMSS')THEN
        ANUM=2.0*(A+D)
        DENOM=2.0*(A+D) + (B+C)
        STAT=ANUM/DENOM
        ISTAT='SOKAL AND SNEATH SIMILARITY'
      ELSEIF(ICASL7.EQ.'BJDI')THEN
        ANUM=B+C
        DENOM=A+B+C
        IF(DENOM.GT.0.0)THEN
          STAT=ANUM/DENOM
        ELSE
          STAT=CPUMIN
        ENDIF
        ISTAT='JACCARD ASYMMETRIC DISSIMILARITY'
      ELSEIF(ICASL7.EQ.'BJSI')THEN
        ANUM=A
        DENOM=A+B+C
        IF(DENOM.GT.0.0)THEN
          STAT=ANUM/DENOM
        ELSE
          STAT=CPUMIN
        ENDIF
        ISTAT='JACCARD ASYMMETRIC SIMILARITY'
      ELSEIF(ICASL7.EQ.'BDDI')THEN
        ANUM=B+C
        DENOM=2.0*A+B+C
        IF(DENOM.GT.0.0)THEN
          STAT=ANUM/DENOM
        ELSE
          STAT=CPUMIN
        ENDIF
        ISTAT='DICE ASYMMETRIC DISSIMILARITY'
      ELSEIF(ICASL7.EQ.'BDSI')THEN
        ANUM=2.0*A
        DENOM=2.0*A+B+C
        IF(DENOM.GT.0.0)THEN
          STAT=ANUM/DENOM
        ELSE
          STAT=CPUMIN
        ENDIF
        ISTAT='DICE ASYMMETRIC SIMILARITY'
      ELSEIF(ICASL7.EQ.'BSDI')THEN
        ANUM=2.0*(B+C)
        DENOM=A+2.0*(B+C)
        IF(DENOM.GT.0.0)THEN
          STAT=ANUM/DENOM
        ELSE
          STAT=CPUMIN
        ENDIF
        ISTAT='SOKAL ASYMMETRIC DISSIMILARITY'
      ELSEIF(ICASL7.EQ.'BSSI')THEN
        ANUM=A
        DENOM=A+2.0*(B+C)
        IF(DENOM.GT.0.0)THEN
          STAT=ANUM/DENOM
        ELSE
          STAT=CPUMIN
        ENDIF
        ISTAT='SOKAL ASYMMETRIC SIMILARITY'
      ELSEIF(ICASL7.EQ.'YULQ' .OR. ICASL7.EQ.'GC22')THEN
        ANUM=A*D - B*C
        DENOM=A*D + B*C
        IF(DENOM.GT.0.0)THEN
          STAT=ANUM/DENOM
        ELSE
          STAT=CPUMIN
        ENDIF
        ISTAT='YULES Q'
      ELSEIF(ICASL7.EQ.'YOUD')THEN
        ANUM=A*D - B*C
        DENOM=(A+B)*(C+D)
        IF(DENOM.GT.0.0)THEN
          STAT=ANUM/DENOM
        ELSE
          STAT=CPUMIN
        ENDIF
        ISTAT='YOUDEN INDEX'
      ELSEIF(ICASL7.EQ.'YULY')THEN
        ANUM=SQRT(A*D) - SQRT(B*C)
        DENOM=SQRT(A*D) + SQRT(B*C)
        IF(DENOM.GT.0.0)THEN
          STAT=ANUM/DENOM
        ELSE
          STAT=CPUMIN
        ENDIF
        ISTAT='YULES Y'
      ENDIF
C
C               *******************************
C               **  STEP 3--                 **
C               **  WRITE OUT A LINE         **
C               **  OF SUMMARY INFORMATION.  **
C               *******************************
C
      IF(IFEEDB.EQ.'ON' .AND. IWRITE.EQ.'ON')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,811)ISTAT,STAT
  811   FORMAT('THE ',A33,' COEFFICIENT = ',G15.7)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'NMAT')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9011)
 9011   FORMAT('***** AT THE END OF BINMAT--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9013)IERROR,A,B,C,D,STAT
 9013   FORMAT('IERROR,A,B,C,D,STAT = ',A4,2X,5G15.7)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      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
      INCLUDE 'DPCOP2.INC'
C
      DATA SQ2PIL / 0.9189385332 0467274E0 /
      DATA BILNMX, FINTMX / 0.0, 0.0 /
C***FIRST EXECUTABLE STATEMENT  BINOM
C
      BINOM=0.0
C
      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 BINPDF(X,P,N,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY MASS
C              FUNCTION VALUE AT THE DOUBLE PRECISION VALUE X FOR THE
C              BINOMIAL DISTRIBUTION WITH DOUBLE PRECISION 'BERNOULLI
C              PROBABILITY' PARAMETER = P, AND INTEGER 'NUMBER OF
C              BERNOULLI TRIALS' PARAMETER = N.  THE BINOMIAL
C              DISTRIBUTION USED HEREIN HAS MEAN = N*P AND
C              STANDARD DEVIATION = SQRT(N*P*(1-P)).  THIS DISTRIBUTION
C              IS DEFINED FOR ALL DISCRETE INTEGER X BETWEEN 0
C              (INCLUSIVELY) AND N (INCLUSIVELY).
C              THIS DISTRIBUTION HAS THE PROBABILITY FUNCTION
C
C                 p(X;P,N) = C(N,X) * P**X * (1-P)**(N-X).
C
C              WHERE C(N,X) IS THE COMBINATORIAL FUNCTION
C              EQUALING THE NUMBER OF COMBINATIONS OF N ITEMS
C              TAKEN X AT A TIME.  THE BINOMIAL DISTRIBUTION IS THE
C              DISTRIBUTION OF THE NUMBER OF SUCCESSES IN N BERNOULLI
C              (0,1) TRIALS WHERE THE PROBABILITY OF SUCCESS
C              IN A SINGLE TRIAL = P.
C     INPUT  ARGUMENTS--X      = THE DOUBLE PRECISION VALUE AT WHICH
C                                THE PORBABILITY MASS FUNCTION
C                                IS TO BE EVALUATED.  X SHOULD BE
C                                INTEGRAL-VALUED, AND BETWEEN 0.0
C                                AND N (INCLUSIVELY).
C                     --P      = THE DOUBLE PRECISION VALUE OF THE
C                                'BERNOULLI PROBABILITY' PARAMETER FOR
C                                THE BINOMIAL DISTRIBUTION.  P SHOULD BE
C                                BETWEEN 0.0 (EXCLUSIVELY) AND
C                                1.0 (INCLUSIVELY).
C                     --N      = THE INTEGER VALUE OF THE 'NUMBER OF
C                                BERNOULLI TRIALS' PARAMETER.
C                                N SHOULD BE A POSITIVE INTEGER.
C     OUTPUT ARGUMENTS--PDF    = THE DOUBLE PRECISION PROBABILITY MASS
C                                FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION PROBABILITY MASS FUNCTION VALUE PDF
C             FOR THE BINOMIAL DISTRIBUTION WITH 'BERNOULLI PROBABILITY'
C             PARAMETER = P AND 'NUMBER OF BERNOULLI TRIALS'
C             PARAMETER = N.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE INTEGRAL-VALUED, AND BETWEEN 0.0
C                  (INCLUSIVELY) AND N (INCLUSIVELY).
C                 --P SHOULD BE BETWEEN 0.0 (INCLUSIVELY) AND 1.0
C                   (INCLUSIVELY).
C                 --N SHOULD BE A POSITIVE INTEGER.
C     OTHER DATAPAC   SUBROUTINES NEEDED--BINRAW.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--CATHERINE LOADER (2000), "FAST AND ACCURATE COMPUTATION
C                 OF BINOMIAL PROBABILITIES", BELL LABS?
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-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2009/3
C     ORIGINAL VERSION--MARCH     2009.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      PDF=0.0D0
      DN=DBLE(N)
C
      IF(P.LT.0.0D0 .OR. P.GT.1.0D0)THEN
        WRITE(ICOUT,11)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)P
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(N.LT.0)THEN
        WRITE(ICOUT,25)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(X.LT.0.0D0 .OR. X.GT.DN)THEN
        WRITE(ICOUT,4)N
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
    4 FORMAT('***** WARNING--THE FIRST ARGUMENT TO BINPDF IS OUTSIDE ',
     1       'THE (0,N) = (0,',I8,') INTERVAL')
   11 FORMAT('***** ERROR--THE SECOND ARGUMENT TO BINPDF IS OUTSIDE ',
     1       'THE ALLOWABLE (0,1) INTERVAL')
   25 FORMAT('***** ERROR--THE THIRD ARGUMENT TO BINPDF IS ',
     1       'NON-POSITIVE')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I10)
C
      INTX=INT(X+0.0001D0)
      DX=DBLE(INTX)
      DQ=1.0D0 - P
      ILOG=0
C
      CALL BINRAW(DX,P,DQ,DN,PDF,ILOG)
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE BINPPF(P,PPAR,N,PPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT FUNCTION
C              VALUE AT THE DOUBLE PRECISION VALUE P FOR THE BINOMIAL
C              DISTRIBUTION WITH DOUBLE PRECISION 'BERNOULLI PROBABILITY'
C              PARAMETER = PPAR, AND INTEGER 'NUMBER OF BERNOULLI
C              TRIALS' C              PARAMETER = N.  THE BINOMIAL
C              DISTRIBUTION USED HEREIN HAS MEAN = N*PPAR AND
C              STANDARD DEVIATION = SQRT(N*PPAR*(1-PPAR)).  THIS
C              DISTRIBUTION IS DEFINED FOR ALL DISCRETE INTEGER X
C              BETWEEN 0 (INCLUSIVELY) AND N (INCLUSIVELY).
C              THIS DISTRIBUTION HAS THE PROBABILITY FUNCTION
C
C                 p(X;P,N) = C(N,X) * PPAR**X * (1-PPAR)**(N-X).
C
C              WHERE C(N,X) IS THE COMBINATORIAL FUNCTION EQUALING THE
C              NUMBER OF COMBINATIONS OF N ITEMS TAKEN X AT A TIME.
C              THE BINOMIAL DISTRIBUTION IS THE DISTRIBUTION OF THE
C              NUMBER OF SUCCESSES IN N BERNOULLI (0,1) TRIALS WHERE
C              THE PROBABILITY OF SUCCESS 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 DOUBLE PRECISION VALUE (BETWEEN
C                                0.0 (INCLUSIVELY) AND 1.0
C                                (INCLUSIVELY)) AT WHICH THE PERCENT
C                                POINT FUNCTION IS TO BE EVALUATED.
C                     --PPAR   = THE DOUBLE PRECISION VALUE OF THE
C                                'BERNOULLI PROBABILITY' PARAMETER FOR
C                                THE BINOMIAL DISTRIBUTION.  PPAR SHOULD
C                                BE BETWEEN 0.0 (EXCLUSIVELY) AND
C                                1.0 (EXCLUSIVELY).
C                     --N      = THE INTEGER VALUE OF THE 'NUMBER OF
C                                BERNOULLI TRIALS' PARAMETER.  N SHOULD
C                                BE A POSITIVE INTEGER.
C     OUTPUT ARGUMENTS--PPF    = THE DOUBLE PRECISION PERCENT
C                                POINT FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION PERCENT POINT FUNCTION VALUE PPF
C             FOR THE BINOMIAL DISTRIBUTION WITH 'BERNOULLI PROBABILITY'
C             PARAMETER = PPAR AND 'NUMBER OF BERNOULLI TRIALS'
C             PARAMETER = N.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--PPAR SHOULD BE BETWEEN 0.0 (INCLUSIVELY) AND 1.0
C                  (EXCLUSIVELY).
C                 --N SHOULD BE A POSITIVE INTEGER.
C                 --P SHOULD BE BETWEEN 0.0 (INCLUSIVELY) AND 1.0
C                   (INCLUSIVELY).
C     OTHER DATAPAC   SUBROUTINES NEEDED--NORPPF, BINCDF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--SQRT.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
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                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--82/7
C     ORIGINAL VERSION--NOVEMBER  1975.
C     UPDATED         --OCTOBER   1978.
C     UPDATED         --DECEMBER  1981.
C     UPDATED         --MAY       1982.
C     UPDATED         --MARCH     2009. MAKE DOUBLE PRECISION
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      PPF=0.0D0
      IF(P.LT.0.0D0 .OR. P.GT.1.0D0)THEN
        WRITE(ICOUT,1)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)P
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(PPAR.LT.0.0D0 .OR. PPAR.GT.1.0D0)THEN
        WRITE(ICOUT,11)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)PPAR
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(N.LT.1)THEN
        WRITE(ICOUT,25)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
    1 FORMAT('***** ERROR--THE FIRST ARGUMENT TO BINPPF IS OUTSIDE ',
     1       'THE ALLOWABLE (0,1) INTERVAL')
   11 FORMAT('***** ERROR--THE SECOND ARGUMENT TO BINPPF IS OUTSIDE ',
     1       'THE ALLOWABLE (0,1) INTERVAL')
   25 FORMAT('***** ERROR--THE THIRD ARGUMENT TO BINPPF IS ',
     1       'NON-POSITIVE')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8)
C
      DN=DBLE(N)
      DPPAR=PPAR
      IX0=0
      IX1=0
      IX2=0
      P0=0.0D0
      P1=0.0D0
      P2=0.0D0
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.0D0)THEN
        PPF=0.0D0
        GOTO9000
      ELSEIF(P.EQ.1.0D0)THEN
        PPF=DBLE(N)
        GOTO9000
      ELSEIF(P.EQ.0.5D0 .AND. PPAR.EQ.0.5D0)THEN
        IPPF=N/2
        PPF=DBLE(IPPF)
        GOTO9000
      ENDIF
C
      PF0=(1.0D0-DPPAR)**N
      QFN=1.0D0-(DPPAR**N)
      IF(P.LE.PF0)THEN
        PPF=0.0D0
        GOTO9000
      ELSEIF(P.GT.QFN)THEN
        PPF=DBLE(N)
        GOTO9000
      ENDIF
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=DN*DPPAR
      SD=SQRT(DN*DPPAR*(1.0D0-DPPAR))
      CALL NODPPF(P,ZPPF)
      X2=AMEAN-0.5D0+ZPPF*SD
      IX2=INT(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=INT(SD+1.0D0)
      X2=REAL(IX2)
      CALL BINCDF(X2,DPPAR,N,P2)
C
      IF(P2.LT.P)THEN
        IX0=IX2
        I=0
  215   CONTINUE
        I=I+1
        IF(I.GT.1000000)THEN
          WRITE(ICOUT,249)
  249     FORMAT('***** INTERNAL ERROR IN BINPPF SUBROUTINE *****')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,222)
  222     FORMAT('      NO UPPER BOUND FOUND AFTER 10**7 ITERATIONS')
          CALL DPWRST('XXX','BUG ')
          GOTO950
        ENDIF
        IX2=IX0+ISD
        IF(IX2.GE.IX1)GOTO275
        X2=IX2
        CALL BINCDF(X2,DPPAR,N,P2)
        IF(P2.GE.P)THEN
          IX1=IX2
          GOTO275
        ENDIF
        IX0=IX2
        GOTO215
C
      ELSE
C
        IX1=IX2
        I=0
  255   CONTINUE
        I=I+1
        IF(I.GT.1000000)THEN
          WRITE(ICOUT,249)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,262)
  262     FORMAT('      NO LOWER BOUND FOUND AFTER 10**7 ITERATIONS')
          CALL DPWRST('XXX','BUG ')
          GOTO950
        ENDIF
        IX2=IX1-ISD
        IF(IX2.LE.IX0)GOTO275
        X2=IX2
        CALL BINCDF(X2,PPAR,N,P2)
        IF(P2.LT.P)THEN
          IX0=IX2
        ELSE
          IX1=IX2
          GOTO255
        ENDIF
      ENDIF
C
  275 CONTINUE
      IF(IX0.EQ.IX1)THEN
        IF(IX0.EQ.0)THEN
          IX1=IX1+1
        ELSEIF(IX0.EQ.N)THEN
          IX0=IX0-1
        ELSE
          WRITE(ICOUT,249)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,282)
  282     FORMAT('      LOWER AND UPPER BOUND IDENTICAL')
          CALL DPWRST('XXX','BUG ')
          GOTO950
        ENDIF
      ENDIF
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)THEN
        GOTO490
      ELSEIF(P0.EQ.P)THEN
        PPF=DBLE(IX0)
        GOTO9000
      ELSEIF(P1.EQ.P)THEN
        PPF=DBLE(IX1)
        GOTO9000
      ELSEIF(P0.GT.P1)THEN
        WRITE(ICOUT,249)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,431)
  431   FORMAT('      LOWER BOUND PROBABILITY (P0) GREATER THAN ',
     1         'UPPER BOUND PROBABILITY (P1)')
        CALL DPWRST('XXX','BUG ')
        GOTO950
      ELSEIF(P0.GT.P)THEN
        WRITE(ICOUT,249)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,441)
  441   FORMAT('      LOWER BOUND PROBABILITY (P0) GREATER THAN ',
     1         'INPUT PROBABILITY (P)')
        CALL DPWRST('XXX','BUG ')
        GOTO950
      ELSEIF(P1.LT.P)THEN
        WRITE(ICOUT,249)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,451)
  451   FORMAT('      UPPER BOUND PROBABILITY (P1) LESS    THAN ',
     1         'INPUT PROBABILITY (P)')
        CALL DPWRST('XXX','BUG ')
        GOTO950
      ELSE
        WRITE(ICOUT,249)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,401)
  401   FORMAT('IMPOSSIBLE BRANCH CONDITION ENCOUNTERED')
        CALL DPWRST('XXX','BUG ')
        GOTO950
      ENDIF
  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 CONTINUE
C
      IX0P1=IX0+1
      IF(IX1.EQ.IX0P1)THEN
        PPF=IX1
        IF(P0.EQ.P)PPF=IX0
        GOTO9000
      ENDIF
      IX2=(IX0+IX1)/2
      IF(IX2.EQ.IX0)THEN
        WRITE(ICOUT,249)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,611)
  611   FORMAT('BISECTION VALUE (X2) = LOWER BOUND (X0)')
        CALL DPWRST('XXX','BUG ')
        GOTO950
      ELSEIF(IX2.EQ.IX1)THEN
        WRITE(ICOUT,249)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,621)
  621   FORMAT('BISECTION VALUE (X2) = UPPER BOUND (X1)')
        CALL DPWRST('XXX','BUG ')
        GOTO950
      ENDIF
      X2=IX2
      CALL BINCDF(X2,PPAR,N,P2)
      IF(P0.LT.P2.AND.P2.LT.P1)THEN
        IF(P2.LE.P)THEN
          IX0=IX2
          P0=P2
        ELSE
          IX1=IX2
          P1=P2
        ENDIF
        GOTO300
      ELSEIF(P2.LE.P0)THEN
        WRITE(ICOUT,249)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,641)
  641   FORMAT('BISECTION VALUE PROBABILITY (P2) ',
     1         'LESS THAN LOWER BOUND PROBABILITY (P0)')
        CALL DPWRST('XXX','BUG ')
        GOTO950
      ELSEIF(P2.GE.P1)THEN
        WRITE(ICOUT,249)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,651)
  651   FORMAT('BISECTION VALUE PROBABILITY (P2) ',
     1         'GREATER THAN UPPER BOUND PROBABILITY (P1)')
        CALL DPWRST('XXX','BUG ')
        GOTO950
      ENDIF
C
  950 CONTINUE
      WRITE(ICOUT,240)IX0,P0
  240 FORMAT('IX0  = ',I8,10X,'P0 = ',F14.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,241)IX1,P1
  241 FORMAT('IX1  = ',I8,10X,'P1 = ',F14.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,242)IX2,P2
  242 FORMAT('IX2  = ',I8,10X,'P2 = ',F14.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,244)P
  244 FORMAT('P    = ',F14.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,245)PPAR,N
  245 FORMAT('PPAR = ',F14.7,10X,'N  = ',I8)
      CALL DPWRST('XXX','BUG ')
      GOTO9000
C
 9000 CONTINUE
      RETURN
      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 INSTITUTE OF STANDARDS AND TECHNOLOGY 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                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1966)
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
      INCLUDE 'DPCOP2.INC'
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 CONTINUE
      DO500I=1,N
        ISUM=0
        J=1
  550   CALL GEORAN(1,P,ISEED,G)
        IG=INT(G(1)+0.5)
        ISUM=ISUM+IG+1
        IF(ISUM.GT.NPAR)GOTO650
        J=J+1
        GOTO550
  650   CONTINUE
        X(I)=INT(J-1)
  500 CONTINUE
      RETURN
C
      END
      SUBROUTINE BINRAW(DX,DP,DQ,DN,DPDF,ILOG)
C
C     PURPOSE--THIS SUBROUTINE IMPLEMENTS CATHERINE LOADER'S
C              ALGORITHM FOR THE BINOMIAL PDF.  THIS ROUTINE IS
C              CALLED BY SEVERAL OTHER ROUTINES (BINPDF, GEOPDF,
C              NBPDF).  THE ERROR CHECKING AND CHECKING FOR
C              APPROPRIATE RANGES IS PERFORMED BY THESE HIGHER LEVEL
C              CALLS.
C
C              THIS ALGORITHM IS BASED ON A SADDLE POINT APPROXIMATION.
C
C              THIS ROUTINE ALLOWS THE OPTION OF RETURNING THE
C              LOGARITHM OF THE PDF.
C
C     INPUT  ARGUMENTS--DX     = THE DOUBLE PRECISION VALUE AT WHICH THE
C                                BINOMIAL PDF IS TO BE EVALUATED.
C                     --DP     = THE DOUBLE PRECISION VALUE OF THE
C                                'BERNOULLI PROBABILITY' PARAMETER FOR
C                                THE BINOMIAL DISTRIBUTION.
C                     --DN     = THE DOUBLE PRECISION VALUE OF THE
C                                'NUMBER OF BERNOULLI TRIALS' PARAMETER.
C     OUTPUT ARGUMENTS--DPDF   = THE DOUBLE PRECISION PROBABILITY MASS
C                                FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION PROBABILITY MASS FUNCTION VALUE DPDF.
C     PRINTING--NONE
C     RESTRICTIONS--DX SHOULD BE INTEGRAL-VALUED AND BETWEEN 0.0 (INCLUSIVELY)
C                   AND DN (INCLUSIVELY).
C                 --DP SHOULD BE BETWEEN 0.0 (EXCLUSIVELY) AND 1.0
C                   (INCLUSIVELY).
C                 --DN SHOULD BE A POSITIVE.
C
C                   NOTE THAT THE CHECK FOR RESTRICTIONS IS TO BE
C                   PERFORMED BY THE CALLING ROUTINES.
C
C     OTHER DATAPAC   SUBROUTINES NEEDED--STRERR, BD0, DLNREL.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--LOG, EXP.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--CATHERINE LOADER (2000), "FAST AND ACCURATE COMPUTATION
C                 OF BINOMIAL PROBABILITIES", BELL LABS?
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-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2009/3
C     ORIGINAL VERSION--MARCH     2009.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      DOUBLE PRECISION LF
      DOUBLE PRECISION LC
      INTEGER ILOG
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----DATA STATEMENTS-------------------------------------------------
C
      DATA DPI2/6.283185307179586476925286/
C
C-----START POINT-----------------------------------------------------
C
C     STEP 1: P = 0 OR P = 1 CASES
C
      IF(DP.EQ.0.0D0)THEN
        IF(DX.EQ.0.0D0)THEN
          DPF=1.0D0
          IF(ILOG.EQ.1)DPDF=0.0D0
        ELSE
          DPF=0.0D0
          IF(ILOG.EQ.1)DPDF=DBLE(CPUMIN)
        ENDIF
        GOTO9000
      ELSEIF(DQ.EQ.0.0D0)THEN
        IF(DX.EQ.DN)THEN
          DPF=1.0D0
          IF(ILOG.EQ.1)DPDF=0.0D0
        ELSE
          DPF=0.0D0
          IF(ILOG.EQ.1)DPDF=DBLE(CPUMIN)
        ENDIF
        GOTO9000
      ENDIF
C
C     STEP 2: X = 0 AND X = N CASES
C
      IF(DX.EQ.0.0D0)THEN
        IF(DN.EQ.0.0D0)THEN
          DPF=1.0D0
          IF(ILOG.EQ.1)DPDF=0.0D0
        ELSE
          IF(DP.LT.0.1D0)THEN
            LC=-BD0(DN,DN*DQ) - DN*DP
          ELSE
            LC=DN*LOG(DQ)
          ENDIF
          IF(ILOG.EQ.1)THEN
            DPDF=LC
          ELSE
            DPDF=EXP(LC)
          ENDIF
        ENDIF
        GOTO9000
      ELSEIF(DX.EQ.DN)THEN
        IF(DQ.LT.0.1D0)THEN
          LC=-BD0(DN,DN*DP) - DN*DQ
        ELSE
          LC=DN*LOG(DP)
        ENDIF
        IF(ILOG.EQ.1)THEN
          DPDF=LC
        ELSE
          DPDF=EXP(LC)
        ENDIF
        GOTO9000
      ENDIF
C
      IF(DX.LT.0.0D0 .OR. DX.GT.DN)THEN
        IF(ILOG.EQ.1)THEN
          DPDF=DBLE(CPUMIN)
        ELSE
          DPDF=0.0D0
        ENDIF
      ENDIF
C
C     STEP 3: GENERAL CASE
C
      LC=STRERR(DN) - STRERR(DX) - STRERR(DN-DX) - BD0(DX,DN*DP) -
     1   BD0(DN-DX,DN*DQ)
      LF=LOG(DPI2) + LOG(DX) + DLNREL(-DX/DN)
      IF(ILOG.EQ.1)THEN
        DPDF=LC - 0.5D0*LF
       ELSE
        DPDF=EXP(LC - 0.5D0*LF)
      ENDIF
C
 9000 CONTINUE
      RETURN
      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
      INCLUDE 'DPCOP2.INC'
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'
      INCLUDE 'DPCOP2.INC'
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      CONTINUE
      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,
     1                 YTEMP,XTEMP,YDIST,XDIST,ZDIST,
     1                 ZTEMP2,ZTEMP,TX,TY,WORK,ISPACE,
     1                 IBUGG3,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--ALAN HECKERT
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     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--94/5
C     ORIGINAL VERSION--MAY       1994.
C     UPDATED         --JUNE      2019. DIMENSION SCRATCH ARRAYS IN
C                                       CALLING ROUTINE
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(*)
      DIMENSION YTEMP(*)
      DIMENSION XTEMP(*)
      DIMENSION YDIST(*)
      DIMENSION XDIST(*)
      DIMENSION ZDIST(*)
      DIMENSION ZTEMP2(*)
      DIMENSION ZTEMP(*)
      DIMENSION TX(*)
      DIMENSION TY(*)
      DIMENSION WORK(ISPACE)
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
      INCLUDE 'DPCOHK.INC'
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='BIVA'
      ISUBN2='R   '
      IERROR='NO'
C
      ISTART=0
      ILAST=0
C
      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'IVAR')THEN
        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,N2,ISPACE
   52   FORMAT('N,N2,ISPACE = ',3I8)
        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,3G15.7)
          CALL DPWRST('XXX','BUG ')
   55   CONTINUE
        DO65I=1,N2
          WRITE(ICOUT,66)I,Y2(I),X2(I)
   66     FORMAT('I,Y2(I),X2(I) = ',I8,2G15.7)
          CALL DPWRST('XXX','BUG ')
   65   CONTINUE
      ENDIF
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.GT.0)THEN
          DO1215I2=1,NDISTX
           IF(X(I).EQ.XDIST(I2))GOTO1210
 1215     CONTINUE
        ENDIF
        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.GT.0)THEN
          DO1315I2=1,NDISTY
            IF(Y(I).EQ.YDIST(I2))GOTO1310
 1315     CONTINUE
        ENDIF
        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
      IXDEG=4
      IYDEG=4
C
      XDEG=3.0
      IHP='XDEG'
      IHP2='REE '
      IHWUSE='P'
      MESSAG='NO'
      CALL CHECKN(IHP,IHP2,IHWUSE,
     1            IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
     1            ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR)
      IF(IERROR.EQ.'YES')GOTO1510
      XDEG=VALUE(ILOCP)
 1510 CONTINUE
C
      IXDEG=INT(XDEG+0.5)
      IF(IXDEG.LT.1.OR.IXDEG.GT.3)THEN
        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
      ENDIF
      IXDEG=IXDEG+1
C
      YDEG=3.0
      IHP='YDEG'
      IHP2='REE '
      IHWUSE='P'
      MESSAG='NO'
      CALL CHECKN(IHP,IHP2,IHWUSE,
     1            IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
     1            ISUBN1,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,1511)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1512)
      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 ',G15.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,
     1            IXDEG,IYDEG,
     1            TX,TY,WORK,ISPACE,
     1            IBUGG3,ISUBRO,IERROR)
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'IVAR')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9011)
 9011   FORMAT('***** AT THE END       OF BIVAR--')
        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,3G15.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,3G15.7)
            CALL DPWRST('XXX','BUG ')
 9054     CONTINUE
 9052   CONTINUE
      ENDIF
C
      RETURN
      END
      SUBROUTINE BIVAR2(Z,Y,X,NX,NY,Y2,X2,N2,Z2,
     1                  IXDEG,IYDEG,
     1                  TX,TY,WORK,ISPACE,
     1                  IBUGG3,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--ALAN HECKERT
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     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
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='BIVA'
      ISUBN2='R2  '
      IERROR='NO'
C
      DO10I=1,N2
        Z2(I)=0.0
 10   CONTINUE
C
      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'VAR2')THEN
        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,N2
   52   FORMAT('NX,NY,N2 = ',3I8)
        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
        DO65I=1,N2
          WRITE(ICOUT,66)I,Y2(I),X2(I)
   66     FORMAT('I,Y2(I),X2(I) = ',I8,2G15.7)
          CALL DPWRST('XXX','BUG ')
   65   CONTINUE
      ENDIF
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,
     1           WORK,ISPACE,IFLAG)
      IF(IFLAG.GT.1)THEN
        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
      ENDIF
C
      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'VAR2')THEN
        DO3191J=1,NX+IXDEG
          WRITE(ICOUT,3192)J,TX(J)
          CALL DPWRST('XXX','BUG ')
 3192     FORMAT('J,TX(J) = ',I5,1X,G15.7)
 3191   CONTINUE
        DO3193J=1,NY+IYDEG
          WRITE(ICOUT,3194)J,TY(J)
          CALL DPWRST('XXX','BUG ')
 3194     FORMAT('J,TY(J) = ',I5,1X,G15.7)
 3193   CONTINUE
      ENDIF
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.'ON'.OR.ISUBRO.NE.'VAR2')THEN
        DO4100J=1,N2
          WRITE(ICOUT,4110)X2(J),Y2(J),Z2(J)
          CALL DPWRST('XXX','BUG ')
 4110     FORMAT('X2(J),Y2(J),Z2(J) = ',3G15.7)
 4100   CONTINUE
      ENDIF
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'VAR2')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9011)
 9011   FORMAT('***** AT THE END       OF BIVAR2--')
        CALL DPWRST('XXX','BUG ')
      ENDIF
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                 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     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2002/7
C     ORIGINAL VERSION--JULY      2002.
C     UPDATED         --JULY      2010. CALL LIST TO MAD
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
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='BIWM'
      ISUBN2='CV  '
      XBWCOV=0.0
C
      IERROR='NO'
C
      IF(IBUGA3.EQ.'ON')THEN
        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,N
   52   FORMAT('IBUGA3,N = ',A4,2X,I8)
        CALL DPWRST('XXX','BUG ')
        DO55I=1,N
          WRITE(ICOUT,56)I,X(I)
   56     FORMAT('I,X(I) = ',I8,G15.7)
          CALL DPWRST('XXX','BUG ')
   55   CONTINUE
      ENDIF
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.LT.1)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,111)
  111   FORMAT('***** ERROR IN BIWEIGHT MID-COVARIANCE--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,112)
  112   FORMAT('      THE RESPONSE VARIABLE HAS LESS THAN ONE ',
     1         'OBSERVATION.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,117)N
  117   FORMAT('      THE INPUT NUMBER OF OBSERVATIONS = ',I8,'.')
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        GOTO9000
      ENDIF
C
      HOLD=X(1)
      DO135I=2,N
      IF(X(I).NE.HOLD)GOTO139
  135 CONTINUE
      XBWCOV=0.0
      GOTO8000
  139 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)
      CALL MAD(X,N,IWRIT2,XTEMP,XTEMP2,MAXNXT,XMAD,IBUGA3,IERROR)
C
      CALL MEDIAN(Y,N,IWRIT2,XTEMP,MAXNXT,YMED,IBUGA3,IERROR)
      CALL MAD(Y,N,IWRIT2,XTEMP,XTEMP2,MAXNXT,YMAD,IBUGA3,IERROR)
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
 8000 CONTINUE
      IF(IFEEDB.EQ.'ON' .AND. IWRITE.EQ.'ON')THEN
        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 ')
      ENDIF
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'ON')THEN
        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,N
 9012   FORMAT('IBUGA3,IERROR,N = ',A4,2X,A4,2X,I8)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9015)XMED,XMAD,YMED,YMAD,XBWCOV
 9015   FORMAT('XMED,XMAD,YMED,YMAD,XBWCOV = ',5G15.7)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      RETURN
      END
      SUBROUTINE BIWEIG(RES,N,IWRITE,WEIGHT,IBUGA3,IERROR)
C
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                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
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
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='BIWE'
      ISUBN2='IG  '
      IERROR='NO'
C
      IF(IBUGA3.EQ.'ON')THEN
        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,IWRITE,N
   52   FORMAT('IBUGA3,IERROR,IWRITE,N = ',3(A4,2X),I8)
        CALL DPWRST('XXX','BUG ')
        IF(N.GE.1)THEN
          DO61I=1,N
            WRITE(ICOUT,62)I,RES(I)
   62       FORMAT('I,RES(I) = ',I8,G15.7)
            CALL DPWRST('XXX','BUG ')
   61     CONTINUE
        ENDIF
      ENDIF
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      IF(N.LT.1)THEN
        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, FOR WHICH BIWEIGHT')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,114)
  114   FORMAT('      WEIGHTS 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
      ENDIF
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)THEN
        CONST=(-999.0)
        DO1111I=1,N
          WEIGHT(I)=1.0
 1111   CONTINUE
        SUM=REAL(N)
      ELSE
        CONST=6.0*XMEDAR
        SUM=0.0
        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
          SUM=SUM + WEIGHT(I)
 1121   CONTINUE
      ENDIF
C
      IF(SUM.LE.0.0)THEN
        DO1131I=1,N
          WEIGHT(I)=1.0
 1131   CONTINUE
      ENDIF
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'ON')THEN
        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,N,XMEDAR
 9012   FORMAT('IBUGA3,IERROR,N,XMEDAR = ',2(A4,2X),I8,G15.7)
        CALL DPWRST('XXX','BUG ')
        IF(N.GE.1)THEN
          DO9021I=1,N
            WRITE(ICOUT,9022)I,RES(I),WEIGHT(I)
 9022       FORMAT('I,RES(I),WEIGHT(I) = ',I8,2G15.7)
            CALL DPWRST('XXX','BUG ')
 9021     CONTINUE
        ENDIF
      ENDIF
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                 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     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2002/7
C     ORIGINAL VERSION--JULY      2002.
C     UPDATED         --JULY      2010. CALL LIST TO MAD
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 DSUM1
      DOUBLE PRECISION DSUM2
      DOUBLE PRECISION DUI
      DOUBLE PRECISION DSBI
C
      DIMENSION X(*)
      DIMENSION XTEMP(*)
      DIMENSION XTEMP2(*)
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='BIWM'
      ISUBN2='DV  '
      XBWMDV=0.0
C
      IERROR='NO'
C
      IF(IBUGA3.EQ.'ON')THEN
        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,N
   52   FORMAT('IBUGA3,N = ',A4,2X,I8)
        CALL DPWRST('XXX','BUG ')
        DO55I=1,N
          WRITE(ICOUT,56)I,X(I)
   56     FORMAT('I,X(I) = ',I8,G15.7)
          CALL DPWRST('XXX','BUG ')
   55   CONTINUE
      ENDIF
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.LT.1)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,111)
  111   FORMAT('***** ERROR IN BIWEIGHT MID-VARIANCE--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,112)
  112   FORMAT('      THE RESPONSE VARIABLE HAS LESS THAN ONE ',
     1         'OBSERVATION.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,117)N
  117   FORMAT('      THE INPUT NUMBER OF OBSERVATIONS = ',I8,'.')
        CALL DPWRST('XXX','BUG ')
        XBWMDV=CPUMIN
        IERROR='YES'
        GOTO9000
      ENDIF
C
      HOLD=X(1)
      DO135I=2,N
      IF(X(I).NE.HOLD)GOTO139
  135 CONTINUE
      XBWMDV=0.0
      GOTO8000
  139 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)
      CALL MAD(X,N,IWRIT2,XTEMP,XTEMP2,MAXNXT,XMAD,IBUGA3,IERROR)
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
 8000 CONTINUE
      IF(IFEEDB.EQ.'ON' .AND. IWRITE.EQ.'ON')THEN
        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 ')
      ENDIF
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'ON')THEN
        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,N,XBWMDV
 9012   FORMAT('IBUGA3,IERROR,N,XBWMDV = ',A4,2X,A4,2X,I8,G15.7)
        CALL DPWRST('XXX','BUG ')
      ENDIF
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                 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     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
      INCLUDE 'DPCOP2.INC'
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
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                 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     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2001/11
C     ORIGINAL VERSION--NOVEMBER  2001.
C     UPDATED         --JULY      2010. CALL LIST TO MAD
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 DSUM1
      DOUBLE PRECISION DSUM2
      DOUBLE PRECISION DUI
      DOUBLE PRECISION DSBI
C
      DIMENSION X(*)
      DIMENSION XTEMP(*)
      DIMENSION XTEMP2(*)
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='BIWL'
      ISUBN2='OC  '
      XBS=0.0
C
      IERROR='NO'
C
      IF(IBUGA3.EQ.'ON')THEN
        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,N
   52   FORMAT('IBUGA3,N = ',A4,2X,I8)
        CALL DPWRST('XXX','BUG ')
        DO55I=1,N
          WRITE(ICOUT,56)I,X(I)
   56     FORMAT('I,X(I) = ',I8,G15.7)
          CALL DPWRST('XXX','BUG ')
   55   CONTINUE
      ENDIF
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.LT.1)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,111)
  111   FORMAT('***** ERROR IN BIWEIGHT SCALE--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,112)
  112   FORMAT('      THE RESPONSE VARIABLE HAS LESS THAN ONE ',
     1         'OBSERVATION.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,117)N
  117   FORMAT('      THE INPUT NUMBER OF OBSERVATIONS = ',I8,'.')
        CALL DPWRST('XXX','BUG ')
        XBS=CPUMIN
        IERROR='YES'
        GOTO9000
      ENDIF
C
      HOLD=X(1)
      DO135I=2,N
      IF(X(I).NE.HOLD)GOTO139
  135 CONTINUE
      XBS=0.0
      GOTO8000
  139 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)
      CALL MAD(X,N,IWRIT2,XTEMP,XTEMP2,MAXNXT,XMAD,IBUGA3,IERROR)
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
 8000 CONTINUE
      IF(IFEEDB.EQ.'ON' .AND. IWRITE.EQ.'ON')THEN
        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 ')
      ENDIF
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'ON')THEN
        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,N,XBS
 9012   FORMAT('IBUGA3,IERROR,N,XBS = ',A4,2X,A4,2X,I8,G15.7)
        CALL DPWRST('XXX','BUG ')
      ENDIF
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
CCCCC IF (NROWM1) 120, 110, 10
      IF (NROWM1.LT.0) THEN
         GOTO120
      ELSEIF (NROWM1.EQ.0) THEN
         GOTO110
      ELSEIF (NROWM1.GT.0) THEN
         GOTO10
      ENDIF
   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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
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
      INCLUDE 'DPCOP2.INC'
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
      SUBROUTINE BNOFUN (N, X, FVEC, IFLAG, XDATA, NOBS)
C
C     PURPOSE--THIS ROUTINE COMPUTES THE FUNCTIONS FOR THE
C              BETA-NORMAL MAXIMUM LIKELIHOOD EQUATIONS
C              TO ESTIMATE THE ALPHA AND BETA SHAPE PARAMETERS
C              AND THE LOCATION/SCALE PARAMETERS.  THE MAXIMUM
C              LIKELIHOOD EQUATIONS ARE:
C
C                 N*PSI(ALPHA+BETA) - N*PSI(ALPHA) +
C                 SUM[i=1 to N][LOG(NORCDF((X(i)-MU)/SIGMA))] = 0
C
C                 N*PSI(ALPHA+BETA) - N*PSI(BETA) +
C                 SUM[i=1 to N][LOG(1-NORCDF((X(i)-MU)/SIGMA))] = 0
C
C                 SUM[i=1 to n][{
C                 (1-ALPHA)*NORPDF((X(i)-MU)/SIGMA)/
C                 NORCDF((X(i)-MU)/SIGMA) +
C                 (BETA-1)*NORPDF((X(i)-MU)/SIGMA)/
C                 (1 - NORCDF((X(i)-MU)/SIGMA)) +
C                 (X(i)-MU)/SIGMA**2)} = 0
C
C                 SUM[i=1 to n][{
C                 (1-ALPHA)*NORPDF((X(i)-MU)/SIGMA)*(X(i)-MU)/SIGMA)/
C                 NORCDF((X(i)-MU)/SIGMA) +
C                 (BETA-1)*NORPDF((X(i)-MU)/SIGMA)*(X(i)-MU)/SIGMA)/
C                 (1 - NORCDF((X(i)-MU)/SIGMA)) +
C                 (X(i)-MU)**2/SIGMA**3)} - (N/SIGMA)= 0
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 NORMAL MAXIMUM LIKELIHOOD Y
C     REFERENCE--EUGENE, LEE, AND FAMOYE (2002), "BETA-NORMAL
C                DISTRIBUTION AND ITS APPLICATIONS", COMMUNICATIONS
C                IN STATISTICS--THEORY AND METHODS, 31(4),
C                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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2007/6
C     ORIGINAL VERSION--JUNE      2007.
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION X(*)
      DOUBLE PRECISION FVEC(*)
      REAL XDATA(*)
C
      DOUBLE PRECISION DA
      DOUBLE PRECISION DB
      DOUBLE PRECISION DMU
      DOUBLE PRECISION DSIGMA
      DOUBLE PRECISION DX
      DOUBLE PRECISION DZ
      DOUBLE PRECISION DN
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
      DOUBLE PRECISION DTERM4
CCCCC DOUBLE PRECISION DTERM5
CCCCC DOUBLE PRECISION DTERM6
CCCCC DOUBLE PRECISION DTERM7
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DSUM2
      DOUBLE PRECISION DSUM3
      DOUBLE PRECISION DEPS
C
      DOUBLE PRECISION DPSI
      EXTERNAL DPSI
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      N=4
      IFLAG=0
C
      DA=X(1)
      DB=X(2)
      DMU=X(3)
      DSIGMA=X(4)
C
      DN=DBLE(NOBS)
      DTERM1=DN*DPSI(DA+DB)
      DTERM2=DN*DPSI(DA)
      DTERM3=DN*DPSI(DB)
      DEPS=1.0D-20
C
      DSUM1=0.0D0
      DSUM2=0.0D0
      DO100I=1,NOBS
        DX=DBLE(XDATA(I))
        DZ=(DX - DMU)/DSIGMA
        CALL NODCDF(DZ,DTERM4)
        IF(DTERM4.LE.0.0D0)DTERM4=DEPS
        DSUM1=DSUM1 + DLOG(DTERM4)
        CALL NODCDF(DZ,DTERM4)
        DTERM4=1.0D0 - DTERM4
        IF(DTERM4.LE.0.0D0)DTERM4=DEPS
        DSUM2=DSUM2 + DLOG(DTERM4)
  100 CONTINUE
C
      FVEC(1)=DTERM1 - DTERM2 + DSUM1
      FVEC(2)=DTERM1 - DTERM3 + DSUM2
C
      DSUM1=0.0D0
      DSUM2=0.0D0
      DSUM3=0.0D0
      DO200I=1,NOBS
        DX=DBLE(XDATA(I))
        DZ=(DX - DMU)/DSIGMA
        CALL NODPDF(DZ,DTERM1)
        CALL NODCDF(DZ,DTERM2)
        DTERM3=(1.0D0 - DA)*DTERM1
        IF(DTERM2.NE.0.0D0)THEN
          DSUM1=DSUM1 + DTERM3/DTERM2
        ELSE
          DSUM1=DSUM1 + DTERM3/DEPS
        ENDIF
        DTERM3=(DB - 1.0D0)*DTERM1
        DTERM4=1.0D0 - DTERM2
        IF(DTERM4.NE.0.0D0)THEN
          DSUM2=DSUM2 + DTERM3/DTERM4
        ELSE
          DSUM2=DSUM2 + DTERM3/DEPS
        ENDIF
        DSUM3=DSUM3 + DZ/DSIGMA
  200 CONTINUE
      FVEC(3)=DSUM1 + DSUM2 + DSUM3
C
      DSUM1=0.0D0
      DSUM2=0.0D0
      DSUM3=0.0D0
      DO300I=1,NOBS
        DX=DBLE(XDATA(I))
        DZ=(DX - DMU)/DSIGMA
        CALL NODPDF(DZ,DTERM1)
        CALL NODCDF(DZ,DTERM2)
        DTERM3=(1.0D0 - DA)*DTERM1
        IF(DTERM2.NE.0.0D0)THEN
          DSUM1=DSUM1 + (DTERM3/DTERM2)*DZ
        ELSE
          DSUM1=DSUM1 + (DTERM3/DEPS)*DZ
        ENDIF
        DTERM3=(DB - 1.0D0)*DTERM1
        DTERM4=1.0D0 - DTERM2
        IF(DTERM4.NE.0.0D0)THEN
          DSUM2=DSUM2 + (DTERM3/DTERM4)*DZ
        ELSE
          DSUM2=DSUM2 + (DTERM3/DEPS)*DZ
        ENDIF
        DSUM3=DSUM3 + (DX-DMU)**2/(DSIGMA**3)
  300 CONTINUE
      FVEC(4)=DSUM1 + DSUM2 + DSUM3 - DN/DSIGMA
C
      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     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
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      CALL BNOCDF(DX,DALPHA,DBETA,DCDF)
      BNOFU2=DP - DCDF
C
      RETURN
      END
      SUBROUTINE BNOML1(Y,N,MAXNXT,DTEMP1,
     1                  XMEAN,XSD,XVAR,XMIN,XMAX,
     1                  AMUSV,SIGMSV,ALPHSV,BETASV,
     1                  AMUML,SIGMML,ALPHML,BETAML,
     1                  ISUBRO,IBUGA3,IERROR)
C
C     PURPOSE--THIS ROUTINE COMPUTES THE MAXIMUM LIKELIHOOD
C              ESTIMATES FOR THE BETA NORMAL DISTRIBUTION.
C     NOTE--THE MAXIMUM LIKELIHOOD ESTIMATES ARE THE SOLUTION
C           TO THE FOLLOWING SYSTEM OF EQUATIONS:
C
C                 N*PSI(ALPHA+BETA) - N*PSI(ALPHA) +
C                 SUM[i=1 to N][LOG(NORCDF((X(i)-MU)/SIGMA))] = 0
C
C                 N*PSI(ALPHA+BETA) - N*PSI(BETA) +
C                 SUM[i=1 to N][LOG(1-NORCDF((X(i)-MU)/SIGMA))] = 0
C
C                 SUM[i=1 to n][{
C                 (1-ALPHA)*NORPDF((X(i)-MU)/SIGMA)/
C                 NORCDF((X(i)-MU)/SIGMA) +
C                 (BETA-1)*NORPDF((X(i)-MU)/SIGMA)/
C                 (1 - NORCDF((X(i)-MU)/SIGMA)) +
C                 (X(i)-MU)/SIGMA**2)} = 0
C
C                 SUM[i=1 to n][{
C                 (1-ALPHA)*NORPDF((X(i)-MU)/SIGMA)*(X(i)-MU)/SIGMA)/
C                 NORCDF((X(i)-MU)/SIGMA) +
C                 (BETA-1)*NORPDF((X(i)-MU)/SIGMA)*(X(i)-MU)/SIGMA)/
C                 (1 - NORCDF((X(i)-MU)/SIGMA)) +
C                 (X(i)-MU)**2/SIGMA**3)} - (N/SIGMA)= 0
C
C           NOTE THAT EUGENE AND HIS CO-AUTHORS SUGGEST TWO
C           DIFFERENT STARTING VALUES DEPENDING ON WHETHER
C           THE DISTRIBUTION IS UNIMODAL OR BIMODAL.  THIS CAN
C           BE DETERMINED BY EVALUATING THE LIKELIHOOD EQUATION
C           AT THESE TWO POINTS.
C     REFERENCE--EUGENE, LEE, AND FAMOYE (2002), "BETA-NORMAL
C                DISTRIBUTION AND ITS APPLICATIONS", COMMUNICATIONS
C                IN STATISTICS--THEORY AND METHODS, 31(4),
C                PP. 497-512.
C     WRITTEN BY--ALAN HECKERT
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     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2010/07
C     ORIGINAL VERSION--JULY      2010. EXTRACTED AS A SEPARATE
C                                       SUBROUTINE (FROM DPMLAD)
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DIMENSION Y(*)
      DOUBLE PRECISION DTEMP1(*)
C
      CHARACTER*4 ISUBRO
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      DOUBLE PRECISION TOL
      DOUBLE PRECISION XPAR(4)
      DOUBLE PRECISION FVEC(4)
CCCCC DOUBLE PRECISION DAE
CCCCC DOUBLE PRECISION DRE
CCCCC DOUBLE PRECISION DXSTRT
CCCCC DOUBLE PRECISION DXLOW
CCCCC DOUBLE PRECISION DXUP
C
      DOUBLE PRECISION DA
      DOUBLE PRECISION DB
      DOUBLE PRECISION DN
      DOUBLE PRECISION DX
      DOUBLE PRECISION DZ
      DOUBLE PRECISION DMU
      DOUBLE PRECISION DSIGMA
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
CCCCC DOUBLE PRECISION DTERM3
CCCCC DOUBLE PRECISION DTERM4
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DSUM2
      DOUBLE PRECISION DSUM3
      DOUBLE PRECISION DPI
      DOUBLE PRECISION DLIKE1
      DOUBLE PRECISION DLIKE2
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DLNGAM
      EXTERNAL DLNGAM
      EXTERNAL BNOFUN
C
C
      CHARACTER*4 IWRITE
      CHARACTER*40 IDIST
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 ISTEPN
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
      DATA DPI / 3.14159265358979D+00/
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='BNOM'
      ISUBN2='L1  '
C
      IERROR='NO'
      IWRITE='OFF'
C
      AMUML=CPUMIN
      SIGMML=CPUMIN
      ALPHML=CPUMIN
      BETAML=CPUMIN
C
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'OML1')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,51)
   51   FORMAT('**** AT THE BEGINNING OF BNOML1--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,52)IBUGA3,ISUBRO,N
   52   FORMAT('IBUGA3,ISUBRO,N = ',2(A4,2X),I8)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,54)AMUSV,SIGMSV,ALPHSV,BETASV
   54   FORMAT('AMUSV,SIGMSV,ALPHSV,BETASV =  ',4G15.7)
        CALL DPWRST('XXX','WRIT')
        DO56I=1,MIN(N,100)
          WRITE(ICOUT,57)I,Y(I)
   57     FORMAT('I,Y(I) = ',I8,G15.7)
          CALL DPWRST('XXX','WRIT')
   56   CONTINUE
      ENDIF
C
C               ***************************************
C               **  STEP 2--                         **
C               **  CARRY OUT CALCULATIONS           **
C               **  FOR BETA-NORMAL MLE ESTIMATE     **
C               ***************************************
C
      ISTEPN='2'
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'OML1')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IDIST='BETA-NORMAL'
      IFLAG=0
      CALL SUMRAW(Y,N,IDIST,IFLAG,
     1            XMEAN,XVAR,XSD,XMIN,XMAX,
     1            ISUBRO,IBUGA3,IERROR)
      IF(IERROR.EQ.'YES')GOTO9000
C
      CALL SORT(Y,N,Y)
C
C     DETERMINE WHETHER TO USE STARTING VALUES FOR
C     UNIMODAl OR BI-MODAL CASE BY EVALUATING LIKELIHOOD
C     FUNCTION.
C
C     UNIMODAL STARTING VALUE: (1,1,MU,SIGMA)
C
      DN=DBLE(N)
      DA=1.0D0
      DB=1.0D0
      DMU=DBLE(XMEAN)
      DSIGMA=DBLE(XSD)
      DTERM1=DN*DLNGAM(DA+DB) - DN*DLNGAM(DA) - DN*DLNGAM(DB) -
     1       (DN/2.0D0)*DLOG(2.0*DPI) - DN*DLOG(DSIGMA)
C
      DSUM1=0.0D0
      DSUM2=0.0D0
      DSUM3=0.0D0
      DEPS=1.0D-20
      DO1010I=1,N
        DX=DBLE(Y(I))
        DZ=(DX - DMU)/DSIGMA
        CALL NODCDF(DX,DTERM2)
        IF(DTERM2.LE.0.0D0)DTERM2=DEPS
        DSUM1=DSUM1 + (DA-1.0D0)*DLOG(DTERM2)
        CALL NODCDF(DX,DTERM2)
        DTERM2=1.0D0 - DTERM2
        IF(DTERM2.LE.0.0D0)DTERM2=DEPS
        DSUM2=DSUM2 + (DB-1.0D0)*DLOG(DTERM2)
        DSUM3=DSUM3 + (DX-DMU)**2/(2.0D0*DSIGMA)
 1010 CONTINUE
       DLIKE1=DTERM1 + (DSUM1 + DSUM2 - DSUM3)
C
C     BI-MODAL STARTING VALUE: (0.1,0.1,MU,SIGMA)
C
      DA=0.1D0
      DB=0.1D0
      DTERM1=DN*DLNGAM(DA+DB) - DN*DLNGAM(DA) - DN*DLNGAM(DB) -
     1       (DN/2.0D0)*DLOG(2.0*DPI) - DN*DLOG(DSIGMA)
C
      DSUM1=0.0D0
      DSUM2=0.0D0
      DSUM3=0.0D0
      DEPS=1.0D-20
      DO1020I=1,N
        DX=DBLE(Y(I))
        DZ=(DX - DMU)/DSIGMA
        CALL NODCDF(DX,DTERM2)
        IF(DTERM2.LE.0.0D0)DTERM2=DEPS
        DSUM1=DSUM1 + (DA-1.0D0)*DLOG(DTERM2)
        CALL NODCDF(DX,DTERM2)
        DTERM2=1.0D0 - DTERM2
        IF(DTERM2.LE.0.0D0)DTERM2=DEPS
        DSUM2=DSUM2 + (DB-1.0D0)*DLOG(DTERM2)
        DSUM3=DSUM3 + (DX-DMU)**2/(2.0D0*DSIGMA)
 1020 CONTINUE
       DLIKE2=DTERM1 + (DSUM1 + DSUM2 - DSUM3)
C
      IF(DLIKE1.GE.DLIKE2)THEN
        XPAR(1)=2.0D0
        XPAR(2)=2.0D0
      ELSE
        XPAR(1)=0.1D0
        XPAR(2)=0.1D0
      ENDIF
      XPAR(3)=DMU
      XPAR(4)=DSIGMA
C
      IF(ALPHSV.GT.0.0)XPAR(1)=DBLE(ALPHSV)
      IF(BETASV.GT.0.0)XPAR(2)=DBLE(BETASV)
      IF(AMUSV.GT.CPUMIN)XPAR(3)=DBLE(AMUSV)
      IF(SIGMSV.GT.0.0)XPAR(4)=DBLE(SIGMSV)
C
      IOPT=2
      TOL=1.0D-6
      NVAR=4
      NPRINT=-1
      INFO=0
      LWA=MAXNXT
      CALL DNSQE(BNOFUN,JAC,IOPT,NVAR,XPAR,FVEC,TOL,NPRINT,INFO,
     1           DTEMP1,MAXNXT,Y,N)
C
      ALPHML=REAL(XPAR(1))
      BETAML=REAL(XPAR(2))
      AMUML=REAL(XPAR(3))
      SIGMML=REAL(XPAR(4))
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'OML1')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9011)
 9011   FORMAT('**** AT THE END OF BNOML1--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9013)N,XMEAN,XSD,XMIN,XMAX
 9013   FORMAT('N,XMEAN,XSD,XMIN,XMAX = ',I8,4G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9019)AMUML,SIGMML,ALPHML,BETAML
 9019   FORMAT('AMUML,SIGMML,ALPHML,BETAML =  ',4G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9021)IERROR
 9021   FORMAT('IERROR = ',A4)
        CALL DPWRST('XXX','WRIT')
      ENDIF
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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
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 DEPS
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
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     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
      INCLUDE 'DPCOP2.INC'
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     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
      INCLUDE 'DPCOP2.INC'
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,
     1                  Y3,N3,
     1                  TEMPY1,TEMPY2,
     1                  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                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
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     UPDATED         --JUNE      2019. PASS SCRATCH ARRAYS FROM CALLING
C                                       ROUTINE
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
      DIMENSION Y1(*)
      DIMENSION Y2(*)
      DIMENSION Y3(*)
      DIMENSION TEMPY1(*)
      DIMENSION TEMPY2(*)
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='BOOT'
      ISUBN2='SS  '
C
      IERROR='NO'
C
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'OTSS')THEN
        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,N1
   52   FORMAT('IBUGA3,ISUBRO,IWRITE,N1 = ',3(A4,2X),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
      ENDIF
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)THEN
        IERROR='YES'
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,1151)
 1151   FORMAT('***** ERROR IN BOOTSTRAP SAMPLE (BOOTSS)--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,1152)
 1152   FORMAT('      THE NUMBER OF OBSERVATIONS FOR THE RESPONSE')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,1153)
 1153   FORMAT('      VARIABLE IS LESS THAN ONE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,1157)N1
 1157   FORMAT('      THE NUMBER OF OBSERVATIONS = ',I8,'.')
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      DO1200I=1,N1
        TEMPY1(I)=Y1(I)
        TEMPY2(I)=Y2(I)
 1200 CONTINUE
C
      J=0
      DO1300I=1,N1
        INDEX=INT(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
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'OTSS')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9011)
 9011   FORMAT('***** AT THE END       OF BOOTSS--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9013)IERROR,N3
 9013   FORMAT('IERROR,N3 = ',A4,2X,I8)
        CALL DPWRST('XXX','BUG ')
        IF(N1.GE.1)THEN
          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
        ENDIF
        IF(N3.GT.0)THEN
          DO9031I=1,N3
            WRITE(ICOUT,9032)I,Y3(I)
 9032       FORMAT('I,Y3(I) = ',I8,E13.5)
            CALL DPWRST('XXX','BUG ')
 9031     CONTINUE
        ENDIF
      ENDIF
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
C
      INCLUDE 'DPCOBE.INC'
      INCLUDE 'DPCOP2.INC'
C
      IF(ISUBG4.EQ.'ON')THEN
        WRITE(ICOUT,11)MAXN,MAXM
   11   FORMAT('MAXN,MAXM = ',2I8)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      PI=DACOS(DBLE(-1.0))
      PI2=PI/2.0
      EPS=0.0000001
      empty=0
      YCORD1=0.0D0
      XCORD1=0.0D0
      J=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
      DOUBLE PRECISION FUNCTION bpser(a,b,x,eps)
C-----------------------------------------------------------------------
C     POWER SERIES EXPANSION FOR EVALUATING IX(A,B) WHEN B .LE. 1
C     OR B*X .LE. 0.7.  EPS IS THE TOLERANCE USED.
C-----------------------------------------------------------------------
C     .. Scalar Arguments ..
      DOUBLE PRECISION a,b,eps,x
C     ..
C     .. Local Scalars ..
      DOUBLE PRECISION a0,apb,b0,c,n,sum,t,tol,u,w,z
      INTEGER i,m
C     ..
C     .. External Functions ..
      DOUBLE PRECISION algdiv,betaln,gam1,gamln1
      EXTERNAL algdiv,betaln,gam1,gamln1
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC abs,dble,dlog,dmax1,dmin1,exp
C     ..
C     .. Executable Statements ..
C
      bpser = 0.0D0
      IF (x.EQ.0.0D0) RETURN
C-----------------------------------------------------------------------
C            COMPUTE THE FACTOR X**A/(A*BETA(A,B))
C-----------------------------------------------------------------------
      a0 = dmin1(a,b)
      IF (a0.LT.1.0D0) GO TO 10
      z = a*dlog(x) - betaln(a,b)
      bpser = exp(z)/a
      GO TO 100

   10 b0 = dmax1(a,b)
      IF (b0.GE.8.0D0) GO TO 90
      IF (b0.GT.1.0D0) GO TO 40
C
C            PROCEDURE FOR A0 .LT. 1 AND B0 .LE. 1
C
      bpser = x**a
      IF (bpser.EQ.0.0D0) RETURN
C
      apb = a + b
      IF (apb.GT.1.0D0) GO TO 20
      z = 1.0D0 + gam1(apb)
      GO TO 30

   20 u = dble(a) + dble(b) - 1.D0
      z = (1.0D0+gam1(u))/apb
C
   30 c = (1.0D0+gam1(a))* (1.0D0+gam1(b))/z
      bpser = bpser*c* (b/apb)
      GO TO 100
C
C         PROCEDURE FOR A0 .LT. 1 AND 1 .LT. B0 .LT. 8
C
   40 u = gamln1(a0)
      m = int(b0 - 1.0D0)
      IF (m.LT.1) GO TO 60
      c = 1.0D0
      DO 50 i = 1,m
          b0 = b0 - 1.0D0
          c = c* (b0/ (a0+b0))
   50 CONTINUE
      u = dlog(c) + u
C
   60 z = a*dlog(x) - u
      b0 = b0 - 1.0D0
      apb = a0 + b0
      IF (apb.GT.1.0D0) GO TO 70
      t = 1.0D0 + gam1(apb)
      GO TO 80

   70 u = dble(a0) + dble(b0) - 1.D0
      t = (1.0D0+gam1(u))/apb
   80 bpser = exp(z)* (a0/a)* (1.0D0+gam1(b0))/t
      GO TO 100
C
C            PROCEDURE FOR A0 .LT. 1 AND B0 .GE. 8
C
   90 u = gamln1(a0) + algdiv(a0,b0)
      z = a*dlog(x) - u
      bpser = (a0/a)*exp(z)
  100 IF (bpser.EQ.0.0D0 .OR. a.LE.0.1D0*eps) RETURN
C-----------------------------------------------------------------------
C                     COMPUTE THE SERIES
C-----------------------------------------------------------------------
      sum = 0.0D0
      n = 0.0D0
      c = 1.0D0
      tol = eps/a
  110 n = n + 1.0D0
      c = c* (0.5D0+ (0.5D0-b/n))*x
      w = c/ (a+n)
      sum = sum + w
      IF (abs(w).GT.tol) GO TO 110
      bpser = bpser* (1.0D0+a*sum)
      RETURN

      END
      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 INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
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
      INCLUDE 'DPCOP2.INC'
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 INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
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
      INCLUDE 'DPCOP2.INC'
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                 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     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
      INCLUDE 'DPCOP2.INC'
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                 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     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
      INCLUDE 'DPCOP2.INC'
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 bratio(a,b,x,y,w,w1,ierr)
C-----------------------------------------------------------------------
C
C            EVALUATION OF THE INCOMPLETE BETA FUNCTION IX(A,B)
C
C                     --------------------
C
C     IT IS ASSUMED THAT A AND B ARE NONNEGATIVE, AND THAT X .LE. 1
C     AND Y = 1 - X.  BRATIO ASSIGNS W AND W1 THE VALUES
C
C                      W  = IX(A,B)
C                      W1 = 1 - IX(A,B)
C
C     IERR IS A VARIABLE THAT REPORTS THE STATUS OF THE RESULTS.
C     IF NO INPUT ERRORS ARE DETECTED THEN IERR IS SET TO 0 AND
C     W AND W1 ARE COMPUTED. OTHERWISE, IF AN ERROR IS DETECTED,
C     THEN W AND W1 ARE ASSIGNED THE VALUE 0 AND IERR IS SET TO
C     ONE OF THE FOLLOWING VALUES ...
C
C        IERR = 1  IF A OR B IS NEGATIVE
C        IERR = 2  IF A = B = 0
C        IERR = 3  IF X .LT. 0 OR X .GT. 1
C        IERR = 4  IF Y .LT. 0 OR Y .GT. 1
C        IERR = 5  IF X + Y .NE. 1
C        IERR = 6  IF X = A = 0
C        IERR = 7  IF Y = B = 0
C
C--------------------
C     WRITTEN BY ALFRED H. MORRIS, JR.
C        NAVAL SURFACE WARFARE CENTER
C        DAHLGREN, VIRGINIA
C     REVISED ... NOV 1991
C-----------------------------------------------------------------------
C     .. Scalar Arguments ..
      DOUBLE PRECISION a,b,w,w1,x,y
      INTEGER ierr
C     ..
C     .. Local Scalars ..
      DOUBLE PRECISION a0,b0,eps,lambda,t,x0,y0,z
      INTEGER ierr1,ind,n
C     ..
C     .. External Functions ..
      DOUBLE PRECISION apser,basym,bfrac,bpser,bup,fpser,spmpar
      EXTERNAL apser,basym,bfrac,bpser,bup,fpser,spmpar
C     ..
C     .. External Subroutines ..
      EXTERNAL bgrat
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC abs,dmax1,dmin1
C     ..
C     .. Executable Statements ..
C-----------------------------------------------------------------------
C
C     ****** EPS IS A MACHINE DEPENDENT CONSTANT. EPS IS THE SMALLEST
C            FLOATING POINT NUMBER FOR WHICH 1.0 + EPS .GT. 1.0
C
      eps = spmpar(1)
C
C-----------------------------------------------------------------------
      w = 0.0D0
      w1 = 0.0D0
      IF (a.LT.0.0D0 .OR. b.LT.0.0D0) GO TO 270
      IF (a.EQ.0.0D0 .AND. b.EQ.0.0D0) GO TO 280
      IF (x.LT.0.0D0 .OR. x.GT.1.0D0) GO TO 290
      IF (y.LT.0.0D0 .OR. y.GT.1.0D0) GO TO 300
      z = ((x+y)-0.5D0) - 0.5D0
      IF (abs(z).GT.3.0D0*eps) GO TO 310
C
      ierr = 0
      IF (x.EQ.0.0D0) GO TO 210
      IF (y.EQ.0.0D0) GO TO 230
      IF (a.EQ.0.0D0) GO TO 240
      IF (b.EQ.0.0D0) GO TO 220
C
      eps = dmax1(eps,1.D-15)
      IF (dmax1(a,b).LT.1.D-3*eps) GO TO 260
C
      ind = 0
      a0 = a
      b0 = b
      x0 = x
      y0 = y
      IF (dmin1(a0,b0).GT.1.0D0) GO TO 40
C
C             PROCEDURE FOR A0 .LE. 1 OR B0 .LE. 1
C
      IF (x.LE.0.5D0) GO TO 10
      ind = 1
      a0 = b
      b0 = a
      x0 = y
      y0 = x
C
   10 IF (b0.LT.dmin1(eps,eps*a0)) GO TO 90
      IF (a0.LT.dmin1(eps,eps*b0) .AND. b0*x0.LE.1.0D0) GO TO 100
      IF (dmax1(a0,b0).GT.1.0D0) GO TO 20
      IF (a0.GE.dmin1(0.2D0,b0)) GO TO 110
      IF (x0**a0.LE.0.9D0) GO TO 110
      IF (x0.GE.0.3D0) GO TO 120
      n = 20
      GO TO 140
C
   20 IF (b0.LE.1.0D0) GO TO 110
      IF (x0.GE.0.3D0) GO TO 120
      IF (x0.GE.0.1D0) GO TO 30
      IF ((x0*b0)**a0.LE.0.7D0) GO TO 110
   30 IF (b0.GT.15.0D0) GO TO 150
      n = 20
      GO TO 140
C
C             PROCEDURE FOR A0 .GT. 1 AND B0 .GT. 1
C
   40 IF (a.GT.b) GO TO 50
      lambda = a - (a+b)*x
      GO TO 60

   50 lambda = (a+b)*y - b
   60 IF (lambda.GE.0.0D0) GO TO 70
      ind = 1
      a0 = b
      b0 = a
      x0 = y
      y0 = x
      lambda = abs(lambda)
C
   70 IF (b0.LT.40.0D0 .AND. b0*x0.LE.0.7D0) GO TO 110
      IF (b0.LT.40.0D0) GO TO 160
      IF (a0.GT.b0) GO TO 80
      IF (a0.LE.100.0D0) GO TO 130
      IF (lambda.GT.0.03D0*a0) GO TO 130
      GO TO 200

   80 IF (b0.LE.100.0D0) GO TO 130
      IF (lambda.GT.0.03D0*b0) GO TO 130
      GO TO 200
C
C            EVALUATION OF THE APPROPRIATE ALGORITHM
C
   90 w = fpser(a0,b0,x0,eps)
      w1 = 0.5D0 + (0.5D0-w)
      GO TO 250
C
  100 w1 = apser(a0,b0,x0,eps)
      w = 0.5D0 + (0.5D0-w1)
      GO TO 250
C
  110 w = bpser(a0,b0,x0,eps)
      w1 = 0.5D0 + (0.5D0-w)
      GO TO 250
C
  120 w1 = bpser(b0,a0,y0,eps)
      w = 0.5D0 + (0.5D0-w1)
      GO TO 250
C
  130 w = bfrac(a0,b0,x0,y0,lambda,15.0D0*eps)
      w1 = 0.5D0 + (0.5D0-w)
      GO TO 250
C
  140 w1 = bup(b0,a0,y0,x0,n,eps)
      b0 = b0 + n
  150 CALL bgrat(b0,a0,y0,x0,w1,15.0D0*eps,ierr1)
      w = 0.5D0 + (0.5D0-w1)
      GO TO 250
C
  160 n = int(b0)
      b0 = b0 - real(n)
      IF (b0.NE.0.0D0) GO TO 170
      n = n - 1
      b0 = 1.0D0
  170 w = bup(b0,a0,y0,x0,n,eps)
      IF (x0.GT.0.7D0) GO TO 180
      w = w + bpser(a0,b0,x0,eps)
      w1 = 0.5D0 + (0.5D0-w)
      GO TO 250
C
  180 IF (a0.GT.15.0D0) GO TO 190
      n = 20
      w = w + bup(a0,b0,x0,y0,n,eps)
      a0 = a0 + n
  190 CALL bgrat(a0,b0,x0,y0,w,15.0D0*eps,ierr1)
      w1 = 0.5D0 + (0.5D0-w)
      GO TO 250
C
  200 w = basym(a0,b0,lambda,100.0D0*eps)
      w1 = 0.5D0 + (0.5D0-w)
      GO TO 250
C
C               TERMINATION OF THE PROCEDURE
C
  210 IF (a.EQ.0.0D0) GO TO 320
  220 w = 0.0D0
      w1 = 1.0D0
      RETURN
C
  230 IF (b.EQ.0.0D0) GO TO 330
  240 w = 1.0D0
      w1 = 0.0D0
      RETURN
C
  250 IF (ind.EQ.0) RETURN
      t = w
      w = w1
      w1 = t
      RETURN
C
C           PROCEDURE FOR A AND B .LT. 1.E-3*EPS
C
  260 w = b/ (a+b)
      w1 = a/ (a+b)
      RETURN
C
C                       ERROR RETURN
C
  270 ierr = 1
      RETURN

  280 ierr = 2
      RETURN

  290 ierr = 3
      RETURN

  300 ierr = 4
      RETURN

  310 ierr = 5
      RETURN

  320 ierr = 6
      RETURN

  330 ierr = 7
      RETURN

      END
      DOUBLE PRECISION FUNCTION brcmp1(mu,a,b,x,y)
C-----------------------------------------------------------------------
C          EVALUATION OF  EXP(MU) * (X**A*Y**B/BETA(A,B))
C-----------------------------------------------------------------------
C     .. Scalar Arguments ..
      DOUBLE PRECISION a,b,x,y
      INTEGER mu
C     ..
C     .. Local Scalars ..
      DOUBLE PRECISION a0,apb,b0,c,const,e,h,lambda,lnx,lny,t,u,v,x0,y0,
     +                 z
      INTEGER i,n
C     ..
C     .. External Functions ..
      DOUBLE PRECISION algdiv,alnrel,bcorr,betaln,esum,gam1,gamln1,rlog1
      EXTERNAL algdiv,alnrel,bcorr,betaln,esum,gam1,gamln1,rlog1
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC abs,dble,dlog,dmax1,dmin1,exp,sqrt
C     ..
C     .. Data statements ..
C-----------------
C     CONST = 1/SQRT(2*PI)
C-----------------
      DATA const/.398942280401433D0/
C     ..
C     .. Executable Statements ..
C
      a0 = dmin1(a,b)
      IF (a0.GE.8.0D0) GO TO 130
C
      IF (x.GT.0.375D0) GO TO 10
      lnx = dlog(x)
      lny = alnrel(-x)
      GO TO 30

   10 IF (y.GT.0.375D0) GO TO 20
      lnx = alnrel(-y)
      lny = dlog(y)
      GO TO 30

   20 lnx = dlog(x)
      lny = dlog(y)
C
   30 z = a*lnx + b*lny
      IF (a0.LT.1.0D0) GO TO 40
      z = z - betaln(a,b)
      brcmp1 = esum(mu,z)
      RETURN
C-----------------------------------------------------------------------
C              PROCEDURE FOR A .LT. 1 OR B .LT. 1
C-----------------------------------------------------------------------
   40 b0 = dmax1(a,b)
      IF (b0.GE.8.0D0) GO TO 120
      IF (b0.GT.1.0D0) GO TO 70
C
C                   ALGORITHM FOR B0 .LE. 1
C
      brcmp1 = esum(mu,z)
      IF (brcmp1.EQ.0.0D0) RETURN
C
      apb = a + b
      IF (apb.GT.1.0D0) GO TO 50
      z = 1.0D0 + gam1(apb)
      GO TO 60

   50 u = dble(a) + dble(b) - 1.D0
      z = (1.0D0+gam1(u))/apb
C
   60 c = (1.0D0+gam1(a))* (1.0D0+gam1(b))/z
      brcmp1 = brcmp1* (a0*c)/ (1.0D0+a0/b0)
      RETURN
C
C                ALGORITHM FOR 1 .LT. B0 .LT. 8
C
   70 u = gamln1(a0)
      n = int(b0 - 1.0D0)
      IF (n.LT.1) GO TO 90
      c = 1.0D0
      DO 80 i = 1,n
          b0 = b0 - 1.0D0
          c = c* (b0/ (a0+b0))
   80 CONTINUE
      u = dlog(c) + u
C
   90 z = z - u
      b0 = b0 - 1.0D0
      apb = a0 + b0
      IF (apb.GT.1.0D0) GO TO 100
      t = 1.0D0 + gam1(apb)
      GO TO 110

  100 u = dble(a0) + dble(b0) - 1.D0
      t = (1.0D0+gam1(u))/apb
  110 brcmp1 = a0*esum(mu,z)* (1.0D0+gam1(b0))/t
      RETURN
C
C                   ALGORITHM FOR B0 .GE. 8
C
  120 u = gamln1(a0) + algdiv(a0,b0)
      brcmp1 = a0*esum(mu,z-u)
      RETURN
C-----------------------------------------------------------------------
C              PROCEDURE FOR A .GE. 8 AND B .GE. 8
C-----------------------------------------------------------------------
  130 IF (a.GT.b) GO TO 140
      h = a/b
      x0 = h/ (1.0D0+h)
      y0 = 1.0D0/ (1.0D0+h)
      lambda = a - (a+b)*x
      GO TO 150

  140 h = b/a
      x0 = 1.0D0/ (1.0D0+h)
      y0 = h/ (1.0D0+h)
      lambda = (a+b)*y - b
C
  150 e = -lambda/a
      IF (abs(e).GT.0.6D0) GO TO 160
      u = rlog1(e)
      GO TO 170

  160 u = e - dlog(x/x0)
C
  170 e = lambda/b
      IF (abs(e).GT.0.6D0) GO TO 180
      v = rlog1(e)
      GO TO 190

  180 v = e - dlog(y/y0)
C
  190 z = esum(mu,- (a*u+b*v))
      brcmp1 = const*sqrt(b*x0)*z*exp(-bcorr(a,b))
      RETURN

      END
      DOUBLE PRECISION FUNCTION brcomp(a,b,x,y)
C-----------------------------------------------------------------------
C               EVALUATION OF X**A*Y**B/BETA(A,B)
C-----------------------------------------------------------------------
C     .. Scalar Arguments ..
      DOUBLE PRECISION a,b,x,y
C     ..
C     .. Local Scalars ..
      DOUBLE PRECISION a0,apb,b0,c,const,e,h,lambda,lnx,lny,t,u,v,x0,y0,
     +                 z
      INTEGER i,n
C     ..
C     .. External Functions ..
      DOUBLE PRECISION algdiv,alnrel,bcorr,betaln,gam1,gamln1,rlog1
      EXTERNAL algdiv,alnrel,bcorr,betaln,gam1,gamln1,rlog1
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC abs,dble,dlog,dmax1,dmin1,exp,sqrt
C     ..
C     .. Data statements ..
C-----------------
C     CONST = 1/SQRT(2*PI)
C-----------------
      DATA const/.398942280401433D0/
C     ..
C     .. Executable Statements ..
C
      brcomp = 0.0D0
      IF (x.EQ.0.0D0 .OR. y.EQ.0.0D0) RETURN
      a0 = dmin1(a,b)
      IF (a0.GE.8.0D0) GO TO 130
C
      IF (x.GT.0.375D0) GO TO 10
      lnx = dlog(x)
      lny = alnrel(-x)
      GO TO 30

   10 IF (y.GT.0.375D0) GO TO 20
      lnx = alnrel(-y)
      lny = dlog(y)
      GO TO 30

   20 lnx = dlog(x)
      lny = dlog(y)
C
   30 z = a*lnx + b*lny
      IF (a0.LT.1.0D0) GO TO 40
      z = z - betaln(a,b)
      brcomp = exp(z)
      RETURN
C-----------------------------------------------------------------------
C              PROCEDURE FOR A .LT. 1 OR B .LT. 1
C-----------------------------------------------------------------------
   40 b0 = dmax1(a,b)
      IF (b0.GE.8.0D0) GO TO 120
      IF (b0.GT.1.0D0) GO TO 70
C
C                   ALGORITHM FOR B0 .LE. 1
C
      brcomp = exp(z)
      IF (brcomp.EQ.0.0D0) RETURN
C
      apb = a + b
      IF (apb.GT.1.0D0) GO TO 50
      z = 1.0D0 + gam1(apb)
      GO TO 60

   50 u = dble(a) + dble(b) - 1.D0
      z = (1.0D0+gam1(u))/apb
C
   60 c = (1.0D0+gam1(a))* (1.0D0+gam1(b))/z
      brcomp = brcomp* (a0*c)/ (1.0D0+a0/b0)
      RETURN
C
C                ALGORITHM FOR 1 .LT. B0 .LT. 8
C
   70 u = gamln1(a0)
      n = int(b0 - 1.0D0)
      IF (n.LT.1) GO TO 90
      c = 1.0D0
      DO 80 i = 1,n
          b0 = b0 - 1.0D0
          c = c* (b0/ (a0+b0))
   80 CONTINUE
      u = dlog(c) + u
C
   90 z = z - u
      b0 = b0 - 1.0D0
      apb = a0 + b0
      IF (apb.GT.1.0D0) GO TO 100
      t = 1.0D0 + gam1(apb)
      GO TO 110

  100 u = dble(a0) + dble(b0) - 1.D0
      t = (1.0D0+gam1(u))/apb
  110 brcomp = a0*exp(z)* (1.0D0+gam1(b0))/t
      RETURN
C
C                   ALGORITHM FOR B0 .GE. 8
C
  120 u = gamln1(a0) + algdiv(a0,b0)
      brcomp = a0*exp(z-u)
      RETURN
C-----------------------------------------------------------------------
C              PROCEDURE FOR A .GE. 8 AND B .GE. 8
C-----------------------------------------------------------------------
  130 IF (a.GT.b) GO TO 140
      h = a/b
      x0 = h/ (1.0D0+h)
      y0 = 1.0D0/ (1.0D0+h)
      lambda = a - (a+b)*x
      GO TO 150

  140 h = b/a
      x0 = 1.0D0/ (1.0D0+h)
      y0 = h/ (1.0D0+h)
      lambda = (a+b)*y - b
C
  150 e = -lambda/a
      IF (abs(e).GT.0.6D0) GO TO 160
      u = rlog1(e)
      GO TO 170

  160 u = e - dlog(x/x0)
C
  170 e = lambda/b
      IF (abs(e).GT.0.6D0) GO TO 180
      v = rlog1(e)
      GO TO 190

  180 v = e - dlog(y/y0)
C
  190 z = exp(- (a*u+b*v))
      brcomp = const*sqrt(b*x0)*z*exp(-bcorr(a,b))
      RETURN

      END
      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
      INCLUDE 'DPCOP2.INC'
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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
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
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      CDF=0.0
      IK=INT(K+0.5)
      INTX=INT(X+0.5)
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(LAMBDA.LE.0.0 .OR. LAMBDA.GE.1.0)THEN
        WRITE(ICOUT,11)
   11   FORMAT('***** ERROR--THE SECOND ARGUMENT TO BTACDF ',
     1         'IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)LAMBDA
   46   FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7,'.')
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ELSEIF(IK.LT.1)THEN
        WRITE(ICOUT,12)
   12   FORMAT('***** ERROR--THE THIRD ARGUMENT TO BTACDF ',
     1         'IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)IK
   47   FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,'.')
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ELSEIF(INTX.LT.IK)THEN
        WRITE(ICOUT,5)IK
    5   FORMAT('***** ERROR--THE FIRST ARGUMENT TO BTACDF ',
     1         'IS LESS THAN THE THIRD ARGUMENT (= ',I8,').')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
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
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      PDF=0.0
      IK=INT(K+0.5)
      INTX=INT(X+0.5)
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(LAMBDA.LE.0.0 .OR. LAMBDA.GE.1.0)THEN
        WRITE(ICOUT,11)
   11   FORMAT('***** ERROR--THE SECOND ARGUMENT TO BTAPDF ',
     1         'IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)LAMBDA
   46   FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7,'.')
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ELSEIF(IK.LT.1)THEN
        WRITE(ICOUT,12)
   12   FORMAT('***** ERROR--THE THIRD ARGUMENT TO BTAPDF ',
     1         'IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)IK
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ELSEIF(INTX.LT.IK)THEN
        WRITE(ICOUT,5)IK
    5   FORMAT('***** ERROR--THE FIRST ARGUMENT TO BTAPDF ',
     1         'IS LESS THAN THE THIRD ARGUMENT (= ',I8,').')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)INTX
   47   FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,'.')
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
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
      DOUBLE PRECISION DEPS
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
      INCLUDE 'DPCOP2.INC'
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)
      DEPS=1.0D-7
C
C     COMPUTE PDF FOR X = IK
C
      DX=DK
      DCDF=DEXP(-DLAMB*DX - DLNGAM(1.0D0))
C
      IF(DCDF.GE.DP-DEPS)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-DEPS)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     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
      INCLUDE 'DPCOP2.INC'
C
C-----DATA STATEMENTS-------------------------------------------------
C
CCCCC 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
      SUBROUTINE BU2CDF(DX,DR,DCDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE BURR TYPE 2 DISTRIBTION.
C              THE CUMULATIVE DISTRIBUTION FUNCTION IS:
C
C              F(X;R) = 1/[(1+EXP(-X))**R]    -INF <  X <  INF; R > 0
C
C              WITH SHAPE PARAMETER R.
C     INPUT  ARGUMENTS--DX     = THE DOUBLE PRECISION VALUE AT
C                                WHICH THE CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C                     --DR     = THE SHAPE PARAMETER
C     OUTPUT ARGUMENTS--DCDF   = THE DOUBLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION CUMULATIVE DISTRIBUTION
C             FUNCTION VALUE CDF FOR THE BURR TYPE 2 DISTRIBUTION
C             WITH SHAPE PARAMETER R.
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--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME I", SECOND EDITION,
C                 JOHN WILEY, 1994, PP. 53-54.
C               --LUC DEVROYE, "NON-UNIFORM RANDOM VARIATE
C                 GENERATION", 1986, SPRINGER-VERLANG, PP. 476-477.
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     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2007.10
C     ORIGINAL VERSION--OCTOBER   2007.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DCDF
      DOUBLE PRECISION DX
      DOUBLE PRECISION DR
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----DATA STATEMENTS-------------------------------------------------
C
C-----START POINT-----------------------------------------------------
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      DCDF=0.0D0
C
      IF(DR.LE.0.0D0)THEN
        WRITE(ICOUT,115)
  115   FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO BU2CDF ',
     1         'IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,147)DR
  147   FORMAT('      THE VALUE OF THE ARGUMENT IS ',G15.7)
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
C               **************************************************
C               **  STEP 2B-                                    **
C               **  COMPUTE BURR TYPE 2  CDF                    **
C               **************************************************
C
      DTERM1=1.0D0 + DEXP(-DX)
      DTERM2=DTERM1**DR
      DCDF=1.0D0/DTERM2
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE BU2PDF(DX,DR,DPDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE BURR TYPE 2 DISTRIBTION.
C              THE PROBABILITY DENSITY FUNCTION IS:
C
C              f(X;R) = R*(1 + EXP(-X))**(-1-R)/EXP(X)
C                       -INF <  X <  INF; R > 0
C
C              WITH SHAPE PARAMETER R.
C     INPUT  ARGUMENTS--DX     = THE DOUBLE PRECISION VALUE AT
C                                WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C                     --DR     = THE SHAPE PARAMETER
C     OUTPUT ARGUMENTS--DPDF   = THE DOUBLE PRECISION PROBABILITY DENSITY
C                                FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE PDF FOR THE BURR TYPE 2 DISTRIBUTION
C             WITH SHAPE PARAMETER R.
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--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME I", SECOND EDITION,
C                 JOHN WILEY, 1994, PP. 53-54.
C               --LUC DEVROYE, "NON-UNIFORM RANDOM VARIATE
C                 GENERATION", 1986, SPRINGER-VERLANG, PP. 476-477.
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     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2007.10
C     ORIGINAL VERSION--OCTOBER   2007.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DPDF
      DOUBLE PRECISION DX
      DOUBLE PRECISION DR
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----DATA STATEMENTS-------------------------------------------------
C
C-----START POINT-----------------------------------------------------
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      DPDF=0.0D0
C
      IF(DR.LE.0.0D0)THEN
        WRITE(ICOUT,115)
  115   FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO BU2PDF ',
     1         'NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,147)DR
  147   FORMAT('      THE VALUE OF THE ARGUMENT IS ',G15.7)
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
C               **************************************************
C               **  STEP 2B-                                    **
C               **  COMPUTE BURR TYPE II PDF                    **
C               **************************************************
C
      DTERM1=DLOG(DR) + (-1.0D0 - DR)*DLOG(1.0D0 + DEXP(-DX))
      DTERM2=DX
      DPDF=DEXP(DTERM1 - DTERM2)
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE BU2PPF(DP,DR,DPPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE BURR TYPE 2 DISTRIBUTION.
C              THE PERCENT POINT FUNCTION IS:
C
C              G(P;R) = -LOG((1/P)**(1/R) - 1)   0 < P < 1; R > 0
C
C              WITH SHAPE PARAMETER R.
C     INPUT  ARGUMENTS--DP     = THE DOUBLE PRECISION VALUE AT
C                                WHICH THE PERCENT POINT
C                                FUNCTION IS TO BE EVALUATED.
C                     --DR     = THE SHAPE PARAMETER
C     OUTPUT ARGUMENTS--DPPF   = THE DOUBLE PRECISION PERCENT POINT
C                                FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION PERCENT POINT
C             FUNCTION VALUE PPF FOR THE BURR TYPE 2 DISTRIBUTION
C             WITH SHAPE PARAMETER R.
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--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME I", SECOND EDITION,
C                 JOHN WILEY, 1994, PP. 53-54.
C               --LUC DEVROYE, "NON-UNIFORM RANDOM VARIATE
C                 GENERATION", 1986, SPRINGER-VERLANG, PP. 476-477.
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     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2007.10
C     ORIGINAL VERSION--OCTOBER   2007.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DPPF
      DOUBLE PRECISION DP
      DOUBLE PRECISION DR
      DOUBLE PRECISION DTERM1
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----DATA STATEMENTS-------------------------------------------------
C
C-----START POINT-----------------------------------------------------
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      DPPF=0.0D0
C
      IF(DP.LE.0.0D0 .OR. DP.GE.1.0D0)THEN
        WRITE(ICOUT,105)
  105   FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO BU2PPF ',
     1         'IS OUTSIDE THE (0,1) INTERVAL.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,147)DP
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(DR.LE.0.0D0)THEN
        WRITE(ICOUT,115)
  115   FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO BU2PPF ',
     1         'IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,147)DR
  147   FORMAT('      THE VALUE OF THE ARGUMENT IS ',G15.7)
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
C               **************************************************
C               **  STEP 2B-                                    **
C               **  COMPUTE BURR TYPE 2 PPF                     **
C               **************************************************
C
      DTERM1=(1.0D0/DP)**(1.0D0/DR)
      DPPF=-DLOG(DTERM1 - 1.0D0)
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE BU2RAN(N,R,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE BURR TYPE 2 DISTRIBUTION WITH
C              SHAPE PARAMETER R.
C
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --R      = THE SINGLE PRECISION VALUE OF THE
C                                SHAPE PARAMETER R.
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 BURR TYPE 2 DISTRIBUTION
C             WITH SHAPE PARAMETER R.
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, BU2PPF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME I", SECOND EDITION,
C                 JOHN WILEY, 1994, PP. 53-54.
C               --LUC DEVROYE, "NON-UNIFORM RANDOM VARIATE
C                 GENERATION", 1986, SPRINGER-VERLANG, PP. 476-477.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHMOLOGY 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     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2007.10
C     ORIGINAL VERSION--OCTOBER   2007.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
C
      DOUBLE PRECISION DTEMP
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
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
    5   FORMAT('***** ERROR--THE REQUESTED NUMBER OF ',
     1         'BURR TYPE 2 RANDOM NUMBERS IS NON-POSITIVE')
   47   FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8)
      ELSEIF(R.LE.0.0)THEN
        WRITE(ICOUT,201)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,203)R
        CALL DPWRST('XXX','BUG ')
        GOTO9000
  201   FORMAT('***** ERROR--THE R SHAPE PARAMETER IS NON-POSITIVE.')
  203   FORMAT('      THE VALUE OF R IS ',G15.7)
      ENDIF
C
C     GENERATE N UNIFORM (0,1) RANDOM NUMBERS;
C
      CALL UNIRAN(N,ISEED,X)
C
C     GENERATE N SLOPE DISTRIBUTION RANDOM
C     NUMBERS USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD.
C
      DO300I=1,N
        CALL BU2PPF(DBLE(X(I)),DBLE(R),DTEMP)
        X(I)=DBLE(DTEMP)
  300 CONTINUE
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE BU3CDF(DX,DR,DK,DCDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE BURR TYPE 3 DISTRIBTION.
C              THE CUMULATIVE DISTRIBUTION FUNCTION IS:
C
C              F(X;R,K) = (1+X**(-K))**(-R)    0 <  X <  INF; R, K > 0
C
C              WITH SHAPE PARAMETERS R AND K.
C     INPUT  ARGUMENTS--DX     = THE DOUBLE PRECISION VALUE AT
C                                WHICH THE CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C                     --DR     = THE FIRST SHAPE PARAMETER
C                     --DK     = THE SECOND SHAPE PARAMETER
C     OUTPUT ARGUMENTS--DCDF   = THE DOUBLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION CUMULATIVE DISTRIBUTION
C             FUNCTION VALUE CDF FOR THE BURR TYPE 3 DISTRIBUTION
C             WITH SHAPE PARAMETERS R AND 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--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME I", SECOND EDITION,
C                 JOHN WILEY, 1994, PP. 53-54.
C               --LUC DEVROYE, "NON-UNIFORM RANDOM VARIATE
C                 GENERATION", 1986, SPRINGER-VERLANG, PP. 476-477.
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     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2007.10
C     ORIGINAL VERSION--OCTOBER   2007.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DCDF
      DOUBLE PRECISION DX
      DOUBLE PRECISION DR
      DOUBLE PRECISION DK
      DOUBLE PRECISION DTERM1
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----DATA STATEMENTS-------------------------------------------------
C
C-----START POINT-----------------------------------------------------
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      DCDF=0.0D0
C
      IF(DR.LE.0.0D0)THEN
        WRITE(ICOUT,115)
  115   FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO BU3CDF ',
     1         'IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,147)DR
  147   FORMAT('      THE VALUE OF THE ARGUMENT IS ',G15.7)
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(DK.LE.0.0D0)THEN
        WRITE(ICOUT,125)
  125   FORMAT('***** ERROR--THE THIRD INPUT ARGUMENT TO BU3CDF ',
     1         'IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,147)DK
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
C               **************************************************
C               **  STEP 2B-                                    **
C               **  COMPUTE BURR TYPE 3 CDF                     **
C               **************************************************
C
      IF(DX.LE.0.0D0)THEN
        DCDF=0.0D0
      ELSE
        DTERM1=1.0D0 + DX**(-DK)
        DCDF=DTERM1**(-DR)
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE BU3PDF(DX,DR,DK,DPDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE BURR TYPE 3 DISTRIBTION.
C              THE PROBABILITY DENSITY FUNCTION IS:
C
C              f(X;R,K) = R*K*X**(R*K-1)/(1+X**K)**(R+1)
C              X >  0; R, K > 0
C
C              WITH SHAPE PARAMETERS R AND K.
C     INPUT  ARGUMENTS--DX     = THE DOUBLE PRECISION VALUE AT
C                                WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C                     --DR     = THE FIRST SHAPE PARAMETER
C                     --DK     = THE SECOND SHAPE PARAMETER
C     OUTPUT ARGUMENTS--DPDF   = THE DOUBLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE PDF FOR THE BURR TYPE 3 DISTRIBUTION
C             WITH SHAPE PARAMETERS R AND 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--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME I", SECOND EDITION,
C                 JOHN WILEY, 1994, PP. 53-54.
C               --LUC DEVROYE, "NON-UNIFORM RANDOM VARIATE
C                 GENERATION", 1986, SPRINGER-VERLANG, PP. 476-477.
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     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2007.10
C     ORIGINAL VERSION--OCTOBER   2007.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DPDF
      DOUBLE PRECISION DX
      DOUBLE PRECISION DR
      DOUBLE PRECISION DK
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----DATA STATEMENTS-------------------------------------------------
C
C-----START POINT-----------------------------------------------------
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      DPDF=0.0D0
C
      IF(DX.LE.0.0D0)THEN
        WRITE(ICOUT,105)
  105   FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO BU3PDF ',
     1         'IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,147)DX
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(DR.LE.0.0D0)THEN
        WRITE(ICOUT,115)
  115   FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO BU3PDF ',
     1         'IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,147)DR
  147   FORMAT('      THE VALUE OF THE ARGUMENT IS ',G15.7)
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(DK.LE.0.0D0)THEN
        WRITE(ICOUT,125)
  125   FORMAT('***** ERROR--THE THIRD INPUT ARGUMENT TO BU3PDF ',
     1         'IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,147)DK
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
C               **************************************************
C               **  STEP 2B-                                    **
C               **  COMPUTE BURR TYPE 3 PDF                     **
C               **************************************************
C
      DTERM1=DLOG(DR) + DLOG(DK) + (DR*DK - 1.0D0)*DLOG(DX)
      DTERM2=(DR+1.0D0)*DLOG(1.0D0 + DX**DK)
      DPDF=DEXP(DTERM1 - DTERM2)
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE BU3PPF(DP,DR,DK,DPPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE BURR TYPE 3 DISTRIBUTION.
C              THE PERCENT POINT FUNCTION IS:
C
C              G(P;R,K) = (P**(-1/R) - 1)**(-1/K)  0 < P < 1; R, K > 0
C
C              WITH SHAPE PARAMETERS R AND K.
C     INPUT  ARGUMENTS--DP     = THE DOUBLE PRECISION VALUE AT
C                                WHICH THE PERCENT POINT
C                                FUNCTION IS TO BE EVALUATED.
C                     --DR     = THE FIRST SHAPE PARAMETER
C                     --DK     = THE SECOND SHAPE PARAMETER
C     OUTPUT ARGUMENTS--DPPF   = THE DOUBLE PRECISION PERCENT POINT
C                                FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION PERCENT POINT
C             FUNCTION VALUE PPF FOR THE BURR TYPE 3 DISTRIBUTION
C             WITH SHAPE PARAMETER R.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--NONE.
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--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME I", SECOND EDITION,
C                 JOHN WILEY, 1994, PP. 53-54.
C               --LUC DEVROYE, "NON-UNIFORM RANDOM VARIATE
C                 GENERATION", 1986, SPRINGER-VERLANG, PP. 476-477.
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     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2007.10
C     ORIGINAL VERSION--OCTOBER   2007.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DPPF
      DOUBLE PRECISION DP
      DOUBLE PRECISION DR
      DOUBLE PRECISION DK
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----DATA STATEMENTS-------------------------------------------------
C
C-----START POINT-----------------------------------------------------
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      DPPF=0.0D0
C
      IF(DP.LE.0.0D0 .OR. DP.GE.1.0D0)THEN
        WRITE(ICOUT,105)
  105   FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO BU3PPF ',
     1         'IS OUTSIDE THE (0,1) INTERVAL.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,147)DP
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(DR.LE.0.0D0)THEN
        WRITE(ICOUT,115)
  115   FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO BU3PPF ',
     1         'IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,147)DR
  147   FORMAT('      THE VALUE OF THE ARGUMENT IS ',G15.7)
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(DK.LE.0.0D0)THEN
        WRITE(ICOUT,125)
  125   FORMAT('***** ERROR--THE THIRD INPUT ARGUMENT TO BU3PPF ',
     1         'IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,147)DK
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
C               **************************************************
C               **  STEP 2B-                                    **
C               **  COMPUTE BURR TYPE 12 PPF                    **
C               **************************************************
C
      IF(DP.LE.0.0D0)THEN
        DPPF=0.0D0
      ELSE
        DPPF=(DP**(-1.0D0/DR) - 1.0D0)**(-1.0D0/DK)
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE BU3RAN(N,R,AK,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE BURR TYPE 3 DISTRIBUTION WITH
C              SHAPE PARAMETERS R AND K.
C
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --R      = THE SINGLE PRECISION VALUE OF THE
C                                SHAPE PARAMETER R.
C                     --AK     = THE SINGLE PRECISION VALUE OF THE
C                                SHAPE PARAMETER K.
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 BURR TYPE 3 DISTRIBUTION
C             WITH SHAPE PARAMETERS R 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     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN, BU3PPF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME I", SECOND EDITION,
C                 JOHN WILEY, 1994, PP. 53-54.
C               --LUC DEVROYE, "NON-UNIFORM RANDOM VARIATE
C                 GENERATION", 1986, SPRINGER-VERLANG, PP. 476-477.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHMOLOGY 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     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2007.10
C     ORIGINAL VERSION--OCTOBER   2007.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
C
      DOUBLE PRECISION DTEMP
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
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
    5   FORMAT('***** ERROR--THE REQUESTED NUMBER OF ',
     1         'BURR TYPE 3 RANDOM NUMBERS IS NON-POSITIVE')
   47   FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8)
      ELSEIF(R.LE.0.0)THEN
        WRITE(ICOUT,201)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,203)R
        CALL DPWRST('XXX','BUG ')
        GOTO9000
  201   FORMAT('***** ERROR--THE R SHAPE PARAMETER IS NON-POSITIVE.')
  203   FORMAT('      THE VALUE OF R IS ',G15.7)
      ELSEIF(AK.LE.0.0)THEN
        WRITE(ICOUT,211)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,213)AK
        CALL DPWRST('XXX','BUG ')
        GOTO9000
  211   FORMAT('***** ERROR--THE K SHAPE PARAMETER IS NON-POSITIVE.')
  213   FORMAT('      THE VALUE OF K IS ',G15.7)
      ENDIF
C
C     GENERATE N UNIFORM (0,1) RANDOM NUMBERS;
C
      CALL UNIRAN(N,ISEED,X)
C
C     GENERATE N SLOPE DISTRIBUTION RANDOM
C     NUMBERS USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD.
C
      DO300I=1,N
        CALL BU3PPF(DBLE(X(I)),DBLE(R),DBLE(AK),DTEMP)
        X(I)=DBLE(DTEMP)
  300 CONTINUE
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE BU4CDF(DX,DR,DC,DCDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE BURR TYPE 4 DISTRIBTION.
C              THE CUMULATIVE DISTRIBUTION FUNCTION IS:
C
C              F(X;R,C) = [1 + (C-X)/X)**(1/C)]**(-R)
C                         0 <  X <  C; C, R > 0
C
C              WITH SHAPE PARAMETERS R AND C.
C     INPUT  ARGUMENTS--DX     = THE DOUBLE PRECISION VALUE AT
C                                WHICH THE CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C                     --DR     = THE FIRST SHAPE PARAMETER
C                     --DC     = THE SECOND SHAPE PARAMETER
C     OUTPUT ARGUMENTS--DCDF   = THE DOUBLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION CUMULATIVE DISTRIBUTION
C             FUNCTION VALUE CDF FOR THE BURR TYPE 4 DISTRIBUTION
C             WITH SHAPE PARAMETERS R AND C.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--NONE.
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--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME I", SECOND EDITION,
C                 JOHN WILEY, 1994, PP. 53-54.
C               --LUC DEVROYE, "NON-UNIFORM RANDOM VARIATE
C                 GENERATION", 1986, SPRINGER-VERLANG, PP. 476-477.
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     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2007.10
C     ORIGINAL VERSION--OCTOBER   2007.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DCDF
      DOUBLE PRECISION DX
      DOUBLE PRECISION DR
      DOUBLE PRECISION DC
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----DATA STATEMENTS-------------------------------------------------
C
C-----START POINT-----------------------------------------------------
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      DCDF=0.0D0
C
      IF(DX.GE.DC)THEN
        WRITE(ICOUT,105)
  105   FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO BU4CDF IS')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,108)
  108   FORMAT('      GREATER THAN OR EQUAL TO THE THIRD INPUT ',
     1         'ARGUMENT.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,141)DX
  141   FORMAT('      THE VALUE OF THE FIRST ARGUMENT IS ',G15.7)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,143)DC
  143   FORMAT('      THE VALUE OF THE THIRD ARGUMENT IS ',G15.7)
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(DR.LE.0.0D0)THEN
        WRITE(ICOUT,115)
  115   FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO BU4CDF ',
     1         'IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,147)DR
  147   FORMAT('      THE VALUE OF THE ARGUMENT IS ',G15.7)
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(DC.LE.0.0D0)THEN
        WRITE(ICOUT,125)
  125   FORMAT('***** ERROR--THE THIRD INPUT ARGUMENT TO BU4CDF ',
     1         'IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,147)DC
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
C               **************************************************
C               **  STEP 2B-                                    **
C               **  COMPUTE BURR TYPE 4 CDF                     **
C               **************************************************
C
      IF(DX.LE.0.0D0)THEN
        DCDF=0.0D0
      ELSE
        DCDF=(1.0D0 + ((DC-DX)/DX)**(1.0D0/DC))**(-DR)
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE BU4PPF(DP,DR,DC,DPPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE BURR TYPE 4 DISTRIBUTION.
C              THE PERCENT POINT FUNCTION IS:
C
C              G(P;R,C) = C/[1 + (P**(-1/R) - 1)**C]
C                         0 <= P < 1; R, C > 0
C
C              WITH SHAPE PARAMETERS R AND C.
C     INPUT  ARGUMENTS--DP     = THE DOUBLE PRECISION VALUE AT
C                                WHICH THE PERCENT POINT
C                                FUNCTION IS TO BE EVALUATED.
C                     --DR     = THE FIRST SHAPE PARAMETER
C                     --DC     = THE SECOND SHAPE PARAMETER
C     OUTPUT ARGUMENTS--DPPF   = THE DOUBLE PRECISION PERCENT POINT
C                                FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION PERCENT POINT
C             FUNCTION VALUE PPF FOR THE BURR TYPE 4 DISTRIBUTION
C             WITH SHAPE PARAMETER R.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--NONE.
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--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME I", SECOND EDITION,
C                 JOHN WILEY, 1994, PP. 53-54.
C               --LUC DEVROYE, "NON-UNIFORM RANDOM VARIATE
C                 GENERATION", 1986, SPRINGER-VERLANG, PP. 476-477.
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     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2007.10
C     ORIGINAL VERSION--OCTOBER   2007.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DPPF
      DOUBLE PRECISION DP
      DOUBLE PRECISION DR
      DOUBLE PRECISION DC
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----DATA STATEMENTS-------------------------------------------------
C
C-----START POINT-----------------------------------------------------
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      DPPF=0.0D0
C
      IF(DP.LT.0.0D0 .OR. DP.GE.1.0D0)THEN
        WRITE(ICOUT,105)
  105   FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO BU4PPF ',
     1         'IS OUTSIDE THE (0,1) INTERVAL.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,147)DP
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(DR.LE.0.0D0)THEN
        WRITE(ICOUT,115)
  115   FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO BU4PPF ',
     1         'NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,147)DR
  147   FORMAT('      THE VALUE OF THE ARGUMENT IS ',G15.7)
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(DC.LE.0.0D0)THEN
        WRITE(ICOUT,125)
  125   FORMAT('***** ERROR--THE THIRD INPUT ARGUMENT TO BU4PPF ',
     1         'NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,147)DC
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
C               **************************************************
C               **  STEP 2B-                                    **
C               **  COMPUTE BURR TYPE 4 PPF                     **
C               **************************************************
C
      IF(DP.LE.0.0D0)THEN
        DPPF=0.0D0
      ELSE
        DPPF=DC/(1.0D0 + (DP**(-1.0D0/DR) - 1.0D0)**DC)
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE BU4RAN(N,R,C,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE BURR TYPE 4 DISTRIBUTION WITH
C              SHAPE PARAMETERS R AND C.
C
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --R      = THE SINGLE PRECISION VALUE OF THE
C                                SHAPE PARAMETER R.
C                     --C     = THE SINGLE PRECISION VALUE OF THE
C                                SHAPE PARAMETER K.
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 BURR TYPE 4 DISTRIBUTION
C             WITH SHAPE PARAMETERS R AND C.
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, BU4PPF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME I", SECOND EDITION,
C                 JOHN WILEY, 1994, PP. 53-54.
C               --LUC DEVROYE, "NON-UNIFORM RANDOM VARIATE
C                 GENERATION", 1986, SPRINGER-VERLANG, PP. 476-477.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHMOLOGY 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     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2007.10
C     ORIGINAL VERSION--OCTOBER   2007.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
C
      DOUBLE PRECISION DTEMP
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
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
    5   FORMAT('***** ERROR--THE REQUESTED NUMBER OF ',
     1         'BURR TYPE 4 RANDOM NUMBERS IS NON-POSITIVE')
   47   FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8)
      ELSEIF(R.LE.0.0)THEN
        WRITE(ICOUT,201)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,203)R
        CALL DPWRST('XXX','BUG ')
        GOTO9000
  201   FORMAT('***** ERROR--THE R SHAPE PARAMETER IS NON-POSITIVE.')
  203   FORMAT('      THE VALUE OF R IS ',G15.7)
      ELSEIF(C.LE.0.0)THEN
        WRITE(ICOUT,211)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,213)C
        CALL DPWRST('XXX','BUG ')
        GOTO9000
  211   FORMAT('***** ERROR--THE C SHAPE PARAMETER IS NON-POSITIVE.')
  213   FORMAT('      THE VALUE OF C IS ',G15.7)
      ENDIF
C
C     GENERATE N UNIFORM (0,1) RANDOM NUMBERS;
C
      CALL UNIRAN(N,ISEED,X)
C
C     GENERATE N SLOPE DISTRIBUTION RANDOM
C     NUMBERS USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD.
C
      DO300I=1,N
        CALL BU4PPF(DBLE(X(I)),DBLE(R),DBLE(C),DTEMP)
        X(I)=DBLE(DTEMP)
  300 CONTINUE
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE BU5CDF(DX,DR,DK,DCDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE BURR TYPE 5 DISTRIBTION.
C              THE CUMULATIVE DISTRIBUTION FUNCTION IS:
C
C              F(X;R,K) = (1 + K*EXP(-TAN(X)))**(-R)
C              -PI/2 <  X <  PI/2; R, K > 0
C
C              WITH SHAPE PARAMETERS R AND K.
C     INPUT  ARGUMENTS--DX     = THE DOUBLE PRECISION VALUE AT
C                                WHICH THE CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C                     --DR     = THE FIRST SHAPE PARAMETER
C                     --DK     = THE SECOND SHAPE PARAMETER
C     OUTPUT ARGUMENTS--DCDF   = THE DOUBLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION CUMULATIVE DISTRIBUTION
C             FUNCTION VALUE CDF FOR THE BURR TYPE 5 DISTRIBUTION
C             WITH SHAPE PARAMETERS R AND 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--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME I", SECOND EDITION,
C                 JOHN WILEY, 1994, PP. 53-54.
C               --LUC DEVROYE, "NON-UNIFORM RANDOM VARIATE
C                 GENERATION", 1986, SPRINGER-VERLANG, PP. 476-477.
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     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2007.10
C     ORIGINAL VERSION--OCTOBER   2007.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DCDF
      DOUBLE PRECISION DX
      DOUBLE PRECISION DR
      DOUBLE PRECISION DK
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DPI
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----DATA STATEMENTS-------------------------------------------------
C
      DATA DPI / 3.1415926535 8979323846 2643383279 503 D0 /
C
C-----START POINT-----------------------------------------------------
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      DCDF=0.0D0
C
      IF(DR.LE.0.0D0)THEN
        WRITE(ICOUT,115)
  115   FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO BU5CDF ',
     1         'IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,147)DR
  147   FORMAT('      THE VALUE OF THE ARGUMENT IS ',G15.7)
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(DK.LE.0.0D0)THEN
        WRITE(ICOUT,125)
  125   FORMAT('***** ERROR--THE THIRD INPUT ARGUMENT TO BU5CDF ',
     1         'IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,147)DK
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
C               **************************************************
C               **  STEP 2B-                                    **
C               **  COMPUTE BURR TYPE 5 CDF                     **
C               **************************************************
C
      DTERM1=DPI/2.0D0
      IF(DX.LE.-DTERM1)THEN
        DCDF=0.0D0
      ELSEIF(DX.GE.DTERM1)THEN
        DCDF=1.0D0
      ELSE
        DTERM2=DEXP(-DTAN(DX))
        DCDF=(1.0D0 + DK*DTERM2)**(-DR)
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE BU5PDF(DX,DR,DK,DPDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE BURR TYPE 5 DISTRIBTION.
C              THE PROBABILITY DENSITY FUNCTION IS:
C
C              f(X;R,K) = R*K*(1 + K/(EXP(TAN(X))**(-R-1)*SEC(X)**2/
C                         EXP(TAN(X))
C              X >  0; R, K > 0
C
C              WITH SHAPE PARAMETERS R AND K.
C     INPUT  ARGUMENTS--DX     = THE DOUBLE PRECISION VALUE AT
C                                WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C                     --DR     = THE FIRST SHAPE PARAMETER
C                     --DK     = THE SECOND SHAPE PARAMETER
C     OUTPUT ARGUMENTS--DPDF   = THE DOUBLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE PDF FOR THE BURR TYPE 5 DISTRIBUTION
C             WITH SHAPE PARAMETERS R AND 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, TAN, SEC.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME I", SECOND EDITION,
C                 JOHN WILEY, 1994, PP. 53-54.
C               --LUC DEVROYE, "NON-UNIFORM RANDOM VARIATE
C                 GENERATION", 1986, SPRINGER-VERLANG, PP. 476-477.
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     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2007.10
C     ORIGINAL VERSION--OCTOBER   2007.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DPDF
      DOUBLE PRECISION DX
      DOUBLE PRECISION DR
      DOUBLE PRECISION DK
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
      DOUBLE PRECISION DTERM4
      DOUBLE PRECISION DPI
      DOUBLE PRECISION DLIM
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----DATA STATEMENTS-------------------------------------------------
C
      DATA DPI / 3.1415926535 8979323846 2643383279 503 D0 /
C
C-----START POINT-----------------------------------------------------
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      DPDF=0.0D0
C
      DLIM=DPI/2.0D0
C
      IF(DX.LE.-DLIM .OR. DX.GE.DLIM)THEN
        WRITE(ICOUT,105)
  105   FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO BU5PDF ',
     1         'IS OUTSIDE THE (-PI/2,PI/2) INTERVAL.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,147)DX
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(DR.LE.0.0D0)THEN
        WRITE(ICOUT,115)
  115   FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO BU5PDF ',
     1         'IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,147)DR
  147   FORMAT('      THE VALUE OF THE ARGUMENT IS ',G15.7)
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(DK.LE.0.0D0)THEN
        WRITE(ICOUT,125)
  125   FORMAT('***** ERROR--THE THIRD INPUT ARGUMENT TO BU5PDF ',
     1         'IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,147)DK
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
C               **************************************************
C               **  STEP 2B-                                    **
C               **  COMPUTE BURR TYPE 5 PDF                     **
C               **************************************************
C
      DTERM1=DEXP(DTAN(DX))
      IF(DTERM1.NE.0.0D0)THEN
        DTERM2=1.0D0 + DK/DTERM1
      ELSE
        DPDF=0.0D0
        GOTO9000
      ENDIF
      DTERM3=1.0D0/DCOS(DX)
      DTERM4=DLOG(DR) + DLOG(DK) + (-DR-1.0D0)*DLOG(DTERM2) +
     1       2.0D0*DLOG(DTERM3)
      DPDF=DEXP(DTERM4 - DLOG(DTERM1))
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE BU5PPF(DP,DR,DK,DPPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE BURR TYPE 5 DISTRIBUTION.
C              THE PERCENT POINT FUNCTION IS:
C
C              G(P;R,K) = ARCTAN{-LOG((P**(-1/R) - 1)/K)}
C                         0 < P < 1; R, K > 0
C
C              WITH SHAPE PARAMETERS R AND K.
C     INPUT  ARGUMENTS--DP     = THE DOUBLE PRECISION VALUE AT
C                                WHICH THE PERCENT POINT
C                                FUNCTION IS TO BE EVALUATED.
C                     --DR     = THE FIRST SHAPE PARAMETER
C                     --DK     = THE SECOND SHAPE PARAMETER
C     OUTPUT ARGUMENTS--DPPF   = THE DOUBLE PRECISION PERCENT POINT
C                                FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION PERCENT POINT
C             FUNCTION VALUE PPF FOR THE BURR TYPE 5 DISTRIBUTION
C             WITH SHAPE PARAMETERS R AND 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--ARCTAN, LOG.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME I", SECOND EDITION,
C                 JOHN WILEY, 1994, PP. 53-54.
C               --LUC DEVROYE, "NON-UNIFORM RANDOM VARIATE
C                 GENERATION", 1986, SPRINGER-VERLANG, PP. 476-477.
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     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2007.10
C     ORIGINAL VERSION--OCTOBER   2007.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DPPF
      DOUBLE PRECISION DP
      DOUBLE PRECISION DR
      DOUBLE PRECISION DK
      DOUBLE PRECISION DTERM1
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----DATA STATEMENTS-------------------------------------------------
C
C-----START POINT-----------------------------------------------------
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      DPPF=0.0D0
C
      IF(DP.LE.0.0D0 .OR. DP.GE.1.0D0)THEN
        WRITE(ICOUT,105)
  105   FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO BU5PPF ',
     1         'IS OUTSIDE THE (0,1) INTERVAL.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,147)DP
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(DR.LE.0.0D0)THEN
        WRITE(ICOUT,115)
  115   FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO BU5PPF ',
     1         'IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,147)DR
  147   FORMAT('      THE VALUE OF THE ARGUMENT IS ',G15.7)
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(DK.LE.0.0D0)THEN
        WRITE(ICOUT,125)
  125   FORMAT('***** ERROR--THE THIRD INPUT ARGUMENT TO BU5PPF ',
     1         'IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,147)DK
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
C               **************************************************
C               **  STEP 2B-                                    **
C               **  COMPUTE BURR TYPE 5 PPF                     **
C               **************************************************
C
      DTERM1=(DP**(-1.0D0/DR) - 1.0D0)/DK
      DPPF=DATAN(-DLOG(DTERM1))
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE BU5RAN(N,R,AK,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE BURR TYPE 5 DISTRIBUTION WITH
C              SHAPE PARAMETERS R AND K.
C
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --R      = THE SINGLE PRECISION VALUE OF THE
C                                SHAPE PARAMETER R.
C                     --K      = THE SINGLE PRECISION VALUE OF THE
C                                SHAPE PARAMETER K.
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 BURR TYPE 5 DISTRIBUTION
C             WITH SHAPE PARAMETERS R 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     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN, BU5PPF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME I", SECOND EDITION,
C                 JOHN WILEY, 1994, PP. 53-54.
C               --LUC DEVROYE, "NON-UNIFORM RANDOM VARIATE
C                 GENERATION", 1986, SPRINGER-VERLANG, PP. 476-477.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHMOLOGY 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     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2007.10
C     ORIGINAL VERSION--OCTOBER   2007.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
C
      DOUBLE PRECISION DTEMP
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
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
    5   FORMAT('***** ERROR--THE REQUESTED NUMBER OF ',
     1         'BURR TYPE 5 RANDOM NUMBERS IS NON-POSITIVE')
   47   FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8)
      ELSEIF(R.LE.0.0)THEN
        WRITE(ICOUT,201)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,203)R
        CALL DPWRST('XXX','BUG ')
        GOTO9000
  201   FORMAT('***** ERROR--THE R SHAPE PARAMETER IS NON-POSITIVE.')
  203   FORMAT('      THE VALUE OF R IS ',G15.7)
      ELSEIF(AK.LE.0.0)THEN
        WRITE(ICOUT,211)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,213)AK
        CALL DPWRST('XXX','BUG ')
        GOTO9000
  211   FORMAT('***** ERROR--THE K SHAPE PARAMETER IS NON-POSITIVE.')
  213   FORMAT('      THE VALUE OF K IS ',G15.7)
      ENDIF
C
C     GENERATE N UNIFORM (0,1) RANDOM NUMBERS;
C
      CALL UNIRAN(N,ISEED,X)
C
C     GENERATE N SLOPE DISTRIBUTION RANDOM
C     NUMBERS USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD.
C
      DO300I=1,N
        CALL BU5PPF(DBLE(X(I)),DBLE(R),DBLE(AK),DTEMP)
        X(I)=DBLE(DTEMP)
  300 CONTINUE
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE BU6CDF(DX,DR,DK,DCDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE BURR TYPE 6 DISTRIBTION.
C              THE CUMULATIVE DISTRIBUTION FUNCTION IS:
C
C              F(X;R,K) = (1 + K*EXP(-SINH(X)))**(-R)
C              -INF <  X <  INF; R, K > 0
C
C              WITH SHAPE PARAMETERS R AND K.
C     INPUT  ARGUMENTS--DX     = THE DOUBLE PRECISION VALUE AT
C                                WHICH THE CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C                     --DR     = THE FIRST SHAPE PARAMETER
C                     --DK     = THE SECOND SHAPE PARAMETER
C     OUTPUT ARGUMENTS--DCDF   = THE DOUBLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION CUMULATIVE DISTRIBUTION
C             FUNCTION VALUE CDF FOR THE BURR TYPE 6 DISTRIBUTION
C             WITH SHAPE PARAMETERS R AND 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--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME I", SECOND EDITION,
C                 JOHN WILEY, 1994, PP. 53-54.
C               --LUC DEVROYE, "NON-UNIFORM RANDOM VARIATE
C                 GENERATION", 1986, SPRINGER-VERLANG, PP. 476-477.
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     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2007.10
C     ORIGINAL VERSION--OCTOBER   2007.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DCDF
      DOUBLE PRECISION DX
      DOUBLE PRECISION DR
      DOUBLE PRECISION DK
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----DATA STATEMENTS-------------------------------------------------
C
CCCCC DATA DPI / 3.1415926535 8979323846 2643383279 503 D0 /
C
C-----START POINT-----------------------------------------------------
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      DCDF=0.0D0
C
      IF(DR.LE.0.0D0)THEN
        WRITE(ICOUT,115)
  115   FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO BU6CDF ',
     1         'IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,147)DR
  147   FORMAT('      THE VALUE OF THE ARGUMENT IS ',G15.7)
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(DK.LE.0.0D0)THEN
        WRITE(ICOUT,125)
  125   FORMAT('***** ERROR--THE THIRD INPUT ARGUMENT TO BU6CDF ',
     1         'IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,147)DK
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
C               **************************************************
C               **  STEP 2B-                                    **
C               **  COMPUTE BURR TYPE 6 CDF                     **
C               **************************************************
C
      DTERM1=(DEXP(DX)-DEXP(-DX))/2.0D0
      DTERM2=DEXP(-DTERM1)
      DCDF=(1.0D0 + DK*DTERM2)**(-DR)
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE BU6PDF(DX,DR,DK,DPDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE BURR TYPE 6 DISTRIBTION.
C              THE PROBABILITY DENSITY FUNCTION IS:
C
C              f(X;R,K) = R*K*(1 + K/EXP(SINH(X)))**(-R-1)*COSH(X)/
C                         EXP(SINH(X))
C              -INF <  X <  INF; R, K > 0
C
C              WITH SHAPE PARAMETERS R AND K.
C     INPUT  ARGUMENTS--DX     = THE DOUBLE PRECISION VALUE AT
C                                WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C                     --DR     = THE FIRST SHAPE PARAMETER
C                     --DK     = THE SECOND SHAPE PARAMETER
C     OUTPUT ARGUMENTS--DPDF   = THE DOUBLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE PDF FOR THE BURR TYPE 6 DISTRIBUTION
C             WITH SHAPE PARAMETERS R AND 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--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME I", SECOND EDITION,
C                 JOHN WILEY, 1994, PP. 53-54.
C               --LUC DEVROYE, "NON-UNIFORM RANDOM VARIATE
C                 GENERATION", 1986, SPRINGER-VERLANG, PP. 476-477.
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     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2007.10
C     ORIGINAL VERSION--OCTOBER   2007.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DPDF
      DOUBLE PRECISION DX
      DOUBLE PRECISION DR
      DOUBLE PRECISION DK
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
      DOUBLE PRECISION DTERM4
      DOUBLE PRECISION DTERM5
      DOUBLE PRECISION DTERM6
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----DATA STATEMENTS-------------------------------------------------
C
CCCCC DATA DPI / 3.1415926535 8979323846 2643383279 503 D0 /
C
C-----START POINT-----------------------------------------------------
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      DPDF=0.0D0
C
      IF(DR.LE.0.0D0)THEN
        WRITE(ICOUT,115)
  115   FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO BU6PDF ',
     1         'IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,147)DR
  147   FORMAT('      THE VALUE OF THE ARGUMENT IS ',G15.7)
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(DK.LE.0.0D0)THEN
        WRITE(ICOUT,125)
  125   FORMAT('***** ERROR--THE THIRD INPUT ARGUMENT TO BU6PDF ',
     1         'IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,147)DK
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
C               **************************************************
C               **  STEP 2B-                                    **
C               **  COMPUTE BURR TYPE 6 PDF                     **
C               **************************************************
C
      DTERM1=(DEXP(DX)-DEXP(-DX))/2.0D0
      DTERM2=DEXP(DTERM1)
      DTERM3=(-DR-1.0D0)*DLOG(1.0D0 + DK/DTERM2)
      DTERM4=(DEXP(DX)+DEXP(-DX))/2.0D0
      DTERM5=DLOG(DTERM4)
      DTERM6=DLOG(DR) + DLOG(DK) + DTERM3 + DTERM5 - DTERM1
      DPDF=DEXP(DTERM6)
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE BU6PPF(DP,DR,DK,DPPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE BURR TYPE 6 DISTRIBUTION.
C              THE PERCENT POINT FUNCTION IS:
C
C              G(P;R,K) = ARCSINH{-LOG((P**(-1/R) - 1)/K)}
C                         0 < P < 1; R, K > 0
C
C              WITH SHAPE PARAMETERS R AND K.
C     INPUT  ARGUMENTS--DP     = THE DOUBLE PRECISION VALUE AT
C                                WHICH THE PERCENT POINT
C                                FUNCTION IS TO BE EVALUATED.
C                     --DR     = THE FIRST SHAPE PARAMETER
C                     --DK     = THE SECOND SHAPE PARAMETER
C     OUTPUT ARGUMENTS--DPPF   = THE DOUBLE PRECISION PERCENT POINT
C                                FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION PERCENT POINT
C             FUNCTION VALUE PPF FOR THE BURR TYPE 6 DISTRIBUTION
C             WITH SHAPE PARAMETERS R AND 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, LOG.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME I", SECOND EDITION,
C                 JOHN WILEY, 1994, PP. 53-54.
C               --LUC DEVROYE, "NON-UNIFORM RANDOM VARIATE
C                 GENERATION", 1986, SPRINGER-VERLANG, PP. 476-477.
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     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2007.10
C     ORIGINAL VERSION--OCTOBER   2007.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DPPF
      DOUBLE PRECISION DP
      DOUBLE PRECISION DR
      DOUBLE PRECISION DK
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----DATA STATEMENTS-------------------------------------------------
C
C-----START POINT-----------------------------------------------------
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      DPPF=0.0D0
C
      IF(DP.LE.0.0D0 .OR. DP.GE.1.0D0)THEN
        WRITE(ICOUT,105)
  105   FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO BU6PPF ',
     1         'IS OUTSIDE THE (0,1) INTERVAL.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,147)DP
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(DR.LE.0.0D0)THEN
        WRITE(ICOUT,115)
  115   FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO BU6PPF ',
     1         'IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,147)DR
  147   FORMAT('      THE VALUE OF THE ARGUMENT IS ',G15.7)
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(DK.LE.0.0D0)THEN
        WRITE(ICOUT,125)
  125   FORMAT('***** ERROR--THE THIRD INPUT ARGUMENT TO BU6PPF ',
     1         'IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,147)DK
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
C               **************************************************
C               **  STEP 2B-                                    **
C               **  COMPUTE BURR TYPE 6 PPF                     **
C               **************************************************
C
      DTERM1=(DP**(-1.0D0/DR) - 1.0D0)/DK
      DTERM2=-DLOG(DTERM1)
      DTERM3=DTERM2+DSQRT(DTERM2*DTERM2+1.0D0)
      DPPF=DLOG(DTERM3)
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE BU6RAN(N,R,AK,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE BURR TYPE 6 DISTRIBUTION WITH
C              SHAPE PARAMETERS R AND K.
C
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --R      = THE SINGLE PRECISION VALUE OF THE
C                                SHAPE PARAMETER R.
C                     --K      = THE SINGLE PRECISION VALUE OF THE
C                                SHAPE PARAMETER K.
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 BURR TYPE 6 DISTRIBUTION
C             WITH SHAPE PARAMETERS R 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     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN, BU6PPF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME I", SECOND EDITION,
C                 JOHN WILEY, 1994, PP. 53-54.
C               --LUC DEVROYE, "NON-UNIFORM RANDOM VARIATE
C                 GENERATION", 1986, SPRINGER-VERLANG, PP. 476-477.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHMOLOGY 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     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2007.10
C     ORIGINAL VERSION--OCTOBER   2007.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
C
      DOUBLE PRECISION DTEMP
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
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
    5   FORMAT('***** ERROR--THE REQUESTED NUMBER OF ',
     1         'BURR TYPE 6 RANDOM NUMBERS IS NON-POSITIVE')
   47   FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8)
      ELSEIF(R.LE.0.0)THEN
        WRITE(ICOUT,201)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,203)R
        CALL DPWRST('XXX','BUG ')
        GOTO9000
  201   FORMAT('***** ERROR--THE R SHAPE PARAMETER IS NON-POSITIVE.')
  203   FORMAT('      THE VALUE OF R IS ',G15.7)
      ELSEIF(AK.LE.0.0)THEN
        WRITE(ICOUT,211)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,213)AK
        CALL DPWRST('XXX','BUG ')
        GOTO9000
  211   FORMAT('***** ERROR--THE K SHAPE PARAMETER IS NON-POSITIVE.')
  213   FORMAT('      THE VALUE OF K IS ',G15.7)
      ENDIF
C
C     GENERATE N UNIFORM (0,1) RANDOM NUMBERS;
C
      CALL UNIRAN(N,ISEED,X)
C
C     GENERATE N SLOPE DISTRIBUTION RANDOM
C     NUMBERS USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD.
C
      DO300I=1,N
        CALL BU6PPF(DBLE(X(I)),DBLE(R),DBLE(AK),DTEMP)
        X(I)=DBLE(DTEMP)
  300 CONTINUE
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE BU7RAN(N,R,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE BURR TYPE 7 DISTRIBUTION WITH
C              SHAPE PARAMETER R.
C
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --R      = THE SINGLE PRECISION VALUE OF THE
C                                SHAPE PARAMETER R.
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 BURR TYPE 7 DISTRIBUTION
C             WITH SHAPE PARAMETER R.
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, BU7PPF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME I", SECOND EDITION,
C                 JOHN WILEY, 1994, PP. 53-54.
C               --LUC DEVROYE, "NON-UNIFORM RANDOM VARIATE
C                 GENERATION", 1986, SPRINGER-VERLANG, PP. 476-477.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHMOLOGY 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     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2007.10
C     ORIGINAL VERSION--OCTOBER   2007.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
C
      DOUBLE PRECISION DTEMP
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
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
    5   FORMAT('***** ERROR--THE REQUESTED NUMBER OF ',
     1         'BURR TYPE 7 RANDOM NUMBERS IS NON-POSITIVE')
   47   FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8)
      ELSEIF(R.LE.0.0)THEN
        WRITE(ICOUT,201)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,203)R
        CALL DPWRST('XXX','BUG ')
        GOTO9000
  201   FORMAT('***** ERROR--THE R SHAPE PARAMETER IS NON-POSITIVE.')
  203   FORMAT('      THE VALUE OF R IS ',G15.7)
      ENDIF
C
C     GENERATE N UNIFORM (0,1) RANDOM NUMBERS;
C
      CALL UNIRAN(N,ISEED,X)
C
C     GENERATE N SLOPE DISTRIBUTION RANDOM
C     NUMBERS USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD.
C
      DO300I=1,N
        CALL BU7PPF(DBLE(X(I)),DBLE(R),DTEMP)
        X(I)=DBLE(DTEMP)
  300 CONTINUE
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE BU7CDF(DX,DR,DCDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE BURR TYPE 7 DISTRIBTION.
C              THE CUMULATIVE DISTRIBUTION FUNCTION IS:
C
C              F(X;R) = 2**(-R)*(1+TANH(X))**R
C              -INF <  X <  INF; R > 0
C
C              WITH SHAPE PARAMETER R.
C     INPUT  ARGUMENTS--DX     = THE DOUBLE PRECISION VALUE AT
C                                WHICH THE CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C                     --DR     = THE SHAPE PARAMETER
C     OUTPUT ARGUMENTS--DCDF   = THE DOUBLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION CUMULATIVE DISTRIBUTION
C             FUNCTION VALUE CDF FOR THE BURR TYPE 7 DISTRIBUTION
C             WITH SHAPE PARAMETER R.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--TANH.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME I", SECOND EDITION,
C                 JOHN WILEY, 1994, PP. 53-54.
C               --LUC DEVROYE, "NON-UNIFORM RANDOM VARIATE
C                 GENERATION", 1986, SPRINGER-VERLANG, PP. 476-477.
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     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2007.10
C     ORIGINAL VERSION--OCTOBER   2007.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DCDF
      DOUBLE PRECISION DX
      DOUBLE PRECISION DR
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----DATA STATEMENTS-------------------------------------------------
C
C-----START POINT-----------------------------------------------------
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      DCDF=0.0D0
C
      IF(DR.LE.0.0D0)THEN
        WRITE(ICOUT,115)
  115   FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO BU7CDF ',
     1         'IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,147)DR
  147   FORMAT('      THE VALUE OF THE ARGUMENT IS ',G15.7)
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
C               **************************************************
C               **  STEP 2B-                                    **
C               **  COMPUTE BURR TYPE 7  CDF                    **
C               **************************************************
C
      IF(DX.GT.80.0D0)THEN
        DTERM1=1.0D0
      ELSEIF(DX.LT.-80.0D0)THEN
        DTERM1=-1.0D0
      ELSE
        DTERM1=(DEXP(DX)-DEXP(-DX))/(DEXP(DX)+DEXP(-DX))
      ENDIF
      DTERM2=(1.0D0 + DTERM1)**DR
      DCDF=(2.0D0**(-DR))*DTERM2
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE BU7PDF(DX,DR,DPDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE BURR TYPE 7 DISTRIBTION.
C              THE PROBABILITY DENSITY FUNCTION IS:
C
C              f(X;R) = R*SECH(x)**2*(1+TANH(X))**(R-1)/(2**R)
C              -INF <  X <  INF; R > 0
C
C              WITH SHAPE PARAMETER R.
C     INPUT  ARGUMENTS--DX     = THE DOUBLE PRECISION VALUE AT
C                                WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C                     --DR     = THE SHAPE PARAMETER
C     OUTPUT ARGUMENTS--DPDF   = THE DOUBLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE PDF FOR THE BURR TYPE 7 DISTRIBUTION
C             WITH SHAPE PARAMETER R.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--TANH, SECH.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME I", SECOND EDITION,
C                 JOHN WILEY, 1994, PP. 53-54.
C               --LUC DEVROYE, "NON-UNIFORM RANDOM VARIATE
C                 GENERATION", 1986, SPRINGER-VERLANG, PP. 476-477.
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     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2007.10
C     ORIGINAL VERSION--OCTOBER   2007.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DPDF
      DOUBLE PRECISION DX
      DOUBLE PRECISION DR
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
      DOUBLE PRECISION DTERM4
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----DATA STATEMENTS-------------------------------------------------
C
C-----START POINT-----------------------------------------------------
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      DPDF=0.0D0
C
      IF(DR.LE.0.0D0)THEN
        WRITE(ICOUT,115)
  115   FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO BU7PDF ',
     1         'IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,147)DR
  147   FORMAT('      THE VALUE OF THE ARGUMENT IS ',G15.7)
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
C               **************************************************
C               **  STEP 2B-                                    **
C               **  COMPUTE BURR TYPE 7  PDF                    **
C               **************************************************
C
      DTERM1=2.0D0/(DEXP(DX)+DEXP(-DX))
      DTERM2=(DEXP(DX)-DEXP(-DX))/(DEXP(DX)+DEXP(-DX))
      DTERM3=DLOG(DR) + 2.0D0*DLOG(DTERM1) +
     1       (DR-1.0D0)*DLOG(1.0D0 + DTERM2)
      DTERM4=DR*DLOG(2.0D0)
      DPDF=DEXP(DTERM3 - DTERM4)
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE BU7PPF(DP,DR,DPPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE BURR TYPE 7 DISTRIBUTION.
C              THE PERCENT POINT FUNCTION IS:
C
C              G(P;R) = ARCTANH((2**R*P)**(1/R) - 1)
C                       0 < P < 1; R > 0
C
C              WITH SHAPE PARAMETER R.
C     INPUT  ARGUMENTS--DP     = THE DOUBLE PRECISION VALUE AT
C                                WHICH THE PERCENT POINT
C                                FUNCTION IS TO BE EVALUATED.
C                     --DR     = THE SHAPE PARAMETER
C     OUTPUT ARGUMENTS--DPPF   = THE DOUBLE PRECISION PERCENT POINT
C                                FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION PERCENT POINT
C             FUNCTION VALUE PPF FOR THE BURR TYPE 7 DISTRIBUTION
C             WITH SHAPE PARAMETER R.
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--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME I", SECOND EDITION,
C                 JOHN WILEY, 1994, PP. 53-54.
C               --LUC DEVROYE, "NON-UNIFORM RANDOM VARIATE
C                 GENERATION", 1986, SPRINGER-VERLANG, PP. 476-477.
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     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2007.10
C     ORIGINAL VERSION--OCTOBER   2007.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DPPF
      DOUBLE PRECISION DP
      DOUBLE PRECISION DR
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----DATA STATEMENTS-------------------------------------------------
C
C-----START POINT-----------------------------------------------------
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      DPPF=0.0D0
C
      IF(DP.LE.0.0D0 .OR. DP.GE.1.0D0)THEN
        WRITE(ICOUT,105)
  105   FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO BU7PPF ',
     1         'IS OUTSIDE THE (0,1) INTERVAL.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,147)DP
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(DR.LE.0.0D0)THEN
        WRITE(ICOUT,115)
  115   FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO BU7PPF ',
     1         'IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,147)DR
  147   FORMAT('      THE VALUE OF THE ARGUMENT IS ',G15.7)
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
C               **************************************************
C               **  STEP 2B-                                    **
C               **  COMPUTE BURR TYPE 7 PPF                     **
C               **************************************************
C
      DTERM1=((2.0D0**DR)*DP)**(1.0D0/DR) - 1.0D0
      IF(DTERM1.GE.1.0D0 .OR. DTERM1.LE.-1.0D0)THEN
        WRITE(ICOUT,125)
  125   FORMAT('***** ERROR IN BU7PPF--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,126)
  126   FORMAT('      ATTEMPT TO TAKE ARCTANH OF A NUMBER ',
     1         '>= 1 OR <= -1')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,127)
  127   FORMAT('      THIS CAN HAPPEN IF BOTH ARGUMENTS ARE ',
     1         'SUFFICIENT SMALL')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,128)DP
  128   FORMAT('      THE VALUE OF THE FIRST ARGUMENT IS ',G15.7)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,129)DR
  129   FORMAT('      THE VALUE OF THE SECOND ARGUMENT IS ',G15.7)
        CALL DPWRST('XXX','BUG ')
      ELSE
        DTERM2=(1.0D0 + DTERM1)/(1.0D0 - DTERM1)
        DPPF=0.5D0*DLOG(DTERM2)
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE BU8CDF(DX,DR,DCDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE BURR TYPE 8 DISTRIBTION.
C              THE CUMULATIVE DISTRIBUTION FUNCTION IS:
C
C              F(X;R) = ((2/PI)*ARCTAN(EXP(X)))**R
C              -INF <  X <  INF; R > 0
C
C              WITH SHAPE PARAMETER R.
C     INPUT  ARGUMENTS--DX     = THE DOUBLE PRECISION VALUE AT
C                                WHICH THE CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C                     --DR     = THE SHAPE PARAMETER
C     OUTPUT ARGUMENTS--DCDF   = THE DOUBLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION CUMULATIVE DISTRIBUTION
C             FUNCTION VALUE CDF FOR THE BURR TYPE 8 DISTRIBUTION
C             WITH SHAPE PARAMETER R.
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, ARCTAN.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME I", SECOND EDITION,
C                 JOHN WILEY, 1994, PP. 53-54.
C               --LUC DEVROYE, "NON-UNIFORM RANDOM VARIATE
C                 GENERATION", 1986, SPRINGER-VERLANG, PP. 476-477.
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     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2007.10
C     ORIGINAL VERSION--OCTOBER   2007.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DCDF
      DOUBLE PRECISION DX
      DOUBLE PRECISION DR
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DPI
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----DATA STATEMENTS-------------------------------------------------
C
      DATA DPI / 3.1415926535 8979323846 2643383279 503 D0 /
C
C-----START POINT-----------------------------------------------------
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      DCDF=0.0D0
C
      IF(DR.LE.0.0D0)THEN
        WRITE(ICOUT,115)
  115   FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO BU8CDF ',
     1         'IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,147)DR
  147   FORMAT('      THE VALUE OF THE ARGUMENT IS ',G15.7)
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
C               **************************************************
C               **  STEP 2B-                                    **
C               **  COMPUTE BURR TYPE 8  CDF                    **
C               **************************************************
C
      DTERM1=DEXP(DX)
      DTERM2=DATAN(DTERM1)
      DCDF=((2.0D0/DPI)*DTERM2)**DR
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE BU8PDF(DX,DR,DPDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE BURR TYPE 8 DISTRIBTION.
C              THE PROBABILITY DENSITY FUNCTION IS:
C
C              f(X;R) = R*EXP(X)*(2/PI)**R*ARCTAN(EXP(X))**(R-1)/
C                       (1 + EXP(2*X))
C              -INF <  X <  INF; R > 0
C
C              WITH SHAPE PARAMETER R.
C     INPUT  ARGUMENTS--DX     = THE DOUBLE PRECISION VALUE AT
C                                WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C                     --DR     = THE SHAPE PARAMETER
C     OUTPUT ARGUMENTS--DPDF   = THE DOUBLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE PDF FOR THE BURR TYPE 8 DISTRIBUTION
C             WITH SHAPE PARAMETER R.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--ARCTAN, EXP.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME I", SECOND EDITION,
C                 JOHN WILEY, 1994, PP. 53-54.
C               --LUC DEVROYE, "NON-UNIFORM RANDOM VARIATE
C                 GENERATION", 1986, SPRINGER-VERLANG, PP. 476-477.
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     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2007.10
C     ORIGINAL VERSION--OCTOBER   2007.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DPDF
      DOUBLE PRECISION DX
      DOUBLE PRECISION DR
      DOUBLE PRECISION DPI
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----DATA STATEMENTS-------------------------------------------------
C
      DATA DPI / 3.1415926535 8979323846 2643383279 503 D0 /
C
C-----START POINT-----------------------------------------------------
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      DPDF=0.0D0
C
      IF(DR.LE.0.0D0)THEN
        WRITE(ICOUT,115)
  115   FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO BU8PDF ',
     1         'IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,147)DR
  147   FORMAT('      THE VALUE OF THE ARGUMENT IS ',G15.7)
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
C               **************************************************
C               **  STEP 2B-                                    **
C               **  COMPUTE BURR TYPE 8  PDF                    **
C               **************************************************
C
      DTERM1=DATAN(DEXP(DX))
      DTERM2=DLOG(DR) + DX + DR*DLOG(2.0D0/DPI) +
     1       (DR-1.0D0)*DLOG(DTERM1)
      DTERM3=DLOG(1.0D0 + DEXP(2.0D0*DX))
      DPDF=DEXP(DTERM2 - DTERM3)
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE BU8PPF(DP,DR,DPPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE BURR TYPE 8 DISTRIBUTION.
C              THE PERCENT POINT FUNCTION IS:
C
C              G(P;R) = LOG(TAN(PI*P**(1/R)/2))
C                       0 < P < 1; R > 0
C
C              WITH SHAPE PARAMETER R.
C     INPUT  ARGUMENTS--DP     = THE DOUBLE PRECISION VALUE AT
C                                WHICH THE PERCENT POINT
C                                FUNCTION IS TO BE EVALUATED.
C                     --DR     = THE SHAPE PARAMETER
C     OUTPUT ARGUMENTS--DPPF   = THE DOUBLE PRECISION PERCENT POINT
C                                FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION PERCENT POINT
C             FUNCTION VALUE PPF FOR THE BURR TYPE 8 DISTRIBUTION
C             WITH SHAPE PARAMETER R.
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--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME I", SECOND EDITION,
C                 JOHN WILEY, 1994, PP. 53-54.
C               --LUC DEVROYE, "NON-UNIFORM RANDOM VARIATE
C                 GENERATION", 1986, SPRINGER-VERLANG, PP. 476-477.
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     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2007.10
C     ORIGINAL VERSION--OCTOBER   2007.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DPPF
      DOUBLE PRECISION DP
      DOUBLE PRECISION DR
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DPI
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----DATA STATEMENTS-------------------------------------------------
C
      DATA DPI / 3.1415926535 8979323846 2643383279 503 D0 /
C
C-----START POINT-----------------------------------------------------
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      DPPF=0.0D0
C
      IF(DP.LE.0.0D0 .OR. DP.GE.1.0D0)THEN
        WRITE(ICOUT,105)
  105   FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO BU8PPF ',
     1         'IS OUTSIDE THE (0,1) INTERVAL.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,147)DP
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(DR.LE.0.0D0)THEN
        WRITE(ICOUT,115)
  115   FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO BU8PPF ',
     1         'IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,147)DR
  147   FORMAT('      THE VALUE OF THE ARGUMENT IS ',G15.7)
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
C               **************************************************
C               **  STEP 2B-                                    **
C               **  COMPUTE BURR TYPE 8 PPF                     **
C               **************************************************
C
      DTERM1=DPI*(DP**(1.0D0/DR))
      DTERM2=DTAN(DTERM1/2.0D0)
      DPPF=DLOG(DTERM2)
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE BU8RAN(N,R,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE BURR TYYPE 8 DISTRIBUTION WITH
C              SHAPE PARAMETER R.
C
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --R      = THE SINGLE PRECISION VALUE OF THE
C                                SHAPE PARAMETER R.
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 BURR TYYPE 8 DISTRIBUTION
C             WITH SHAPE PARAMETER R.
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, BU8PPF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME I", SECOND EDITION,
C                 JOHN WILEY, 1994, PP. 53-54.
C               --LUC DEVROYE, "NON-UNIFORM RANDOM VARIATE
C                 GENERATION", 1986, SPRINGER-VERLANG, PP. 476-477.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHMOLOGY 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     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2007.10
C     ORIGINAL VERSION--OCTOBER   2007.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
C
      DOUBLE PRECISION DTEMP
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
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
    5   FORMAT('***** ERROR--THE REQUESTED NUMBER OF ',
     1         'BURR TYYPE 8 RANDOM NUMBERS IS NON-POSITIVE')
   47   FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8)
      ELSEIF(R.LE.0.0)THEN
        WRITE(ICOUT,201)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,203)R
        CALL DPWRST('XXX','BUG ')
        GOTO9000
  201   FORMAT('***** ERROR--THE R SHAPE PARAMETER IS NON-POSITIVE.')
  203   FORMAT('      THE VALUE OF R IS ',G15.7)
      ENDIF
C
C     GENERATE N UNIFORM (0,1) RANDOM NUMBERS;
C
      CALL UNIRAN(N,ISEED,X)
C
C     GENERATE N SLOPE DISTRIBUTION RANDOM
C     NUMBERS USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD.
C
      DO300I=1,N
        CALL BU8PPF(DBLE(X(I)),DBLE(R),DTEMP)
        X(I)=DBLE(DTEMP)
  300 CONTINUE
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE BU9CDF(DX,DR,DK,DCDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE BURR TYPE 9 DISTRIBTION.
C              THE CUMULATIVE DISTRIBUTION FUNCTION IS:
C
C              F(X;R,K) = 1 - 2/{2 + K*((1+EXP(X))**R - 1)}
C                         -INF <  X <  INF; R, K > 0
C
C              WITH SHAPE PARAMETERS R AND K.
C     INPUT  ARGUMENTS--DX     = THE DOUBLE PRECISION VALUE AT
C                                WHICH THE CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C                     --DR     = THE FIRST SHAPE PARAMETER
C                     --DK     = THE SECOND SHAPE PARAMETER
C     OUTPUT ARGUMENTS--DCDF   = THE DOUBLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION CUMULATIVE DISTRIBUTION
C             FUNCTION VALUE CDF FOR THE BURR TYPE 9 DISTRIBUTION
C             WITH SHAPE PARAMETERS R AND 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--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME I", SECOND EDITION,
C                 JOHN WILEY, 1994, PP. 53-54.
C               --LUC DEVROYE, "NON-UNIFORM RANDOM VARIATE
C                 GENERATION", 1986, SPRINGER-VERLANG, PP. 476-477.
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     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2007.10
C     ORIGINAL VERSION--OCTOBER   2007.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DCDF
      DOUBLE PRECISION DX
      DOUBLE PRECISION DR
      DOUBLE PRECISION DK
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----DATA STATEMENTS-------------------------------------------------
C
C-----START POINT-----------------------------------------------------
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      DCDF=0.0D0
C
      IF(DR.LE.0.0D0)THEN
        WRITE(ICOUT,115)
  115   FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO BU9CDF ',
     1         'IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,147)DR
  147   FORMAT('      THE VALUE OF THE ARGUMENT IS ',G15.7)
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(DK.LE.0.0D0)THEN
        WRITE(ICOUT,125)
  125   FORMAT('***** ERROR--THE THIRD INPUT ARGUMENT TO BU9CDF ',
     1         'IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,147)DK
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
C               **************************************************
C               **  STEP 2B-                                    **
C               **  COMPUTE BURR TYPE 9 CDF                     **
C               **************************************************
C
      DTERM1=(1.0D0 + DEXP(DX))**DR
      DTERM2=2.0D0 + DK*(DTERM1 - 1.0D0)
      DCDF=1.0D0 - 2.0D0/DTERM2
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE BU9PDF(DX,DR,DK,DPDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE BURR TYPE 9 DISTRIBTION.
C              THE PROBABILITY DENSITY FUNCTION IS:
C
C              f(X;R,K) = 2*EXP(X)*(1+EXP(X))**(R-1)*K*R/
C                         (2+(-1+(1+EXP(X))**R)K)**2
C                         -INF <  X <  INF; R, K > 0
C
C              WITH SHAPE PARAMETERS R AND K.
C     INPUT  ARGUMENTS--DX     = THE DOUBLE PRECISION VALUE AT
C                                WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C                     --DR     = THE FIRST SHAPE PARAMETER
C                     --DK     = THE SECOND SHAPE PARAMETER
C     OUTPUT ARGUMENTS--DPDF   = THE DOUBLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE PDF FOR THE BURR TYPE 9 DISTRIBUTION
C             WITH SHAPE PARAMETERS R AND 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--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME I", SECOND EDITION,
C                 JOHN WILEY, 1994, PP. 53-54.
C               --LUC DEVROYE, "NON-UNIFORM RANDOM VARIATE
C                 GENERATION", 1986, SPRINGER-VERLANG, PP. 476-477.
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     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2007.10
C     ORIGINAL VERSION--OCTOBER   2007.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DPDF
      DOUBLE PRECISION DX
      DOUBLE PRECISION DR
      DOUBLE PRECISION DK
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
      DOUBLE PRECISION DTERM4
      DOUBLE PRECISION DTERM5
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----DATA STATEMENTS-------------------------------------------------
C
C-----START POINT-----------------------------------------------------
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      DPDF=0.0D0
C
      IF(DR.LE.0.0D0)THEN
        WRITE(ICOUT,115)
  115   FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO BU9PDF ',
     1         'IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,147)DR
  147   FORMAT('      THE VALUE OF THE ARGUMENT IS ',G15.7)
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(DK.LE.0.0D0)THEN
        WRITE(ICOUT,125)
  125   FORMAT('***** ERROR--THE THIRD INPUT ARGUMENT TO BU9PDF ',
     1         'IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,147)DK
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
C               **************************************************
C               **  STEP 2B-                                    **
C               **  COMPUTE BURR TYPE 9 PDF                     **
C               **************************************************
C
      DTERM1=DLOG(2.0D0) + DLOG(DK) + DLOG(DR) + DX
      DTERM2=(DR-1.0D0)*DLOG(1.0D0 + DEXP(DX))
      DTERM3=(1.0D0 + DEXP(DX))**DR
      DTERM4=2.0D0 + DK*(-1.0D0 + DTERM3)
      DTERM5=2.0D0*DLOG(DTERM4)
      DPDF=DEXP(DTERM1 + DTERM2 - DTERM5)
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE BU9PPF(DP,DR,DK,DPPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE BURR TYPE 9 DISTRIBUTION.
C              THE PERCENT POINT FUNCTION IS:
C
C              G(P;R,K) = LOG{[1 + (1/K)*(2/(1-P) - 2)]**(1/R) - 1}
C                         0 < P < 1; R, K > 0
C
C              WITH SHAPE PARAMETERS R AND K.
C     INPUT  ARGUMENTS--DP     = THE DOUBLE PRECISION VALUE AT
C                                WHICH THE PERCENT POINT
C                                FUNCTION IS TO BE EVALUATED.
C                     --DR     = THE FIRST SHAPE PARAMETER
C                     --DK     = THE SECOND SHAPE PARAMETER
C     OUTPUT ARGUMENTS--DPPF   = THE DOUBLE PRECISION PERCENT POINT
C                                FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION PERCENT POINT
C             FUNCTION VALUE PPF FOR THE BURR TYPE 9 DISTRIBUTION
C             WITH SHAPE PARAMETERS R AND 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--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME I", SECOND EDITION,
C                 JOHN WILEY, 1994, PP. 53-54.
C               --LUC DEVROYE, "NON-UNIFORM RANDOM VARIATE
C                 GENERATION", 1986, SPRINGER-VERLANG, PP. 476-477.
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     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2007.10
C     ORIGINAL VERSION--OCTOBER   2007.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DPPF
      DOUBLE PRECISION DP
      DOUBLE PRECISION DR
      DOUBLE PRECISION DK
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----DATA STATEMENTS-------------------------------------------------
C
C-----START POINT-----------------------------------------------------
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      DPPF=0.0D0
C
      IF(DP.LE.0.0D0 .OR. DP.GE.1.0D0)THEN
        WRITE(ICOUT,105)
  105   FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO BU9PPF ',
     1         'IS OUTSIDE THE (0,1) INTERVAL.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,147)DP
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(DR.LE.0.0D0)THEN
        WRITE(ICOUT,115)
  115   FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO BU9PPF ',
     1         'IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,147)DR
  147   FORMAT('      THE VALUE OF THE ARGUMENT IS ',G15.7)
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(DK.LE.0.0D0)THEN
        WRITE(ICOUT,125)
  125   FORMAT('***** ERROR--THE THIRD INPUT ARGUMENT TO BU9PPF ',
     1         'IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,147)DK
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
C               **************************************************
C               **  STEP 2B-                                    **
C               **  COMPUTE BURR TYPE 9 PPF                     **
C               **************************************************
C
      DTERM1=1.0D0 + (1.0D0/DK)*(2.0D0/(1.0D0-DP) - 2.0D0)
      DTERM2=DTERM1**(1.0D0/DR)
      DPPF=DLOG(DTERM2 - 1.0D0)
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE BU9RAN(N,R,AK,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE BURR TYPE 9 DISTRIBUTION WITH
C              SHAPE PARAMETERS R AND K.
C
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --R      = THE SINGLE PRECISION VALUE OF THE
C                                SHAPE PARAMETER R.
C                     --AK     = THE SINGLE PRECISION VALUE OF THE
C                                SHAPE PARAMETER K.
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 BURR TYPE 9 DISTRIBUTION
C             WITH SHAPE PARAMETERS R 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     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN, BU9PPF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME I", SECOND EDITION,
C                 JOHN WILEY, 1994, PP. 53-54.
C               --LUC DEVROYE, "NON-UNIFORM RANDOM VARIATE
C                 GENERATION", 1986, SPRINGER-VERLANG, PP. 476-477.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHMOLOGY 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     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2007.10
C     ORIGINAL VERSION--OCTOBER   2007.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
C
      DOUBLE PRECISION DTEMP
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
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
    5   FORMAT('***** ERROR--THE REQUESTED NUMBER OF ',
     1         'BURR TYPE 9 RANDOM NUMBERS IS NON-POSITIVE')
   47   FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8)
      ELSEIF(R.LE.0.0)THEN
        WRITE(ICOUT,201)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,203)R
        CALL DPWRST('XXX','BUG ')
        GOTO9000
  201   FORMAT('***** ERROR--THE R SHAPE PARAMETER IS NON-POSITIVE.')
  203   FORMAT('      THE VALUE OF R IS ',G15.7)
      ELSEIF(AK.LE.0.0)THEN
        WRITE(ICOUT,211)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,213)AK
        CALL DPWRST('XXX','BUG ')
        GOTO9000
  211   FORMAT('***** ERROR--THE K SHAPE PARAMETER IS NON-POSITIVE.')
  213   FORMAT('      THE VALUE OF K IS ',G15.7)
      ENDIF
C
C     GENERATE N UNIFORM (0,1) RANDOM NUMBERS;
C
      CALL UNIRAN(N,ISEED,X)
C
C     GENERATE N SLOPE DISTRIBUTION RANDOM
C     NUMBERS USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD.
C
      DO300I=1,N
        CALL BU9PPF(DBLE(X(I)),DBLE(R),DBLE(AK),DTEMP)
        X(I)=DBLE(DTEMP)
  300 CONTINUE
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE B10CDF(DX,DR,DCDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE BURR TYPE 10 DISTRIBTION.
C              THE CUMULATIVE DISTRIBUTION FUNCTION IS:
C
C              F(X;R) = (1 - EXP(-X**2))**R   X >  0; R > 0
C
C              WITH SHAPE PARAMETER R.
C     INPUT  ARGUMENTS--DX     = THE DOUBLE PRECISION VALUE AT
C                                WHICH THE CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C                     --DR     = THE SHAPE PARAMETER
C     OUTPUT ARGUMENTS--DCDF   = THE DOUBLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION CUMULATIVE DISTRIBUTION
C             FUNCTION VALUE CDF FOR THE BURR TYPE 10 DISTRIBUTION
C             WITH SHAPE PARAMETER R.
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--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME I", SECOND EDITION,
C                 JOHN WILEY, 1994, PP. 53-54.
C               --LUC DEVROYE, "NON-UNIFORM RANDOM VARIATE
C                 GENERATION", 1986, SPRINGER-VERLANG, PP. 476-477.
C                 (NOTE: THERE IS A TYPO IN THE DEVROYE CDF EQUATION,
C                 CORRECT FORM TAKEN FROM JOHNSON AND KOTZ).
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     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2007.10
C     ORIGINAL VERSION--OCTOBER   2007.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DCDF
      DOUBLE PRECISION DX
      DOUBLE PRECISION DR
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----DATA STATEMENTS-------------------------------------------------
C
C-----START POINT-----------------------------------------------------
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      DCDF=0.0D0
C
      IF(DR.LE.0.0D0)THEN
        WRITE(ICOUT,115)
  115   FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO B10CDF ',
     1         'IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,147)DR
  147   FORMAT('      THE VALUE OF THE ARGUMENT IS ',G15.7)
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
C               **************************************************
C               **  STEP 2B-                                    **
C               **  COMPUTE BURR TYPE 10 CDF                    **
C               **************************************************
C
      DCDF=(1.0D0 - DEXP(-DX**2))**DR
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE B10FUN (N, X, FVEC, IFLAG, XDATA, NOBS)
C
C     PURPOSE--THIS ROUTINE COMPUTES THE FUNCTIONS FOR THE
C              BURR TYPE 10 MAXIMUM LIKELIHOOD EQUATIONS.
C
C              (N/R) + SUM[i=1 to N][LN(1 - EXP(-(S*X(i))**2) = 0
C
C              (2*N/S) - 2*S*SUM[i=1 to n][X(i)**2] +
C              2*S*(R-1)*SUM[i=1 tp n][X(i)^2*EXP(-(S*X(i))**2)/
C              1 - EXP(-(S*X(i))**2))] = 0
C
C              WITH R AND S DENOTING THE SHAPE PARAMETER R AND
C              SCALE PARAMETER S RESPECTIVELY.
C
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--BURR TYPE 10 MAXIMUM LIKELIHOOD Y
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME I", SECOND EDITION,
C                 JOHN WILEY, 1994, PP. 53-54.
C               --LUC DEVROYE, "NON-UNIFORM RANDOM VARIATE
C                 GENERATION", 1986, SPRINGER-VERLANG, PP. 476-477.
C                 (NOTE: THERE IS A TYPO IN THE DEVROYE CDF EQUATION,
C                 CORRECT FORM TAKEN FROM JOHNSON AND KOTZ).
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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2007/10
C     ORIGINAL VERSION--OCTOBER   2007.
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION X(*)
      DOUBLE PRECISION FVEC(*)
      REAL XDATA(*)
C
      DOUBLE PRECISION DN
      DOUBLE PRECISION DX
      DOUBLE PRECISION DX2
      DOUBLE PRECISION DX3
      DOUBLE PRECISION DR
      DOUBLE PRECISION DS
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DSUM2
      DOUBLE PRECISION DSUM3
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
      DOUBLE PRECISION DTERM4
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C  COMPUTE SOME SUMS
C
      N=2
      IFLAG=0
C
      DN=DBLE(NOBS)
      DR=X(1)
      DS=X(2)
      DTERM1=DN/DR
      DTERM2=2.0D0*DN/DS
      DTERM3=2.0D0*DS
      DTERM4=2.0D0*DS*(DR-1.0D0)
C
      DSUM1=0.0D0
      DSUM2=0.0D0
      DSUM3=0.0D0
C
      DO200I=1,NOBS
        DX=DBLE(XDATA(I))
        DX2=DX**2
        DX3=DEXP(-(DS*DX)**2)
        DSUM1=DSUM1 + DLOG(1.0D0 - DX3)
        DSUM2=DSUM2 + DX2
        DSUM3=DSUM3 + DX2*DX3/(1.0D0 - DX3)
  200 CONTINUE
C
      FVEC(1)=DTERM1 + DSUM1
      FVEC(2)=DTERM2 - DTERM3*DSUM2 + DTERM4*DSUM3
C
      RETURN
      END
      SUBROUTINE B10LI1(Y,N,ICASPL,ALOC,SCALE,SHAPE,
     1                  ALIK,AIC,AICC,BIC,
     1                  ISUBRO,IBUGA3,IERROR)
C
C     PURPOSE--THIS ROUTINE COMPUTES THE LOG-LIKELIHOOD FUNCTION FOR
C              THE BURR TYPE 10 DISTRIBUTION.  THIS IS FOR THE RAW DATA
C              CASE (I.E., NO GROUPING AND NO CENSORING).
C
C              IT IS ASSUMED THAT BASIC ERROR CHECKING HAS ALREADY BEEN
C              PERFORMED.
C
C     REFERENCE--KUNDU AND RAQAB, "GENERALIZED RAYLEIGH DISTRIBUTION:
C                METHODS OF ESTIMATION", COMPUTATIONAL STATISTICS
C                AND DATA ANALYSIS, 49, PP. 187-200.
C     WRITTEN BY--ALAN HECKERT
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     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2011/4
C     ORIGINAL VERSION--APRIL     2010.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 ICASPL
      CHARACTER*4 ISUBRO
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 IWRITE
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 ISTEPN
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DS
      DOUBLE PRECISION DU
      DOUBLE PRECISION DR
      DOUBLE PRECISION DN
      DOUBLE PRECISION DNP
      DOUBLE PRECISION DLIK
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DSUM2
      DOUBLE PRECISION DSUM3
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
C
C---------------------------------------------------------------------
C
      DIMENSION Y(*)
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='B10L'
      ISUBN2='I1  '
C
      IERROR='NO'
C
      ALIK=-99.0
      AIC=-99.0
      AICC=-99.0
      BIC=-99.0
C
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'0LI1')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,51)
   51   FORMAT('**** AT THE BEGINNING OF B10LI1--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,52)IBUGA3,ISUBRO
   52   FORMAT('IBUGA3,ISUBRO = ',A4,2X,A4)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,55)N,ALOC,SCALE,SHAPE
   55   FORMAT('N,ALOC,SCALE,SHAPE = ',I8,3G15.7)
        CALL DPWRST('XXX','WRIT')
        DO56I=1,MIN(N,100)
          WRITE(ICOUT,57)I,Y(I)
   57     FORMAT('I,Y(I) = ',I8,G15.7)
          CALL DPWRST('XXX','WRIT')
   56   CONTINUE
      ENDIF
C
C               ******************************************
C               **  STEP 1--                            **
C               **  COMPUTE LIKELIHOOD FUNCTION         **
C               ******************************************
C
      ISTEPN='1'
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'0LI1')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IERFLG=0
      IERROR='NO'
      IWRITE='OFF'
      IF(ICASPL.EQ.'3B10')ALOC=0.0
C
C     LOG-LIKELIHOOD FUNCTION IS:
C
C     N*LOG(2) + N*LOG(R) - 2*N*LOG(S) + SUM[i=1 to N][LOG(X(i) - L)] +
C     (R-1)*SUM[i=1 to N][1 - EXP(-((X(i)-L)/S)**2)] -
C     SUM[i=1 to N][((X(i)-L)/S)**2]
C
C     WITH R, L, AND S DENOTING THE SHAPE, LOCATION, AND SCALE
C     PARAMETERS, RESPECTIVELY.
C
      DN=DBLE(N)
      DS=DBLE(1.0/SCALE)
      DU=DBLE(ALOC)
      DR=DBLE(SHAPE)
C
      DTERM1=DN*DLOG(2.0D0) + DN*DLOG(DR) + 2.0D0*DN*DLOG(DS)
      DSUM1=0.0D0
      DSUM2=0.0D0
      DSUM3=0.0D0
      DO1000I=1,N
        DX=DBLE(Y(I))
        DX=DX-DU
        IF(DX.GT.0.0D0)THEN
          DSUM1=DSUM1 + DLOG(DX)
        ENDIF
        DSUM2=DSUM2 + DX**2
        DTERM2=1.0D0 - DEXP(-(DS*DX)**2)
        IF(DTERM2.GE.0.0D0)THEN
          DSUM3=DSUM3 + DLOG(DTERM2)
        ENDIF
 1000 CONTINUE
C
      DLIK=DTERM1 + DSUM1 - DS**2*DSUM2 + (DR-1.0D0)*DSUM3
      ALIK=REAL(DLIK)
      DNP=2.0D0
      IF(ICASPL.EQ.'3B10')DNP=3.0
      AIC=REAL(-2.0D0*DLIK + 2.0D0*DNP)
      DTERM3=(2.0D0*DNP*(DNP+1.0D0))/(DN-DNP-1.0D0)
      AICC=REAL(-2.0D0*DLIK + 2.0D0*DNP + DTERM3)
      BIC=REAL(-2.0D0*DLIK + DNP*LOG(DN))
C
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'0LI1')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9011)
 9011   FORMAT('**** AT THE END OF B10LI1--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9013)DSUM1,DSUM2,DSUM3,DTERM1,DTERM2
 9013   FORMAT('DSUM1,DSUM2,DSUM3,DTERM1,DTERM2 = ',5G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9014)ALIK,AIC,AICC,BIC
 9014   FORMAT('ALIK,AIC,AICC,BIC = ',4G15.7)
        CALL DPWRST('XXX','WRIT')
      ENDIF
C
      RETURN
      END
      SUBROUTINE B10ML1(Y,N,MAXNXT,
     1                  TEMP1,TEMP2,DISPAR,DTEMP1,
     1                  XMEAN,XSD,XVAR,XMIN,XMAX,
     1                  SCALSV,SHAPSV,SCALML,SHAPML,
     1                  ISUBRO,IBUGA3,IERROR)
C
C     PURPOSE--THIS ROUTINE COMPUTES THE MAXIMUM LIKELIHOOD ESTIMATES
C              FOR THE 2-PARAMETER BURR TYPE 10 DISTRIBUTION FOR THE RAW
C              DATA CASE (I.E., NO CENSORING AND NO GROUPING).  THIS
C              ROUTINE RETURNS ONLY THE POINT ESTIMATES (CONFIDENCE
C              INTERVALS WILL BE COMPUTED IN A SEPARATE ROUTINE).
C
C              IT IS ASSUMED THAT BASIC ERROR CHECKING HAS ALREADY BEEN
C              PERFORMED.
C
C              PUT THIS IN A SEPARATE ROUTINE AS IT MAY BE CALLED
C              FROM MULTIPLE PLACES (DPMB10 WILL GENERATE THE OUTPUT
C              FOR THE BURR TYPE 10 MLE COMMAND).
C
C     REFERENCES--RAQAB AND KUNDU (2006).  "BURR TYPE X DISTRIBUTIIONS:
C                 REVISITED", JOURNAL OF PROBABILITY AND STATISTICAL
C                 SCIENCE, VOL. 4, NO. 2, PP. 179-193.
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     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2010/2
C     ORIGINAL VERSION--FEBRUARY  2010. EXTRACTED AS A SEPARATE
C                                       SUBROUTINE (FROM DPMB10)
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DIMENSION Y(*)
      DIMENSION TEMP1(*)
      DIMENSION TEMP2(*)
      DIMENSION DISPAR(*)
      DOUBLE PRECISION DTEMP1(*)
C
      DOUBLE PRECISION TOL
      DOUBLE PRECISION XPAR(2)
      DOUBLE PRECISION FVEC(2)
      DIMENSION DISPA2(1)
      INTEGER IPPCAP(2)
C
      EXTERNAL B10FUN
C
      DOUBLE PRECISION DXOUT
C
      CHARACTER*4 ISUBRO
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 IWRITE
      CHARACTER*40 IDIST
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 ISTEPN
C
      CHARACTER*4 IADEDF
      CHARACTER*4 IGEPDF
      CHARACTER*4 IMAKDF
      CHARACTER*4 IBEIDF
      CHARACTER*4 ILGADF
      CHARACTER*4 ISKNDF
      CHARACTER*4 IGLDDF
      CHARACTER*4 IBGEDF
      CHARACTER*4 IGETDF
      CHARACTER*4 ICONDF
      CHARACTER*4 IGOMDF
      CHARACTER*4 IKATDF
      CHARACTER*4 IGIGDF
      CHARACTER*4 IGEODF
      CHARACTER*4 ICASPL
      CHARACTER*4 ICASP2
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='B10M'
      ISUBN2='L1  '
C
      IERROR='NO'
C
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'0ML1')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,51)
   51   FORMAT('**** AT THE BEGINNING OF B10ML1--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,52)IBUGA3,ISUBRO,N
   52   FORMAT('IBUGA3,ISUBRO,N = ',A4,2X,A4,2X,I8)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,53)SHAPSV,SCALSV
   53   FORMAT('SHAPSV,SCALSV = ',2G15.7)
        CALL DPWRST('XXX','WRIT')
        DO56I=1,MIN(N,100)
          WRITE(ICOUT,57)I,Y(I)
   57     FORMAT('I,Y(I) = ',I8,G15.7)
          CALL DPWRST('XXX','WRIT')
   56   CONTINUE
      ENDIF
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      ISTEPN='1'
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'0ML1')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
C               *****************************************************
C               **  STEP 2--                                       **
C               **  CARRY OUT CALCULATIONS                         **
C               **  FOR BURR TYPE 10 MLE ESTIMATE                  **
C               *****************************************************
C
      ISTEPN='2'
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'0ML1')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IDIST='BURR TYPE 10'
C
      IFLAG=2
      CALL SUMRAW(Y,N,IDIST,IFLAG,
     1            XMEAN,XVAR,XSD,XMIN,XMAX,
     1            ISUBRO,IBUGA3,IERROR)
C
      SHAPML=CPUMIN
      SCALML=CPUMIN
      IF(IERROR.EQ.'YES')GOTO9000
C
      IF(SHAPSV.GT.0.0 .AND. SCALSV.GT.0.0)THEN
        XPAR(1)=DBLE(SHAPSV)
        XPAR(2)=DBLE(1.0/SCALSV)
      ELSE
C
C       IF NO STARTING VALUES SPECIFIED, COMPUTE STARTING
C       VALUES BASED ON PPCC METHOD.
C
        CALL UNIMED(N,TEMP1)
        CALL SORT(Y,N,Y)
        ICASP2='BU10'
        ICASPL='PPCC'
        IPPCAP(1)=100
        IPPCAP(2)=1
C
C       OBTAIN LOWER/UPPER LIMITS FOR SHAPE PARAMETER
C
        CALL EXTPA2(ICASP2,IDIST,A,B,
     1              SHAP11,SHAP12,SHAP21,SHAP22,
     1              SHAPE1,SHAPE2,SHAPE3,SHAPE4,SHAPE5,
     1              IADEDF,IGEPDF,IMAKDF,IBEIDF,
     1              ILGADF,ISKNDF,IGLDDF,IBGEDF,
     1              IGETDF,ICONDF,IGOMDF,IKATDF,
     1              IGIGDF,IGEODF,
     1              ISUBRO,IBUGA3,IERROR)
C
C       CREATE ARRAY FOR THE CANDIDATE VALUES OF SHAPE PARAMETER
C
        NUMSHA=1
        CALL DPPPC7(ICASPL,ICASP2,IPPCAP,
     1              SHAP11,SHAP12,SHAP21,SHAP22,
     1              SHAPE1,SHAPE2,SHAPE3,SHAPE4,
     1              XMIN,XMAX,A,B,
     1              DISPAR,DISPA2,NUMDIS,NUMSHA,
     1              IADEDF,IGEPDF,IMAKDF,IBEIDF,
     1              ILGADF,ISKNDF,IGLDDF,IBGEDF,IGETDF,
     1              ICONDF,IGOMDF,IKATDF,IGIGDF,IGEODF,
     1              IBUGA3,ISUBRO,IERROR)
C
        CORRMX=-1.0
        IWRITE='OFF'
        DO1010IDIS=1,NUMDIS
          SHAPE=DISPAR(IDIS)
          DO1020I=1,N
            CALL B10PPF(DBLE(TEMP1(I)),DBLE(SHAPE),DXOUT)
            TEMP2(I)=REAL(DXOUT)
 1020     CONTINUE
          CALL CORR(Y,TEMP2,N,IWRITE,CC,IBUGA3,IERROR)
          IF(CC.GT.CORRMX)THEN
            SHAPE1=SHAPE
            CALL LINFI2(Y,TEMP2,N,PPA0,PPA1,ISUBRO,IBUGA3,IERROR)
            CORRMX=CC
          ENDIF
 1010   CONTINUE
        XPAR(1)=DBLE(SHAPE1)
        XPAR(2)=DBLE(1.0/PPA1)
      ENDIF
C
      IOPT=2
      TOL=1.0D-8
      NVAR=2
      NPRINT=-1
      INFO=0
      LWA=MAXNXT
      CALL DNSQE(B10FUN,JAC,IOPT,NVAR,XPAR,FVEC,TOL,NPRINT,INFO,
     1           DTEMP1,MAXNXT,Y,N)
C
      SHAPML=REAL(XPAR(1))
      SCALML=1.0/REAL(XPAR(2))
      IF(SHAPML.LE.0.0)IERROR='YES'
      IF(SCALML.LE.0.0)IERROR='YES'
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'0ML1')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9011)
 9011   FORMAT('**** AT THE END OF B10ML1--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9013)N,XMEAN,XSD,XMIN,XMAX
 9013   FORMAT('N,XMEAN,XSD,XMIN,XMAX = ',I8,4G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9017)XPAR(1),XPAR(2),SHAPML,SCALML
 9017   FORMAT('XPAR(1),XPAR(2),SHAPML,SCALML =  ',4G15.7)
        CALL DPWRST('XXX','WRIT')
      ENDIF
C
      RETURN
      END
      SUBROUTINE B10PDF(DX,DR,DPDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE BURR TYPE 10 DISTRIBTION.
C              THE PROBABILITY DENSITY FUNCTION IS:
C
C              f(X;R) = 2*R*X*(1 - EXP(-X**2)**(R-1)/EXP(X^2)
C                       X >  0; R > 0
C
C              WITH SHAPE PARAMETER R.
C     INPUT  ARGUMENTS--DX     = THE DOUBLE PRECISION VALUE AT
C                                WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C                     --DR     = THE SHAPE PARAMETER
C     OUTPUT ARGUMENTS--DPDF   = THE DOUBLE PRECISION PROBABILITY DENSITY
C                                FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE PDF FOR THE BURR TYPE 10 DISTRIBUTION
C             WITH SHAPE PARAMETER R.
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--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME I", SECOND EDITION,
C                 JOHN WILEY, 1994, PP. 53-54.
C               --LUC DEVROYE, "NON-UNIFORM RANDOM VARIATE
C                 GENERATION", 1986, SPRINGER-VERLANG, PP. 476-477.
C                 (NOTE: THERE IS A TYPO IN THE DEVROYE CDF EQUATION,
C                 CORRECT FORM TAKEN FROM JOHNSON AND KOTZ).
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     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2007.10
C     ORIGINAL VERSION--OCTOBER   2007.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DPDF
      DOUBLE PRECISION DX
      DOUBLE PRECISION DR
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----DATA STATEMENTS-------------------------------------------------
C
C-----START POINT-----------------------------------------------------
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      DPDF=0.0D0
C
      IF(DX.LE.0.0D0)THEN
        WRITE(ICOUT,105)
  105   FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO B10PDF ',
     1         'IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,147)DR
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(DR.LE.0.0D0)THEN
        WRITE(ICOUT,115)
  115   FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO B10PDF ',
     1         'NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,147)DR
  147   FORMAT('      THE VALUE OF THE ARGUMENT IS ',G15.7)
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
C               **************************************************
C               **  STEP 2B-                                    **
C               **  COMPUTE BURR TYPE 10 PDF                    **
C               **************************************************
C
      DTERM1=(DR-1.0D0)*DLOG(1.0D0 - DEXP(-DX**2))
      DTERM2=DLOG(2.0D0) + DLOG(DR) + DLOG(DX)
      DTERM3=DX**2
      DPDF=DEXP(DTERM1 + DTERM2 - DTERM3)
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE B10PPF(DP,DR,DPPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE BURR TYPE 10 DISTRIBUTION.
C              THE PERCENT POINT FUNCTION IS:
C
C              G(P;R) = SQRT(-LOG(1 - P**(1/R)))    0 < P < 1; R > 0
C
C              WITH SHAPE PARAMETER R.
C     INPUT  ARGUMENTS--DP     = THE DOUBLE PRECISION VALUE AT
C                                WHICH THE PERCENT POINT
C                                FUNCTION IS TO BE EVALUATED.
C                     --DR     = THE SHAPE PARAMETER
C     OUTPUT ARGUMENTS--DPPF   = THE DOUBLE PRECISION PERCENT POINT
C                                FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION PERCENT POINT
C             FUNCTION VALUE PPF FOR THE BURR TYPE 10 DISTRIBUTION
C             WITH SHAPE PARAMETER R.
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, SQRT.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME I", SECOND EDITION,
C                 JOHN WILEY, 1994, PP. 53-54.
C               --LUC DEVROYE, "NON-UNIFORM RANDOM VARIATE
C                 GENERATION", 1986, SPRINGER-VERLANG, PP. 476-477.
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     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2007.10
C     ORIGINAL VERSION--OCTOBER   2007.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DPPF
      DOUBLE PRECISION DP
      DOUBLE PRECISION DR
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----DATA STATEMENTS-------------------------------------------------
C
C-----START POINT-----------------------------------------------------
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      DPPF=0.0D0
C
      IF(DP.LE.0.0D0 .OR. DP.GE.1.0D0)THEN
        WRITE(ICOUT,105)
  105   FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO B10PPF ',
     1         'IS OUTSIDE THE (0,1) INTERVAL.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,147)DP
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(DR.LE.0.0D0)THEN
        WRITE(ICOUT,115)
  115   FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO B10PPF ',
     1         'NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,147)DR
  147   FORMAT('      THE VALUE OF THE ARGUMENT IS ',G15.7)
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
C               **************************************************
C               **  STEP 2B-                                    **
C               **  COMPUTE BURR TYPE 10 PPF                    **
C               **************************************************
C
      DPPF=DSQRT(-DLOG(1.D0 - DP**(1.0D0/DR)))
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE B10RAN(N,R,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE BURR TYPE 10 DISTRIBUTION WITH
C              SHAPE PARAMETER R.
C
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --R      = THE SINGLE PRECISION VALUE OF THE
C                                SHAPE PARAMETER R.
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 BURR TYPE 10 DISTRIBUTION
C             WITH SHAPE PARAMETER R.
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, B10PPF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME I", SECOND EDITION,
C                 JOHN WILEY, 1994, PP. 53-54.
C               --LUC DEVROYE, "NON-UNIFORM RANDOM VARIATE
C                 GENERATION", 1986, SPRINGER-VERLANG, PP. 476-477.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHMOLOGY 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     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2007.10
C     ORIGINAL VERSION--OCTOBER   2007.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
C
      DOUBLE PRECISION DTEMP
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
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
    5   FORMAT('***** ERROR--THE REQUESTED NUMBER OF ',
     1         'BURR TYPE 10 RANDOM NUMBERS IS NON-POSITIVE')
   47   FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8)
      ELSEIF(R.LE.0.0)THEN
        WRITE(ICOUT,201)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,203)R
        CALL DPWRST('XXX','BUG ')
        GOTO9000
  201   FORMAT('***** ERROR--THE R SHAPE PARAMETER IS NON-POSITIVE.')
  203   FORMAT('      THE VALUE OF R IS ',G15.7)
      ENDIF
C
C     GENERATE N UNIFORM (0,1) RANDOM NUMBERS;
C
      CALL UNIRAN(N,ISEED,X)
C
C     GENERATE N SLOPE DISTRIBUTION RANDOM
C     NUMBERS USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD.
C
      DO300I=1,N
        CALL B10PPF(DBLE(X(I)),DBLE(R),DTEMP)
        X(I)=DBLE(DTEMP)
  300 CONTINUE
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE B11CDF(DX,DR,DCDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE BURR TYPE 11 DISTRIBTION.
C              THE CUMULATIVE DISTRIBUTION FUNCTION IS:
C
C              F(X;R) = [X - (1/(2*PI))*SIN(2*PI*X)]**R
C              0 <  X <  1; R > 0
C
C              WITH SHAPE PARAMETER R.
C     INPUT  ARGUMENTS--DX     = THE DOUBLE PRECISION VALUE AT
C                                WHICH THE CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C                     --DR     = THE SHAPE PARAMETER
C     OUTPUT ARGUMENTS--DCDF   = THE DOUBLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION CUMULATIVE DISTRIBUTION
C             FUNCTION VALUE CDF FOR THE BURR TYPE 11 DISTRIBUTION
C             WITH SHAPE PARAMETER R.
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--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME I", SECOND EDITION,
C                 JOHN WILEY, 1994, PP. 53-54.
C               --LUC DEVROYE, "NON-UNIFORM RANDOM VARIATE
C                 GENERATION", 1986, SPRINGER-VERLANG, PP. 476-477.
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     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2007.10
C     ORIGINAL VERSION--OCTOBER   2007.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DCDF
      DOUBLE PRECISION DX
      DOUBLE PRECISION DR
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DPI
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----DATA STATEMENTS-------------------------------------------------
C
      DATA DPI / 3.1415926535 8979323846 2643383279 503 D0 /
C
C-----START POINT-----------------------------------------------------
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      DCDF=0.0D0
C
      IF(DR.LE.0.0D0)THEN
        WRITE(ICOUT,115)
  115   FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO B11CDF ',
     1         'IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,147)DR
  147   FORMAT('      THE VALUE OF THE ARGUMENT IS ',G15.7)
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
C               **************************************************
C               **  STEP 2B-                                    **
C               **  COMPUTE BURR TYPE 11  CDF                   **
C               **************************************************
C
      IF(DX.LE.0.0D0)THEN
        DCDF=0.0D0
      ELSEIF(DX.GE.1.0D0)THEN
        DCDF=1.0D0
      ELSE
        DTERM1=SIN(2.0D0*DPI*DX)/(2.0D0*DPI)
        DTERM2=DX - DTERM1
        DCDF=DTERM2**DR
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE B11PDF(DX,DR,DPDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE BURR TYPE 11 DISTRIBTION.
C              THE PROBABILITY DENSITY FUNCTION IS:
C
C              f(X;R) = R*{1 - COS(2*PI*DX)*
C                       (X - SIN(2*PI*X)/(2*PI)}**(R-1)
C              0 <  X <  1; R > 0
C
C              WITH SHAPE PARAMETER R.
C     INPUT  ARGUMENTS--DX     = THE DOUBLE PRECISION VALUE AT
C                                WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C                     --DR     = THE SHAPE PARAMETER
C     OUTPUT ARGUMENTS--DPDF   = THE DOUBLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE PDF FOR THE BURR TYPE 11 DISTRIBUTION
C             WITH SHAPE PARAMETER R.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--SIN, COS.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME I", SECOND EDITION,
C                 JOHN WILEY, 1994, PP. 53-54.
C               --LUC DEVROYE, "NON-UNIFORM RANDOM VARIATE
C                 GENERATION", 1986, SPRINGER-VERLANG, PP. 476-477.
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     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2007.10
C     ORIGINAL VERSION--OCTOBER   2007.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DPDF
      DOUBLE PRECISION DX
      DOUBLE PRECISION DR
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DPI
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----DATA STATEMENTS-------------------------------------------------
C
      DATA DPI / 3.1415926535 8979323846 2643383279 503 D0 /
C
C-----START POINT-----------------------------------------------------
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      DPDF=0.0D0
C
      IF(DX.LE.0.0D0 .OR. DX.GE.1.0D0)THEN
        WRITE(ICOUT,105)
  105   FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO B11PDF ',
     1         'IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,147)DX
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(DR.LE.0.0D0)THEN
        WRITE(ICOUT,115)
  115   FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO B11PDF ',
     1         'IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,147)DR
  147   FORMAT('      THE VALUE OF THE ARGUMENT IS ',G15.7)
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
C               **************************************************
C               **  STEP 2B-                                    **
C               **  COMPUTE BURR TYPE 11  PDF                   **
C               **************************************************
C
      DTERM1=1.0D0 - DCOS(2.0D0*DPI*DX)
      DTERM2=DX - DSIN(2.0D0*DPI*DX)/(2.0D0*DPI)
      DPDF=DR*DTERM1*(DTERM2**(DR-1.0D0))
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE B11PPF(DP,DR,DPPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE BURR TYPE 11 DISTRIBTION.
C              THE CUMULATIVE DISTRIBUTION FUNCTION IS:
C
C              F(X;R) = [X - (1/(2*PI))*SIN(2*PI*X)]**R
C              0 <  X <  1; R > 0
C
C              WITH SHAPE PARAMETER R.
C
C              THE PERCENT POINT FUNCTION IS COMPUTED BY
C              NUMERICALLY INVERTING THE CDF FUNCTION.
C
C     INPUT  ARGUMENTS--DP     = THE DOUBLE PRECISION VALUE AT
C                                WHICH THE PERCENT POINT
C                                FUNCTION IS TO BE EVALUATED.
C                     --DR     = THE SHAPE PARAMETER
C     OUTPUT ARGUMENTS--DCDF   = THE DOUBLE PRECISION PERCENT POINT
C                                FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION PERCENT POINT
C             FUNCTION VALUE PPF FOR THE BURR TYPE 11 DISTRIBUTION
C             WITH SHAPE PARAMETER R.
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     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     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2007/10
C     ORIGINAL VERSION--OCTOBER   2007.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DOUBLE PRECISION DP
      DOUBLE PRECISION DCDF
      DOUBLE PRECISION DR
      DOUBLE PRECISION DX
      DOUBLE PRECISION DPPF
      DOUBLE PRECISION XL
      DOUBLE PRECISION XR
      DOUBLE PRECISION FXL
      DOUBLE PRECISION FXR
      DOUBLE PRECISION FCS
      DOUBLE PRECISION P1
      DOUBLE PRECISION EPS
      DOUBLE PRECISION SIG
      DOUBLE PRECISION ZERO
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
      DATA EPS /1.0D-10/
      DATA SIG /1.0D-9/
      DATA ZERO /0.D0/
      DATA MAXIT /500/
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      DPPF=0.0D0
C
      IF(DP.LT.0.0D0 .OR. DP.GT.1.0D0)THEN
        WRITE(ICOUT,11)
   11   FORMAT('***** ERROR--THE FIRST ARGUMENT TO B11PPF IS ',
     1         'OUTSIDE THE ALLOWABLE (0,1) INTERVAL')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)DP
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(DR.LE.0.0D0)THEN
        WRITE(ICOUT,15)
   15   FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO B11PPF ',
     1         'IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)DR
   47   FORMAT('      THE VALUE OF THE ARGUMENT IS ',G15.7)
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(DP.LE.0.0D0)THEN
        DPPF=0.0D0
        GOTO9000
      ELSEIF(DP.GE.1.0D0)THEN
        DPPF=1.0D0
        GOTO9000
      ENDIF
C
      IERR=0
      IC = 0
      XL = 0.0D0
      XR = 1.0D0
      FXL = -DP
      FXR = 1.0D0 - DP
C
      IF(FXL*FXR .GT. ZERO)THEN
        WRITE(ICOUT,11)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)DP
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
C  BISECTION METHOD
C
  105 CONTINUE
      DX = (XL+XR)*0.5D0
      CALL B11CDF(DX,DR,DCDF)
      P1=DCDF
      DPPF=DX
      FCS = P1 - DP
      IF(FCS*FXL.GT.ZERO)GOTO110
      XR = DX
      FXR = FCS
      GOTO115
  110 CONTINUE
      XL = DX
      FXL = FCS
  115 CONTINUE
      XRML = XR - XL
      IF(XRML.LE.SIG .AND. ABS(FCS).LE.EPS)GOTO9000
      IC = IC + 1
      IF(IC.LE.MAXIT)GOTO105
      WRITE(ICOUT,130)
  130 FORMAT('***** ERROR--B11PPF ROUTINE DID NOT CONVERGE.')
      CALL DPWRST('XXX','BUG ')
      GOTO9000
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE B11RAN(N,R,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE BURR TYPE 11 DISTRIBUTION WITH
C              SHAPE PARAMETER R.
C
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --R      = THE SINGLE PRECISION VALUE OF THE
C                                SHAPE PARAMETER R.
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 BURR TYPE 11 DISTRIBUTION
C             WITH SHAPE PARAMETER R.
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, B11PPF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME I", SECOND EDITION,
C                 JOHN WILEY, 1994, PP. 53-54.
C               --LUC DEVROYE, "NON-UNIFORM RANDOM VARIATE
C                 GENERATION", 1986, SPRINGER-VERLANG, PP. 476-477.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHMOLOGY 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     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2007.10
C     ORIGINAL VERSION--OCTOBER   2007.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
C
      DOUBLE PRECISION DTEMP
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
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
    5   FORMAT('***** ERROR--THE REQUESTED NUMBER OF ',
     1         'BURR TYPE 11 RANDOM NUMBERS IS NON-POSITIVE')
   47   FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8)
      ELSEIF(R.LE.0.0)THEN
        WRITE(ICOUT,201)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,203)R
        CALL DPWRST('XXX','BUG ')
        GOTO9000
  201   FORMAT('***** ERROR--THE R SHAPE PARAMETER IS NON-POSITIVE.')
  203   FORMAT('      THE VALUE OF R IS ',G15.7)
      ENDIF
C
C     GENERATE N UNIFORM (0,1) RANDOM NUMBERS;
C
      CALL UNIRAN(N,ISEED,X)
C
C     GENERATE N BURR TYPE 11 DISTRIBUTION RANDOM
C     NUMBERS USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD.
C
      DO300I=1,N
        CALL B11PPF(DBLE(X(I)),DBLE(R),DTEMP)
        X(I)=DBLE(DTEMP)
  300 CONTINUE
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE B12CDF(DX,DC,DK,DCDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE BURR TYPE 12 DISTRIBTION.
C              THE CUMULATIVE DISTRIBUTION FUNCTION IS:
C
C              F(X;C,K) = 1 - (1+X**C)**(-K)   X >= 0
C
C              WITH SHAPE PARAMETERS C AND K.
C     INPUT  ARGUMENTS--DX     = THE DOUBLE PRECISION VALUE AT
C                                WHICH THE CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C                     --DC     = THE FIRST SHAPE PARAMETER
C                     --DK     = THE SECOND SHAPE PARAMETER
C     OUTPUT ARGUMENTS--DCDF   = THE DOUBLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION CUMULATIVE DISTRIBUTION
C             FUNCTION VALUE CDF FOR THE BURR TYPE 12 DISTRIBUTION
C             WITH SHAPE PARAMETERS C AND 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--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME I", SECOND EDITION,
C                 JOHN WILEY, 1994, PP. 53-54.
C               --LUC DEVROYE, "NON-UNIFORM RANDOM VARIATE
C                 GENERATION", 1986, SPRINGER-VERLANG, PP. 476-477.
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     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2007.10
C     ORIGINAL VERSION--OCTOBER   2007.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DCDF
      DOUBLE PRECISION DX
      DOUBLE PRECISION DC
      DOUBLE PRECISION DK
      DOUBLE PRECISION DTERM1
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----DATA STATEMENTS-------------------------------------------------
C
C-----START POINT-----------------------------------------------------
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      DCDF=0.0D0
C
      IF(DC.LE.0.0D0)THEN
        WRITE(ICOUT,115)
  115   FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO B12CDF ',
     1         'IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,147)DC
  147   FORMAT('      THE VALUE OF THE ARGUMENT IS ',G15.7)
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(DK.LE.0.0D0)THEN
        WRITE(ICOUT,125)
  125   FORMAT('***** ERROR--THE THIRD INPUT ARGUMENT TO B12CDF ',
     1         'IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,147)DK
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
C               **************************************************
C               **  STEP 2B-                                    **
C               **  COMPUTE BURR TYPE 12 CDF                    **
C               **************************************************
C
      IF(DX.LE.0.0D0)THEN
        DCDF=0.0D0
      ELSE
        DTERM1=1.0D0 + DX**DC
        DCDF=1.0D0 - DTERM1**(-DK)
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE B12PDF(DX,DC,DK,DPDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE BURR TYPE 12 DISTRIBTION.
C              THE PROBABILITY DENSITY FUNCTION IS:
C
C              f(X;C,K) = C*K*X**(C-1)*(1 + X**C)**(-K-1)
C                         X > 0; C, K >0
C
C              WITH SHAPE PARAMETERS C AND K.
C     INPUT  ARGUMENTS--DX     = THE DOUBLE PRECISION VALUE AT
C                                WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C                     --DC     = THE FIRST SHAPE PARAMETER
C                     --DK     = THE SECOND SHAPE PARAMETER
C     OUTPUT ARGUMENTS--DPDF   = THE DOUBLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE PDF FOR THE BURR TYPE 12 DISTRIBUTION
C             WITH SHAPE PARAMETERS C AND 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--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME I", SECOND EDITION,
C                 JOHN WILEY, 1994, PP. 53-54.
C               --LUC DEVROYE, "NON-UNIFORM RANDOM VARIATE
C                 GENERATION", 1986, SPRINGER-VERLANG, PP. 476-477.
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     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2007.10
C     ORIGINAL VERSION--OCTOBER   2007.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DPDF
      DOUBLE PRECISION DX
      DOUBLE PRECISION DC
      DOUBLE PRECISION DK
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----DATA STATEMENTS-------------------------------------------------
C
C-----START POINT-----------------------------------------------------
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      DPDF=0.0D0
C
      IF(DX.LE.0.0D0)THEN
        WRITE(ICOUT,105)
  105   FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO B12PDF ',
     1         'IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,147)DX
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(DC.LE.0.0D0)THEN
        WRITE(ICOUT,115)
  115   FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO B12PDF ',
     1         'IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,147)DC
  147   FORMAT('      THE VALUE OF THE ARGUMENT IS ',G15.7)
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(DK.LE.0.0D0)THEN
        WRITE(ICOUT,125)
  125   FORMAT('***** ERROR--THE THIRD INPUT ARGUMENT TO B12PDF ',
     1         'IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,147)DK
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
C               **************************************************
C               **  STEP 2B-                                    **
C               **  COMPUTE BURR TYPE 12 PDF                    **
C               **************************************************
C
      DTERM1=DLOG(DC) + DLOG(DK) + (DC-1.0D0)*DLOG(DX)
      DTERM2=(-DK-1.0D0)*DLOG(1.0D0 + DX**DC)
      DPDF=DEXP(DTERM1+DTERM2)
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE B12PPF(DP,DC,DK,DPPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE BURR TYPE 12 DISTRIBTION.
C              THE PERCENT POINT FUNCTION IS:
C
C              G(P;C,K) = [(1-P)**(-1/K)-1]**(1/C)  0 <= P < 1; C, K > 0
C
C              WITH SHAPE PARAMETERS C AND K.
C     INPUT  ARGUMENTS--DP     = THE DOUBLE PRECISION VALUE AT
C                                WHICH THE PERCENT POINT
C                                FUNCTION IS TO BE EVALUATED.
C                     --DC     = THE FIRST SHAPE PARAMETER
C                     --DK     = THE SECOND SHAPE PARAMETER
C     OUTPUT ARGUMENTS--DPPF   = THE DOUBLE PRECISION PERCENT POINT
C                                FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION PERCENT POINT
C             FUNCTION VALUE PPF FOR THE BURR TYPE 12 DISTRIBUTION
C             WITH SHAPE PARAMETERS C AND 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--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME I", SECOND EDITION,
C                 JOHN WILEY, 1994, PP. 53-54.
C               --LUC DEVROYE, "NON-UNIFORM RANDOM VARIATE
C                 GENERATION", 1986, SPRINGER-VERLANG, PP. 476-477.
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     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2007.10
C     ORIGINAL VERSION--OCTOBER   2007.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DPPF
      DOUBLE PRECISION DP
      DOUBLE PRECISION DC
      DOUBLE PRECISION DK
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----DATA STATEMENTS-------------------------------------------------
C
C-----START POINT-----------------------------------------------------
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      DPPF=0.0D0
C
      IF(DP.LT.0.0D0 .OR. DP.GE.1.0D0)THEN
        WRITE(ICOUT,105)
  105   FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO B12PPF ',
     1         'IS OUTSIDE THE (0,1) INTERVAL.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,147)DP
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(DC.LE.0.0D0)THEN
        WRITE(ICOUT,115)
  115   FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO B12PPF ',
     1         'NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,147)DC
  147   FORMAT('      THE VALUE OF THE ARGUMENT IS ',G15.7)
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(DK.LE.0.0D0)THEN
        WRITE(ICOUT,125)
  125   FORMAT('***** ERROR--THE THIRD INPUT ARGUMENT TO B12PPF ',
     1         'NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,147)DK
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
C               **************************************************
C               **  STEP 2B-                                    **
C               **  COMPUTE BURR 12 PPF                         **
C               **************************************************
C
      IF(DP.LE.0.0D0)THEN
        DPPF=0.0D0
      ELSE
        DPPF=((1.0D0 - DP)**(-1.0D0/DK) - 1.0D0)**(1.0D0/DC)
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE B12RAN(N,C,AK,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE BURR TYPE 12 DISTRIBUTION WITH
C              SHAPE PARAMETERS C AND K.
C
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --C      = THE SINGLE PRECISION VALUE OF THE
C                                SHAPE PARAMETER C.
C                     --AK     = THE SINGLE PRECISION VALUE OF THE
C                                SHAPE PARAMETER K.
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 BURR TYPE 12 DISTRIBUTION
C             WITH SHAPE PARAMETERS C 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     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN, B12PPF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME I", SECOND EDITION,
C                 JOHN WILEY, 1994, PP. 53-54.
C               --LUC DEVROYE, "NON-UNIFORM RANDOM VARIATE
C                 GENERATION", 1986, SPRINGER-VERLANG, PP. 476-477.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHMOLOGY 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     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2007.10
C     ORIGINAL VERSION--OCTOBER   2007.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
C
      DOUBLE PRECISION DTEMP
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
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
    5   FORMAT('***** ERROR--THE REQUESTED NUMBER OF ',
     1         'BURR TYPE 12 RANDOM NUMBERS IS NON-POSITIVE')
   47   FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8)
      ELSEIF(C.LE.0.0)THEN
        WRITE(ICOUT,201)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,203)C
        CALL DPWRST('XXX','BUG ')
        GOTO9000
  201   FORMAT('***** ERROR--THE C SHAPE PARAMETER IS NON-POSITIVE.')
  203   FORMAT('      THE VALUE OF R IS ',G15.7)
      ELSEIF(AK.LE.0.0)THEN
        WRITE(ICOUT,211)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,213)AK
        CALL DPWRST('XXX','BUG ')
        GOTO9000
  211   FORMAT('***** ERROR--THE K SHAPE PARAMETER IS NON-POSITIVE.')
  213   FORMAT('      THE VALUE OF K IS ',G15.7)
      ENDIF
C
C     GENERATE N UNIFORM (0,1) RANDOM NUMBERS;
C
      CALL UNIRAN(N,ISEED,X)
C
C     GENERATE N SLOPE DISTRIBUTION RANDOM
C     NUMBERS USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD.
C
      DO300I=1,N
        CALL B12PPF(DBLE(X(I)),DBLE(C),DBLE(AK),DTEMP)
        X(I)=DBLE(DTEMP)
  300 CONTINUE
C
 9000 CONTINUE
      RETURN
      END
      DOUBLE PRECISION FUNCTION bup(a,b,x,y,n,eps)
C-----------------------------------------------------------------------
C     EVALUATION OF IX(A,B) - IX(A+N,B) WHERE N IS A POSITIVE INTEGER.
C     EPS IS THE TOLERANCE USED.
C-----------------------------------------------------------------------
C     .. Scalar Arguments ..
      DOUBLE PRECISION a,b,eps,x,y
      INTEGER n
C     ..
C     .. Local Scalars ..
      DOUBLE PRECISION ap1,apb,d,l,r,t,w
      INTEGER i,k,kp1,mu,nm1
C     ..
C     .. External Functions ..
      DOUBLE PRECISION brcmp1,exparg
      EXTERNAL brcmp1,exparg
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC abs,exp
C     ..
C     .. Executable Statements ..
C
C          OBTAIN THE SCALING FACTOR EXP(-MU) AND
C             EXP(MU)*(X**A*Y**B/BETA(A,B))/A
C
      apb = a + b
      ap1 = a + 1.0D0
      mu = 0
      d = 1.0D0
      IF (n.EQ.1 .OR. a.LT.1.0D0) GO TO 10
      IF (apb.LT.1.1D0*ap1) GO TO 10
      mu = int(abs(exparg(1)))
      k = int(exparg(0))
      IF (k.LT.mu) mu = k
      t = mu
      d = exp(-t)
C
   10 bup = brcmp1(mu,a,b,x,y)/a
      IF (n.EQ.1 .OR. bup.EQ.0.0D0) RETURN
      nm1 = n - 1
      w = d
C
C          LET K BE THE INDEX OF THE MAXIMUM TERM
C
      k = 0
      IF (b.LE.1.0D0) GO TO 50
      IF (y.GT.1.D-4) GO TO 20
      k = nm1
      GO TO 30

   20 r = (b-1.0D0)*x/y - a
      IF (r.LT.1.0D0) GO TO 50
      k = nm1
      t = nm1
      IF (r.LT.t) k = int(r)
C
C          ADD THE INCREASING TERMS OF THE SERIES
C
   30 DO 40 i = 1,k
          l = i - 1
          d = ((apb+l)/ (ap1+l))*x*d
          w = w + d
   40 CONTINUE
      IF (k.EQ.nm1) GO TO 70
C
C          ADD THE REMAINING TERMS OF THE SERIES
C
   50 kp1 = k + 1
      DO 60 i = kp1,nm1
          l = i - 1
          d = ((apb+l)/ (ap1+l))*x*d
          w = w + d
          IF (d.LE.eps*w) GO TO 70
   60 CONTINUE
C
C               TERMINATE THE PROCEDURE
C
   70 bup = bup*w
      RETURN

      END
      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
      INCLUDE 'DPCOP2.INC'
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                 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     LANGUAGE--ANSI FORTRAN (1966)
C     VERSION NUMBER--94.10
C     ORIGINAL VERSION--OCTOBER   1994.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
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('XXX','BUG ')
        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                 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     LANGUAGE--ANSI FORTRAN (1966)
C     VERSION NUMBER--95.9
C     ORIGINAL VERSION--SEPTEMBER 1995.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
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('XXX','BUG ')
        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                 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     LANGUAGE--ANSI FORTRAN (1966)
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
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      DCDF=0.0D0
      CDF=0.0
      IF(ASCAL1.LE.0.0)THEN
        WRITE(ICOUT,5)
    5   FORMAT('***** ERROR--THE SCALE(1) PARAMETER FOR BWECDF ',
     1         'IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ASCAL1
   46   FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7,'.')
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ELSEIF(GAMMA1.LE.0.0)THEN
        WRITE(ICOUT,15)
   15   FORMAT('***** ERROR--THE GAMMA(1) SHAPE PARAMETER FOR ',
     1        'BWECDF IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)GAMMA1
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ELSEIF(ASCAL2.LE.0.0)THEN
        WRITE(ICOUT,25)
   25   FORMAT('***** ERROR--THE SCALE(2) PARAMETER FOR ',
     1         'BWECDF IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ASCAL2
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ELSEIF(GAMMA2.LE.0.0)THEN
        WRITE(ICOUT,35)
   35   FORMAT('***** ERROR--THE GAMMA(2) SHAPE PARAMETER FOR ',
     1         'BWECDF IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)GAMMA2
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ELSEIF(ALOC2.LE.0.0)THEN
        WRITE(ICOUT,45)
   45   FORMAT('***** ERROR--THE LOCATION(2) PARAMETER FOR ',
     1         'BWECDF IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ALOC2
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
C
      IF(X.LE.0.0)GOTO9999
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                 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     LANGUAGE--ANSI FORTRAN (1966)
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
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      HAZ=0.0
      DHAZ=0.0D0
      IF(ASCAL1.LE.0.0)THEN
        WRITE(ICOUT,5)
    5   FORMAT('***** ERROR--THE SCALE(1) PARAMETER FOR ',
     1         'BWEHAZ IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ASCAL1
   46   FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7,'.')
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ELSEIF(GAMMA1.LE.0.0)THEN
        WRITE(ICOUT,15)
   15   FORMAT('***** ERROR--THE GAMMA(1) SHAPE PARAMETER FOR ',
     1         'BWEHAZ IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)GAMMA1
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ELSEIF(ASCAL2.LE.0.0)THEN
        WRITE(ICOUT,25)
   25   FORMAT('***** ERROR--THE SCALE(2) PARAMETER FOR ',
     1         'BWEHAZ IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ASCAL2
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ELSEIF(GAMMA2.LE.0.0)THEN
        WRITE(ICOUT,35)
   35   FORMAT('***** ERROR--THE GAMMA(2) SHAPE PARAMETER FOR ',
     1         'BWEHAZ IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)GAMMA2
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ELSEIF(ALOC2.LE.0.0)THEN
        WRITE(ICOUT,45)
   45   FORMAT('***** ERROR--THE LOCATION(2) PARAMETER FOR ',
     1         'BWEHAZ IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ALOC2
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
C
      IF(X.LE.0.0)GOTO9999
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                 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     LANGUAGE--ANSI FORTRAN (1966)
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
      INCLUDE 'DPCOP2.INC'
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
      PPF=0.0
      DPPF=0.0D0
      IF(P.LT.0.0 .OR. P.GE.1.0)THEN
        WRITE(ICOUT,1)
    1   FORMAT('***** ERROR--THE INPUT ARGUMENT FOR BWEPPF ',
     1         'BWEPPF IS OUTSIDE THE INTERVAL [0,1).')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)P
   46   FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7,'.')
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ELSEIF(ASCAL1.LE.0.0)THEN
        WRITE(ICOUT,5)
    5   FORMAT('***** ERROR--THE SCALE(1) PARAMETER FOR ',
     1         'BWEPPF IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ASCAL1
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ELSEIF(GAMMA1.LE.0.0)THEN
        WRITE(ICOUT,15)
   15   FORMAT('***** ERROR--THE GAMMA(1) SHAPE PARAMETER FOR ',
     1         'BWEPPF IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)GAMMA1
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ELSEIF(ASCAL2.LE.0.0)THEN
        WRITE(ICOUT,25)
   25   FORMAT('***** ERROR--THE SCALE(2) PARAMETER FOR ',
     1         'BWEPPF IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ASCAL2
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ELSEIF(GAMMA2.LE.0.0)THEN
        WRITE(ICOUT,35)
   35   FORMAT('***** ERROR--THE GAMMA(2) SHAPE PARAMETER FOR ',
     1         'BWEPPF IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)GAMMA2
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ELSEIF(ALOC2.LE.0.0)THEN
        WRITE(ICOUT,45)
   45   FORMAT('***** ERROR--THE LOCATION(2) PARAMETER FOR ',
     1         'BWEPPF IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ALOC2
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
C
      IF(P.EQ.0.0)GOTO9999
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('***** 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                 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     LANGUAGE--ANSI FORTRAN (1966)
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
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(ASCAL1.LE.0.0)THEN
        WRITE(ICOUT,5)
    5   FORMAT('***** 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 ',G15.7,'.')
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ELSEIF(GAMMA1.LE.0.0)THEN
        WRITE(ICOUT,15)
   15   FORMAT('***** ERROR--THE GAMMA(1) SHAPE PARAMETER FOR ',
     1         'BWERAN IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)GAMMA1
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ELSEIF(ASCAL2.LE.0.0)THEN
        WRITE(ICOUT,25)
   25   FORMAT('***** ERROR--THE SCALE(2) PARAMETER FOR ',
     1         'BWERAN IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ASCAL2
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ELSEIF(GAMMA2.LE.0.0)THEN
        WRITE(ICOUT,35)
   35   FORMAT('***** ERROR--THE GAMMA(2) SHAPE PARAMETER FOR ',
     1         'BWERAN IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)GAMMA2
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ELSEIF(ALOC2.LE.0.0)THEN
        WRITE(ICOUT,45)
   45   FORMAT('***** ERROR--THE LOCATION(2) PARAMETER FOR ',
     1         'BWERAN 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(*)
C
      BVN = 0.0D0
C
      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