      SUBROUTINE AAD(X,N,IWRITE,XTEMP,MAXNXT,XAAD,IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE
C              SAMPLE AVERAGE ABSOLUTE DEVIATION (WITH DENOMINATOR N)
C              OF THE DATA IN THE INPUT VECTOR X.
C              THE SAMPLE AVERAGE ABSOLUTE DEVIATION = (THE SUM OF THE
C              ABSOLUTE DEVIATIONS ABOUT THE SAMPLE MEDIAN) / N).
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR OF
C                                (UNSORTED OR SORTED) OBSERVATIONS.
C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTOR X.
C     OUTPUT ARGUMENTS--XAAD    = THE SINGLE PRECISION VALUE OF THE
C                                COMPUTED SAMPLE AVERAGE ABSOLUTE DEVIATION.
C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
C             SAMPLE AVERAGE ABSOLUTE DEVIATION (WITH DENOMINATOR N-1).
C     OTHER DATAPAC   SUBROUTINES NEEDED--MEDIAN AND SORT.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--SNEDECOR AND COCHRAN, STATISTICAL METHODS,
C                 EDITION 6, 1967, PAGE 44.
C               --DIXON AND MASSEY, INTRODUCTION TO STATISTICAL
C                 ANALYSIS, EDITION 2, 1957, PAGES 19, 76.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--82/7
C     ORIGINAL VERSION--JULY      1981.
C     UPDATED         --AUGUST    1981.
C     UPDATED         --MAY       1982.
C     UPDATED         --JANUARY   1989.  FIX COMPUTATIONAL BUG (ALAN)
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 IWRIT2
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DN
      DOUBLE PRECISION DX
      DOUBLE PRECISION DDEL
      DOUBLE PRECISION DSUM
      DOUBLE PRECISION DMED
C
      DIMENSION X(*)
      DIMENSION XTEMP(*)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='AAD '
      ISUBN2='    '
C
      IERROR='NO'
C
      DMED=0.0D0
      DDEL=0.0D0
C
      IF(IBUGA3.EQ.'OFF')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF AAD--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)IBUGA3
   52 FORMAT('IBUGA3 = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)N
   53 FORMAT('N = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO55I=1,N
      WRITE(ICOUT,56)I,X(I)
   56 FORMAT('I,X(I) = ',I8,E15.7)
      CALL DPWRST('XXX','BUG ')
   55 CONTINUE
   90 CONTINUE
C
C               ******************************************
C               **  COMPUTE AVERAGE ABSOLUTE DEVIATION  **
C               ******************************************
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      AN=N
C
      IF(N.GE.1)GOTO119
      IERROR='YES'
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,111)
  111 FORMAT('***** ERROR IN AAD--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,112)
  112 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,113)
  113 FORMAT('      IN THE VARIABLE FOR WHICH')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,114)
  114 FORMAT('      THE AVERAGE ABSOLUTE DEVIATION IS TO BE')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,115)
  115 FORMAT('      COMPUTED, MUST BE 1 OR LARGER.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,116)
  116 FORMAT('      SUCH WAS NOT THE CASE HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,117)N
  117 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8,
     1'.')
      CALL DPWRST('XXX','BUG ')
      GOTO9000
  119 CONTINUE
C
      IF(N.EQ.1)GOTO120
      GOTO129
  120 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,121)
  121 FORMAT('***** NON-FATAL DIAGNOSTIC IN AAD--',
     1'THE SECOND INPUT ARGUMENT (N) HAS THE VALUE 1')
      CALL DPWRST('XXX','BUG ')
      XAAD=0.0
      GOTO9000
  129 CONTINUE
C
      HOLD=X(1)
      DO135I=2,N
      IF(X(I).NE.HOLD)GOTO139
  135 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,136)HOLD
  136 FORMAT('***** NON-FATAL DIAGNOSTIC IN AAD--',
     1'THE FIRST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      XAAD=0.0
      GOTO9000
  139 CONTINUE
C
  190 CONTINUE
C
C               ***********************************************
C               **  STEP 2--                         **
C               **  COMPUTE THE AVERAGE ABSOLUTE DEVIATION.  **
C               ***************************************
C
      IWRIT2='OFF'
      CALL MEDIAN(X,N,IWRIT2,XTEMP,MAXNXT,XMED,IBUGA3,IERROR)
      DMED=XMED
C
      DN=N
      DSUM=0.0D0
      DO300I=1,N
      DX=X(I)
      DDEL=DX-DMED
      IF(DDEL.LT.0.0D0)DDEL=-DDEL
      DSUM=DSUM+DDEL
  300 CONTINUE
C  BUG FIX: AUGUST, 1987
CCCCC XAAD=DDEL/DN
      XAAD=DSUM/DN
C  END BUG FIX
C
C               *******************************
C               **  STEP 3--                 **
C               **  WRITE OUT A LINE         **
C               **  OF SUMMARY INFORMATION.  **
C               *******************************
C
      IF(IFEEDB.EQ.'OFF')GOTO890
      IF(IWRITE.EQ.'OFF')GOTO890
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,811)N,XAAD
  811 FORMAT('THE AVERAGE ABSOLUTE DEVIATION OF THE ',I8,
     1' OBSERVATIONS = ',E15.7)
      CALL DPWRST('XXX','BUG ')
  890 CONTINUE
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'OFF')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF AAD--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IBUGA3,IERROR
 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)N
 9013 FORMAT('N = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9014)DMED
 9014 FORMAT('DMED = ',D15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9015)XAAD
 9015 FORMAT('XAAD = ',E15.7)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      DOUBLE PRECISION FUNCTION ABRAM0(XVALUE)
C
C   DESCRIPTION:
C      This function calculates the Abramowitz function of order 0,
C      defined as
C
C       ABRAM0(x) = integral{ 0 to infinity } exp( -t*t - x/t ) dt
C
C       The code uses Chebyshev expansions with the coefficients
C       given to an accuracy of 20 decimal places.
C
C
C   ERROR RETURNS:
C      If XVALUE < 0.0, the function prints a message and returns the 
C      value 0.0.
C
C
C   MACHINE-DEPENDENT CONSTANTS:
C
C      NTERMF - INTEGER - No. of terms needed for the array AB0F.
C               Recommended value such that 
C                     ABS( AB0F(NTERMF) ) < EPS/100
C
C      NTERMG - INTEGER - No. of terms needed for array AB0G.
C               Recommended value such that
C                     ABS( AB0G(NTERMG) ) < EPS/100
C
C      NTERMH - INTEGER - No. of terms needed for array AB0H.
C               Recommended value such that
C                     ABS( AB0H(NTERMH) ) < EPS/100
C
C      NTERMA - INTEGER - No. of terms needed for array AB0AS.
C               Recommended value such that
C                     ABS( AB0AS(NTERMA) ) < EPS/100 
C
C     XLOW1 - DOUBLE PRECISION - The value below which 
C              ABRAM0 = root(pi)/2 + X ( ln X - GVAL0 )
C             Recommended value is SQRT(2*EPSNEG)
C
C     LNXMIN - DOUBLE PRECISION - The value of ln XMIN. Used to prevent
C              exponential underflow for large X.
C
C     For values of EPS, EPSNEG, XMIN refer to the file MACHCON.TXT.
C
C     The machine-dependent constants are computed internally by
C     using the D1MACH subroutine.
C
C
C   INTRINSIC FUNCTIONS USED:
C
C     LOG, EXP, SQRT
C
C
C   OTHER MISCFUN SUBROUTINES USED:
C
C          CHEVAL , ERRPRN, D1MACH
C
C
C   AUTHOR:
C
C      DR. ALLAN J. MACLEOD,
C      DEPT. OF MATHEMATICS AND STATISTICS,
C      UNIVERSITY OF PAISLEY ,
C      HIGH ST.,
C      PAISLEY,
C      SCOTLAND.
C      PA1 2BE
C
C      ( e-mail: macl_ms0@paisley.ac.uk ) 
C
C
C   LATEST REVISION:   23 January
C
C
      INTEGER NTERMA,NTERMF,NTERMG,NTERMH
      DOUBLE PRECISION AB0F(0:8),AB0G(0:8),AB0H(0:8),AB0AS(0:27),
     &     ASLN,ASVAL,CHEVAL,FVAL,GVAL,GVAL0,HALF,HVAL,
     &     LNXMIN,ONEHUN,ONERPI,RTPIB2,RT3BPI,SIX,T,
     &     THREE,TWO,V,X,XLOW1,XVALUE,ZERO
CCCCC CHARACTER FNNAME*6,ERRMSG*33
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
CCCCC DATA FNNAME/'ABRAM0'/
CCCCC DATA ERRMSG/'FUNCTION CALLED WITH ARGUMENT < 0'/
      DATA AB0F/-0.68121 92709 35494 69816  D    0,
     1          -0.78867 91981 61492 52495  D    0,
     2           0.51215 81776 81881 9543   D   -1,
     3          -0.71092 35289 45412 96     D   -3,
     4           0.36868 18085 04287        D   -5,
     5          -0.91783 23372 37           D   -8,
     6           0.12702 02563              D  -10,
     7          -0.10768 88                 D  -13,
     8           0.599                      D  -17/
      DATA AB0G/-0.60506 03943 08682 73190  D    0,
     1          -0.41950 39816 32017 79803  D    0,
     2           0.17032 65125 19037 0333   D   -1,
     3          -0.16938 91784 24913 97     D   -3,
     4           0.67638 08951 9710         D   -6,
     5          -0.13572 36362 55           D   -8,
     6           0.15629 7065               D  -11,
     7          -0.11288 7                  D  -14,
     8           0.55                       D  -18/
      DATA AB0H/1.38202 65523 05749 89705  D    0,
     1         -0.30097 92907 39749 04355  D    0,
     2          0.79428 88093 64887 241    D   -2,
     3         -0.64319 10276 84756 3      D   -4,
     4          0.22549 83068 4374         D   -6,
     5         -0.41220 96619 5            D   -9,
     6          0.44185 282                D  -12,
     7         -0.30123                    D  -15,
     8          0.14                       D  -18/
      DATA AB0AS(0)/  1.97755 49972 36930 67407  D    0/
      DATA AB0AS(1)/ -0.10460 24792 00481 9485   D   -1/
      DATA AB0AS(2)/  0.69680 79025 36253 66     D   -3/
      DATA AB0AS(3)/ -0.58982 98299 99659 9      D   -4/
      DATA AB0AS(4)/  0.57716 44553 05320        D   -5/
      DATA AB0AS(5)/ -0.61523 01336 5756         D   -6/
      DATA AB0AS(6)/  0.67853 96884 767          D   -7/
      DATA AB0AS(7)/ -0.72306 25379 07           D   -8/
      DATA AB0AS(8)/  0.63306 62736 5            D   -9/
      DATA AB0AS(9)/ -0.98945 3793               D  -11/
      DATA AB0AS(10)/-0.16819 80530              D  -10/
      DATA AB0AS(11)/ 0.67379 9551               D  -11/
      DATA AB0AS(12)/-0.20099 7939               D  -11/
      DATA AB0AS(13)/ 0.54055 903                D  -12/
      DATA AB0AS(14)/-0.13816 679                D  -12/
      DATA AB0AS(15)/ 0.34222 05                 D  -13/
      DATA AB0AS(16)/-0.82668 6                  D  -14/
      DATA AB0AS(17)/ 0.19456 6                  D  -14/
      DATA AB0AS(18)/-0.44268                    D  -15/
      DATA AB0AS(19)/ 0.9562                     D  -16/
      DATA AB0AS(20)/-0.1883                     D  -16/
      DATA AB0AS(21)/ 0.301                      D  -17/
      DATA AB0AS(22)/-0.19                       D  -18/
      DATA AB0AS(23)/-0.14                       D  -18/
      DATA AB0AS(24)/ 0.11                       D  -18/
      DATA AB0AS(25)/-0.4                        D  -19/
      DATA AB0AS(26)/ 0.2                        D  -19/
      DATA AB0AS(27)/-0.1                        D  -19/
      DATA ZERO,HALF,TWO/ 0.0 D 0 , 0.5 D 0, 2.0 D 0/
      DATA THREE,SIX,ONEHUN/ 3.0 D 0, 6.0 D 0 , 100.0 D 0/
      DATA RT3BPI/0.97720 50238 05839 84317 D 0/
      DATA RTPIB2/0.88622 69254 52758 01365 D 0/
      DATA GVAL0/0.13417 65026 47700 70909 D 0/
      DATA ONERPI/0.56418 95835 47756 28695 D 0/
C
C   Start computation
C
      X = XVALUE
C
C   Error test
C
      IF ( X .LT. ZERO ) THEN
CCCCC    CALL ERRPRN(FNNAME,ERRMSG)
         WRITE(ICOUT,999)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,101)X
         CALL DPWRST('XXX','BUG ')
         ABRAM0 = ZERO
         RETURN
      ENDIF
  999 FORMAT(1X)
  101 FORMAT('***** ERROR FROM ABRAM0--ARGUMENT MUST BE ',
     1       'NON-NEGATIVE, ARGUMENT = ',G15.7)
C
C   Compute the machine-dependent constants.
C
      T = D1MACH(4) / ONEHUN
      IF ( X .LE. TWO ) THEN
         DO 10 NTERMF = 8 , 0 , -1
            IF ( ABS(AB0F(NTERMF)) .GT. T ) GOTO 19
 10      CONTINUE
 19      DO 20 NTERMG = 8 , 0 , -1
            IF ( ABS(AB0G(NTERMG)) .GT. T ) GOTO 29
 20      CONTINUE
 29      DO 30 NTERMH = 8 , 0 , -1
            IF ( ABS(AB0H(NTERMH)) .GT. T ) GOTO 39
 30      CONTINUE 
 39      XLOW1 = SQRT ( TWO * D1MACH(3) )
      ELSE
         DO 40 NTERMA = 27 , 0 , -1
            IF ( ABS(AB0AS(NTERMA)) .GT. T ) GOTO 49
 40      CONTINUE
 49      LNXMIN = LOG(D1MACH(1))
      ENDIF
C
C   Code for 0 <= XVALUE <= 2
C
      IF ( X .LE. TWO ) THEN
         IF ( X .EQ. ZERO ) THEN
            ABRAM0 = RTPIB2
            RETURN
         ENDIF
         IF ( X .LT. XLOW1 ) THEN
            ABRAM0 = RTPIB2 + X * ( LOG( X ) - GVAL0 ) 
            RETURN
         ELSE
            T =  ( X * X / TWO - HALF ) - HALF
            FVAL = CHEVAL( NTERMF,AB0F,T ) 
            GVAL = CHEVAL( NTERMG,AB0G,T ) 
            HVAL = CHEVAL( NTERMH,AB0H,T ) 
            ABRAM0 = FVAL/ONERPI + X * ( LOG( X ) * HVAL- GVAL ) 
            RETURN
         ENDIF
      ELSE
C
C   Code for XVALUE > 2
C
         V = THREE *  ( (X / TWO) ** ( TWO / THREE ) ) 
         T =  ( SIX/V - HALF ) - HALF         
         ASVAL = CHEVAL( NTERMA,AB0AS,T ) 
         ASLN = LOG( ASVAL / RT3BPI ) - V
         IF ( ASLN .LT. LNXMIN ) THEN
            ABRAM0 = ZERO
         ELSE
            ABRAM0 = EXP( ASLN ) 
         ENDIF
         RETURN
      ENDIF
      END
      DOUBLE PRECISION FUNCTION ABRAM1(XVALUE)
C
C   DESCRIPTION:
C      This function calculates the Abramowitz function of order 1,
C      defined as
C
C       ABRAM1(x) = integral{ 0 to infinity } t * exp( -t*t - x/t ) dt
C
C       The code uses Chebyshev expansions with the coefficients
C       given to an accuracy of 20 decimal places.
C
C
C   ERROR RETURNS:
C      If XVALUE < 0.0, the function prints a message and returns the 
C      value 0.0.
C
C
C   MACHINE-DEPENDENT CONSTANTS:
C
C      NTERMF - INTEGER - No. of terms needed for the array AB1F.
C               Recommended value such that 
C                     ABS( AB1F(NTERMF) ) < EPS/100
C
C      NTERMG - INTEGER - No. of terms needed for array AB1G.
C               Recommended value such that
C                     ABS( AB1G(NTERMG) ) < EPS/100
C
C      NTERMH - INTEGER - No. of terms needed for array AB1H.
C               Recommended value such that
C                     ABS( AB1H(NTERMH) ) < EPS/100
C
C      NTERMA - INTEGER - No. of terms needed for array AB1AS.
C               Recommended value such that
C                     ABS( AB1AS(NTERMA) ) < EPS/100 
C
C      XLOW - DOUBLE PRECISION - The value below which
C                ABRAM1(x) = 0.5 to machine precision.
C             The recommended value is EPSNEG/2
C
C      XLOW1 - DOUBLE PRECISION - The value below which 
C                ABRAM1(x) = (1 - x ( sqrt(pi) + xln(x) ) / 2 
C              Recommended value is SQRT(2*EPSNEG)
C
C      LNXMIN - DOUBLE PRECISION - The value of ln XMIN. Used to prevent
C              exponential underflow for large X.
C
C      For values of EPS, EPSNEG, XMIN refer to the file MACHCON.TXT
C
C      The machine-dependent constants are computed internally by using
C      the D1MACH subroutine.
C
C
C   INTRINSIC FUNCTIONS USED:
C
C     LOG, EXP, SQRT
C
C
C   OTHER MISCFUN SUBROUTINES USED:
C
C          CHEVAL , ERRPRN, D1MACH
C
C
C   AUTHOR:
C
C      DR. ALLAN J. MACLEOD,
C      DEPT. OF MATHEMATICS AND STATISTICS,
C      UNIVERSITY OF PAISLEY,
C      HIGH ST.,
C      PAISLEY,
C      SCOTLAND.
C      PA1 2BE
C
C      ( e-mail: macl_ms0@paisley.ac.uk ) 
C
C
C   LATEST REVISION:   23 January, 1996
C
C
      INTEGER NTERMA,NTERMF,NTERMG,NTERMH
      DOUBLE PRECISION AB1F(0:9),AB1G(0:8),AB1H(0:8),AB1AS(0:27),
     &     ASLN,ASVAL,CHEVAL,FVAL,GVAL,HALF,HVAL,
     &     LNXMIN,ONE,ONEHUN,ONERPI,RT3BPI,SIX,T,THREE,TWO,
     &     V,X,XLOW,XLOW1,XVALUE,ZERO
CCCCC CHARACTER FNNAME*6,ERRMSG*33
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
CCCCC DATA FNNAME/'ABRAM1'/
CCCCC DATA ERRMSG/'FUNCTION CALLED WITH ARGUMENT < 0'/
      DATA AB1F/1.47285 19257 79788 07369  D    0,
     1          0.10903 49757 01689 56257  D    0,
     2         -0.12430 67536 00565 69753  D    0,
     3          0.30619 79468 53493 315    D   -2,
     4         -0.22184 10323 07651 1      D   -4,
     5          0.69899 78834 451          D   -7,
     6         -0.11597 07644 4            D   -9,
     7          0.11389 776                D  -12,
     8         -0.7173                     D  -16,
     9          0.3                        D  -19/
      DATA AB1G/0.39791 27794 90545 03528  D    0,
     1         -0.29045 28522 64547 20849  D    0,
     2          0.10487 84695 46536 3504   D   -1,
     3         -0.10249 86952 26913 36     D   -3,
     4          0.41150 27939 9110         D   -6,
     5         -0.83652 63894 0            D   -9,
     6          0.97862 595                D  -12,
     7         -0.71868                    D  -15,
     8          0.35                       D  -18/
      DATA AB1H/0.84150 29215 22749 47030  D    0,
     1         -0.77900 50698 77414 3395   D   -1,
     2          0.13399 24558 78390 993    D   -2,
     3         -0.80850 39071 52788        D   -5,
     4          0.22618 58281 728          D   -7,
     5         -0.34413 95838              D  -10,
     6          0.31598 58                 D  -13,
     7         -0.1884                     D  -16,
     8          0.1                        D  -19/
      DATA AB1AS(0)/  2.13013 64342 90655 49448  D    0/
      DATA AB1AS(1)/  0.63715 26795 21853 9933   D   -1/
      DATA AB1AS(2)/ -0.12933 49174 77510 647    D   -2/
      DATA AB1AS(3)/  0.56783 28753 22826 5      D   -4/
      DATA AB1AS(4)/ -0.27943 49391 77646        D   -5/
      DATA AB1AS(5)/  0.56002 14736 787          D   -7/
      DATA AB1AS(6)/  0.23920 09242 798          D   -7/
      DATA AB1AS(7)/ -0.75098 48650 09           D   -8/
      DATA AB1AS(8)/  0.17301 53307 76           D   -8/
      DATA AB1AS(9)/ -0.36648 87795 5            D   -9/
      DATA AB1AS(10)/ 0.75207 58307              D  -10/
      DATA AB1AS(11)/-0.15179 90208              D  -10/
      DATA AB1AS(12)/ 0.30171 3710               D  -11/
      DATA AB1AS(13)/-0.58596 718                D  -12/
      DATA AB1AS(14)/ 0.10914 455                D  -12/
      DATA AB1AS(15)/-0.18705 36                 D  -13/
      DATA AB1AS(16)/ 0.26254 2                  D  -14/
      DATA AB1AS(17)/-0.14627                    D  -15/
      DATA AB1AS(18)/-0.9500                     D  -16/
      DATA AB1AS(19)/ 0.5873                     D  -16/
      DATA AB1AS(20)/-0.2420                     D  -16/
      DATA AB1AS(21)/ 0.868                      D  -17/
      DATA AB1AS(22)/-0.290                      D  -17/
      DATA AB1AS(23)/ 0.93                       D  -18/
      DATA AB1AS(24)/-0.29                       D  -18/
      DATA AB1AS(25)/ 0.9                        D  -19/
      DATA AB1AS(26)/-0.3                        D  -19/
      DATA AB1AS(27)/ 0.1                        D  -19/
      DATA ZERO,HALF,ONE/ 0.0 D 0, 0.5 D 0, 1.0 D 0/
      DATA TWO,THREE,SIX/ 2.0 D 0, 3.0 D 0, 6.0 D 0/
      DATA ONEHUN/100.0 D 0/
      DATA RT3BPI/ 0.97720 50238 05839 84317 D 0/
      DATA ONERPI/ 0.56418 95835 47756 28695 D 0/
C
C   Start calculation
C
      X = XVALUE
C
C   Error test
C
      IF ( X .LT. ZERO ) THEN
CCCCC    CALL ERRPRN(FNNAME,ERRMSG)
         WRITE(ICOUT,999)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,101)X
         CALL DPWRST('XXX','BUG ')
         ABRAM1 = ZERO
         RETURN
      ENDIF   
  999 FORMAT(1X)
  101 FORMAT('***** ERROR FROM ABRAM1--ARGUMENT MUST BE ',
     1       'NON-NEGATIVE, ARGUMENT = ',G15.7)
C
C   Compute the machine-dependent constants.
C
      T = D1MACH(4) / ONEHUN
      IF ( X .LE. TWO ) THEN
         DO 10 NTERMF = 9 , 0 , -1
            IF ( ABS(AB1F(NTERMF)) .GT. T ) GOTO 19
 10      CONTINUE
 19      DO 20 NTERMG = 8 , 0 , -1
            IF ( ABS(AB1G(NTERMG)) .GT. T ) GOTO 29
 20      CONTINUE
 29      DO 30 NTERMH = 8 , 0 , -1
            IF ( ABS(AB1H(NTERMH)) .GT. T ) GOTO 39
 30      CONTINUE 
 39      T = D1MACH(3)
         XLOW1 = SQRT ( TWO * T )
         XLOW = T / TWO
      ELSE
         DO 40 NTERMA = 27 , 0 , -1
            IF ( ABS(AB1AS(NTERMA)) .GT. T ) GOTO 49
 40      CONTINUE
 49      LNXMIN = LOG(D1MACH(1))
      ENDIF
C
C   Code for 0 <= XVALUE <= 2
C
      IF ( X .LE. TWO ) THEN
         IF ( X .EQ. ZERO ) THEN
            ABRAM1 = HALF
            RETURN
         ENDIF
         IF ( X .LT. XLOW1 ) THEN
            IF ( X .LT. XLOW ) THEN
               ABRAM1 = HALF
            ELSE
               ABRAM1 = ( ONE - X / ONERPI - X * X * LOG( X ) ) * HALF
            ENDIF
            RETURN
         ELSE
            T =  ( X * X / TWO - HALF ) - HALF
            FVAL = CHEVAL( NTERMF,AB1F,T ) 
            GVAL = CHEVAL( NTERMG,AB1G,T ) 
            HVAL = CHEVAL( NTERMH,AB1H,T ) 
            ABRAM1 = FVAL - X * ( GVAL / ONERPI + X * LOG( X ) * HVAL )
            RETURN
         ENDIF
      ELSE
C
C   Code for XVALUE > 2
C
         V = THREE *  ( (X / TWO) ** ( TWO / THREE ) ) 
         T =  ( SIX / V - HALF ) - HALF         
         ASVAL = CHEVAL( NTERMA,AB1AS,T ) 
         ASLN = LOG( ASVAL * SQRT ( V / THREE ) / RT3BPI ) - V
         IF ( ASLN .LT. LNXMIN ) THEN
            ABRAM1 = ZERO
         ELSE
            ABRAM1 = EXP( ASLN ) 
         ENDIF
         RETURN
      ENDIF
      END
      DOUBLE PRECISION FUNCTION ABRAM2(XVALUE)
C
C   DESCRIPTION:
C      This function calculates the Abramowitz function of order 2,
C      defined as
C
C       ABRAM2(x) = integral{ 0 to infinity } (t**2) * exp( -t*t - x/t ) dt
C
C      The code uses Chebyshev expansions with the coefficients
C      given to an accuracy of 20 decimal places. 
C
C
C   ERROR RETURNS:
C      If XVALUE < 0.0, the function prints a message and returns the 
C      value 0.0.
C
C
C   MACHINE-DEPENDENT CONSTANTS:
C
C      NTERMF - INTEGER - No. of terms needed for the array AB2F.
C               Recommended value such that 
C                     ABS( AB2F(NTERMF) ) < EPS/100
C
C      NTERMG - INTEGER - No. of terms needed for array AB2G.
C               Recommended value such that
C                     ABS( AB2G(NTERMG) ) < EPS/100
C
C      NTERMH - INTEGER - No. of terms needed for array AB2H.
C               Recommended value such that
C                     ABS( AB2H(NTERMH) ) < EPS/100
C
C      NTERMA - INTEGER - No. of terms needed for array AB2AS.
C               Recommended value such that
C                     ABS( AB2AS(NTERMA) ) < EPS/100 
C
C      XLOW - DOUBLE PRECISION - The value below which 
C               ABRAM2 = root(pi)/4 to machine precision.
C             The recommended value is EPSNEG
C
C      XLOW1 - DOUBLE PRECISION - The value below which 
C                ABRAM2 = root(pi)/4 - x/2 + x**3ln(x)/6
C              Recommended value is SQRT(2*EPSNEG)
C
C      LNXMIN - DOUBLE PRECISION - The value of ln XMIN. Used to prevent
C               exponential underflow for large X.
C
C     For values of EPS, EPSNEG, XMIN refer to the file MACHCON.TXT
C
C     The machine-dependent constants are computed internally by
C     using the D1MACH subroutine.
C
C
C   INTRINSIC FUNCTIONS USED:
C
C     LOG, EXP
C
C
C   OTHER MISCFUN SUBROUTINES USED:
C
C          CHEVAL , ERRPRN, D1MACH
C
C
C   AUTHOR:
C
C      DR. ALLAN J. MACLEOD,
C      DEPT. OF MATHEMATICS AND STATISTICS,
C      UNIVERSITY OF PAISLEY,
C      HIGH ST.,
C      PAISLEY,
C      SCOTLAND.
C      PA1 2BE
C
C      ( e-mail: macl_ms0@paisley.ac.uk ) 
C
C
C   LATEST REVISION:   23 January, 1996
C
C
      INTEGER NTERMA,NTERMF,NTERMG,NTERMH
      DOUBLE PRECISION AB2F(0:9),AB2G(0:8),AB2H(0:7),AB2AS(0:26),
     &     ASLN,ASVAL,CHEVAL,FVAL,GVAL,HALF,HVAL,LNXMIN,
     &     ONEHUN,ONERPI,RTPIB4,RT3BPI,SIX,T,THREE,TWO,
     &     V,X,XLOW,XLOW1,XVALUE,ZERO
CCCCC CHARACTER FNNAME*6,ERRMSG*33
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
CCCCC DATA FNNAME/'ABRAM2'/
CCCCC DATA ERRMSG/'FUNCTION CALLED WITH ARGUMENT < 0'/
      DATA AB2F/1.03612 16280 42437 13846  D    0,
     1          0.19371 24662 67945 70012  D    0,
     2         -0.72587 58839 23300 7378   D   -1,
     3          0.17479 05908 64327 399    D   -2,
     4         -0.12812 23233 75654 9      D   -4,
     5          0.41150 18153 651          D   -7,
     6         -0.69710 47256              D  -10,
     7          0.69901 83                 D  -13,
     8         -0.4492                     D  -16,
     9          0.2                        D  -19/
      DATA AB2G/1.46290 15719 86307 41150  D    0,
     1          0.20189 46688 31540 14317  D    0,
     2         -0.29082 92087 99712 9022   D   -1,
     3          0.47061 04903 52700 50     D   -3,
     4         -0.25792 20803 59333        D   -5,
     5          0.65613 37129 46           D   -8,
     6         -0.91411 0203               D  -11,
     7          0.77427 6                  D  -14,
     8         -0.429                      D  -17/
      DATA AB2H/0.30117 22501 09104 88881  D    0,
     1         -0.15886 67818 31762 3783   D   -1,
     2          0.19295 93693 55845 26     D   -3,
     3         -0.90199 58784 9300         D   -6,
     4          0.20610 50418 37           D   -8,
     5         -0.26511 1806               D  -11,
     6          0.21086 4                  D  -14,
     7         -0.111                      D  -17/
      DATA AB2AS(0)/  2.46492 32530 43348 56893  D    0/
      DATA AB2AS(1)/  0.23142 79742 22489 05432  D    0/
      DATA AB2AS(2)/ -0.94068 17301 00857 73     D   -3/
      DATA AB2AS(3)/  0.82902 70038 08973 3      D   -4/
      DATA AB2AS(4)/ -0.88389 47042 45866        D   -5/
      DATA AB2AS(5)/  0.10663 85435 67985        D   -5/
      DATA AB2AS(6)/ -0.13991 12853 8529         D   -6/
      DATA AB2AS(7)/  0.19397 93208 445          D   -7/
      DATA AB2AS(8)/ -0.27704 99383 75           D   -8/
      DATA AB2AS(9)/  0.39590 68718 6            D   -9/
      DATA AB2AS(10)/-0.54083 54342              D  -10/
      DATA AB2AS(11)/ 0.63554 6076               D  -11/
      DATA AB2AS(12)/-0.38461 613                D  -12/
      DATA AB2AS(13)/-0.11696 067                D  -12/
      DATA AB2AS(14)/ 0.68966 71                 D  -13/
      DATA AB2AS(15)/-0.25031 13                 D  -13/
      DATA AB2AS(16)/ 0.78558 6                  D  -14/
      DATA AB2AS(17)/-0.23033 4                  D  -14/
      DATA AB2AS(18)/ 0.64914                    D  -15/
      DATA AB2AS(19)/-0.17797                    D  -15/
      DATA AB2AS(20)/ 0.4766                     D  -16/
      DATA AB2AS(21)/-0.1246                     D  -16/
      DATA AB2AS(22)/ 0.316                      D  -17/
      DATA AB2AS(23)/-0.77                       D  -18/
      DATA AB2AS(24)/ 0.18                       D  -18/
      DATA AB2AS(25)/-0.4                        D  -19/
      DATA AB2AS(26)/ 0.1                        D  -19/
      DATA ZERO,HALF,TWO/ 0.0 D 0 , 0.5 D 0, 2.0 D 0/
      DATA THREE,SIX,ONEHUN/ 3.0 D 0, 6.0 D 0 , 100.0 D 0/
      DATA RT3BPI/ 0.97720 50238 05839 84317 D 0/
      DATA RTPIB4/ 0.44311 34627 26379 00682 D 0/
      DATA ONERPI/ 0.56418 95835 47756 28695 D 0/
C
C   Start calculation
C
      X = XVALUE
C
C   Error test
C
      IF ( X .LT. ZERO ) THEN
CCCCC    CALL ERRPRN(FNNAME,ERRMSG)
         WRITE(ICOUT,999)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,101)X
         CALL DPWRST('XXX','BUG ')
         ABRAM2 = ZERO
         RETURN
      ENDIF
  999 FORMAT(1X)
  101 FORMAT('***** ERROR FROM ABRAM2--ARGUMENT MUST BE ',
     1       'NON-NEGATIVE, ARGUMENT = ',G15.7)
C
C   Compute the machine-dependent constants.
C
      T = D1MACH(4) / ONEHUN
      IF ( X .LE. TWO ) THEN
         DO 10 NTERMF = 9 , 0 , -1
            IF ( ABS(AB2F(NTERMF)) .GT. T ) GOTO 19
 10      CONTINUE
 19      DO 20 NTERMG = 8 , 0 , -1
            IF ( ABS(AB2G(NTERMG)) .GT. T ) GOTO 29
 20      CONTINUE
 29      DO 30 NTERMH = 7 , 0 , -1
            IF ( ABS(AB2H(NTERMH)) .GT. T ) GOTO 39
 30      CONTINUE
 39      XLOW = D1MACH(3)
         XLOW1 = SQRT ( TWO * XLOW )
      ELSE
         DO 40 NTERMA = 26 , 0 , -1
            IF ( ABS(AB2AS(NTERMA)) .GT. T ) GOTO 49
 40      CONTINUE
 49      LNXMIN = LOG(D1MACH(1))
      ENDIF
C
C   Code for 0 <= XVALUE <= 2
C
      IF ( X .LE. TWO ) THEN
         IF ( X .EQ. ZERO ) THEN
            ABRAM2 = RTPIB4
            RETURN
         ENDIF
         IF ( X .LT. XLOW1 ) THEN
            IF ( X .LT. XLOW ) THEN
               ABRAM2 = RTPIB4
            ELSE
               ABRAM2 = RTPIB4 - HALF * X + X * X * X * LOG( X ) / SIX
            ENDIF 
            RETURN
         ELSE
            T =  ( X * X / TWO - HALF ) - HALF
            FVAL = CHEVAL( NTERMF,AB2F,T ) 
            GVAL = CHEVAL( NTERMG,AB2G,T ) 
            HVAL = CHEVAL( NTERMH,AB2H,T ) 
            ABRAM2 = FVAL/ONERPI + X * ( X * X * LOG(X) * HVAL- GVAL ) 
            RETURN
         ENDIF
      ELSE
C
C   Code for XVALUE > 2
C
         V = THREE *  ( (X / TWO) ** ( TWO / THREE ) ) 
         T =  ( SIX / V - HALF ) - HALF         
         ASVAL = CHEVAL( NTERMA,AB2AS,T ) 
         ASLN = LOG( ASVAL / RT3BPI ) + LOG( V / THREE ) - V
         IF ( ASLN .LT. LNXMIN ) THEN
            ABRAM2 = ZERO
         ELSE
            ABRAM2 = EXP( ASLN ) 
         ENDIF
         RETURN
      ENDIF
      END
      SUBROUTINE ADAPT(NDIM, MINCLS, MAXCLS, FUNCTN,
     &     ABSREQ, RELREQ, LENWRK, WORK, ABSEST, FINEST, INFORM)
*
*   Adaptive Multidimensional Integration Subroutine
*
*   Author: Alan Genz
*           Department of Mathematics
*           Washington State University
*           Pullman, WA 99164-3113 USA
*
*  This subroutine computes an approximation to the integral
*
*      1 1     1
*     I I ... I       FUNCTN(NDIM,X)  dx(NDIM)...dx(2)dx(1)
*      0 0     0  
*
***************  Parameters for ADAPT  ********************************
*
****** Input Parameters
*
*  NDIM    Integer number of integration variables.
*  MINCLS  Integer minimum number of FUNCTN calls to be allowed; MINCLS
*          must not exceed MAXCLS. If MINCLS < 0, then ADAPT assumes
*          that a previous call of ADAPT has been made with the same
*          integrand and continues that calculation.
*  MAXCLS  Integer maximum number of FUNCTN calls to be used; MAXCLS
*          must be >= RULCLS, the number of function calls required for
*          one application of the basic integration rule.
*           IF ( NDIM .EQ. 1 ) THEN
*              RULCLS = 11
*           ELSE IF ( NDIM .LT. 15 ) THEN
*              RULCLS = 2**NDIM + 2*NDIM*(NDIM+3) + 1
*           ELSE
*              RULCLS = 1 + NDIM*(24-NDIM*(6-NDIM*4))/3
*           ENDIF
*  FUNCTN  Externally declared real user defined integrand. Its 
*          parameters must be (NDIM, Z), where Z is a real array of
*          length NDIM.
*  ABSREQ  Real required absolute accuracy.
*  RELREQ  Real required relative accuracy.
*  LENWRK  Integer length of real array WORK (working storage); ADAPT
*          needs LENWRK >= 16*NDIM + 27. For maximum efficiency LENWRK
*          should be about 2*NDIM*MAXCLS/RULCLS if MAXCLS FUNCTN
*          calls are needed. If LENWRK is significantly less than this,
*          ADAPT may be less efficient.
*
****** Output Parameters
*
*  MINCLS  Actual number of FUNCTN calls used by ADAPT.
*  WORK    Real array (length LENWRK) of working storage. This contains
*          information that is needed for additional calls of ADAPT
*          using the same integrand (input MINCLS < 0).
*  ABSEST  Real estimated absolute accuracy.
*  FINEST  Real estimated value of integral.
*  INFORM  INFORM = 0 for normal exit, when ABSEST <= ABSREQ or
*                     ABSEST <= |FINEST|*RELREQ with MINCLS <= MAXCLS.
*          INFORM = 1 if MAXCLS was too small for ADAPT to obtain the
*                     result FINEST to within the requested accuracy.
*          INFORM = 2 if MINCLS > MAXCLS, LENWRK < 16*NDIM + 27 or 
*                     RULCLS > MAXCLS.
*
************************************************************************
*
*     Begin driver routine. This routine partitions the working storage 
*      array and then calls the main subroutine ADBASE.
*
      EXTERNAL FUNCTN
      INTEGER NDIM, MINCLS, MAXCLS, LENWRK, INFORM
      DOUBLE PRECISION 
     &     FUNCTN, ABSREQ, RELREQ, WORK(LENWRK), ABSEST, FINEST
      INTEGER SBRGNS, MXRGNS, RULCLS, LENRUL, 
     & INERRS, INVALS, INPTRS, INLWRS, INUPRS, INMSHS, INPNTS, INWGTS, 
     & INLOWR, INUPPR, INWDTH, INMESH, INWORK 
      IF ( NDIM .EQ. 1 ) THEN
         LENRUL = 5
         RULCLS = 9
      ELSE IF ( NDIM .LT. 12 ) THEN
         LENRUL = 6
         RULCLS = 2**NDIM + 2*NDIM*(NDIM+2) + 1
      ELSE
         LENRUL = 6
         RULCLS = 1 + 2*NDIM*(1+2*NDIM)
      ENDIF
      IF ( LENWRK .GE. LENRUL*(NDIM+4) + 10*NDIM + 3 .AND.
     &     RULCLS. LE. MAXCLS .AND. MINCLS .LE. MAXCLS ) THEN
        MXRGNS = ( LENWRK - LENRUL*(NDIM+4) - 7*NDIM )/( 3*NDIM + 3 )
        INERRS = 1
        INVALS = INERRS + MXRGNS
        INPTRS = INVALS + MXRGNS
        INLWRS = INPTRS + MXRGNS
        INUPRS = INLWRS + MXRGNS*NDIM
        INMSHS = INUPRS + MXRGNS*NDIM
        INWGTS = INMSHS + MXRGNS*NDIM
        INPNTS = INWGTS + LENRUL*4
        INLOWR = INPNTS + LENRUL*NDIM
        INUPPR = INLOWR + NDIM
        INWDTH = INUPPR + NDIM
        INMESH = INWDTH + NDIM
        INWORK = INMESH + NDIM
        IF ( MINCLS .LT. 0 ) SBRGNS = WORK(LENWRK)
        CALL ADBASE(NDIM, MINCLS, MAXCLS, FUNCTN, ABSREQ, RELREQ, 
     &       ABSEST, FINEST, SBRGNS, MXRGNS, RULCLS, LENRUL, 
     &       WORK(INERRS), WORK(INVALS), WORK(INPTRS), WORK(INLWRS), 
     &       WORK(INUPRS), WORK(INMSHS), WORK(INWGTS), WORK(INPNTS), 
     &       WORK(INLOWR), WORK(INUPPR), WORK(INWDTH), WORK(INMESH), 
     &       WORK(INWORK), INFORM)
        WORK(LENWRK) = SBRGNS
       ELSE
        INFORM = 2
        MINCLS = RULCLS
      ENDIF
C
      RETURN
      END
      SUBROUTINE ADBASE(NDIM, MINCLS, MAXCLS, FUNCTN, ABSREQ, RELREQ,
     &     ABSEST, FINEST, SBRGNS, MXRGNS, RULCLS, LENRUL,
     &     ERRORS, VALUES, PONTRS, LOWERS, 
     &     UPPERS, MESHES, WEGHTS, POINTS, 
     &     LOWER, UPPER, WIDTH, MESH, WORK, INFORM)
*
*        Main adaptive integration subroutine
*
      EXTERNAL FUNCTN
      INTEGER I, J, NDIM, MINCLS, MAXCLS, SBRGNS, MXRGNS, 
     &     RULCLS, LENRUL, INFORM, NWRGNS 
      DOUBLE PRECISION FUNCTN, ABSREQ, RELREQ, ABSEST, FINEST,   
     &     ERRORS(*), VALUES(*), PONTRS(*),
     &     LOWERS(NDIM,*), UPPERS(NDIM,*),
     &     MESHES(NDIM,*),WEGHTS(*), POINTS(*),
     &     LOWER(*), UPPER(*), WIDTH(*), MESH(*), WORK(*) 
      INTEGER DIVAXN, TOP, RGNCLS, FUNCLS, DIFCLS
      
*
*     Initialization of subroutine
*
      INFORM = 2
      FUNCLS = 0
      CALL BSINIT(NDIM, WEGHTS, LENRUL, POINTS)
      IF ( MINCLS .GE. 0) THEN
*
*       When MINCLS >= 0 determine initial subdivision of the
*       integration region and apply basic rule to each subregion.
*
         SBRGNS = 0
         DO 100 I = 1,NDIM
            LOWER(I) = 0
            MESH(I) = 1
            WIDTH(I) = 1/(2*MESH(I))
            UPPER(I) = 1
 100     CONTINUE
         DIVAXN = 0
         RGNCLS = RULCLS
         NWRGNS = 1
 10      CALL DIFFER(NDIM, LOWER, UPPER, WIDTH, WORK, WORK(NDIM+1),  
     &        FUNCTN, DIVAXN, DIFCLS)
         FUNCLS = FUNCLS + DIFCLS
         IF ( FUNCLS + RGNCLS*(MESH(DIVAXN)+1)/MESH(DIVAXN)
     &        .LE. MINCLS ) THEN
            RGNCLS = RGNCLS*(MESH(DIVAXN)+1)/MESH(DIVAXN)
            NWRGNS = NWRGNS*(MESH(DIVAXN)+1)/MESH(DIVAXN)
            MESH(DIVAXN) = MESH(DIVAXN) + 1
            WIDTH(DIVAXN) = 1/( 2*MESH(DIVAXN) )
            GO TO 10
         ENDIF
         IF ( NWRGNS .LE. MXRGNS ) THEN
            DO 200 I = 1,NDIM
               UPPER(I) = LOWER(I) + 2*WIDTH(I)
               MESH(I) = 1
 200        CONTINUE
         ENDIF
*     
*     Apply basic rule to subregions and store results in heap.
*     
 20      SBRGNS = SBRGNS + 1
         CALL BASRUL(NDIM, LOWER, UPPER, WIDTH, FUNCTN, 
     &        WEGHTS, LENRUL, POINTS, WORK, WORK(NDIM+1), 
     &        ERRORS(SBRGNS),VALUES(SBRGNS))
         CALL TRESTR(SBRGNS, SBRGNS, PONTRS, ERRORS)
         DO 300 I = 1,NDIM
            LOWERS(I,SBRGNS) = LOWER(I)
            UPPERS(I,SBRGNS) = UPPER(I)
            MESHES(I,SBRGNS) = MESH(I)
  300    CONTINUE
         DO 400 I = 1,NDIM
            LOWER(I) = UPPER(I)
            UPPER(I) = LOWER(I) + 2*WIDTH(I)
            IF ( LOWER(I)+WIDTH(I) .LT. 1 )  GO TO 20
            LOWER(I) = 0
            UPPER(I) = LOWER(I) + 2*WIDTH(I)
  400    CONTINUE
         FUNCLS = FUNCLS + SBRGNS*RULCLS
      ENDIF
*     
*     Check for termination
*
 30   FINEST = 0
      ABSEST = 0
      DO 500 I = 1, SBRGNS
         FINEST = FINEST + VALUES(I)
         ABSEST = ABSEST + ERRORS(I)
 500  CONTINUE
      IF ( ABSEST .GT. MAX( ABSREQ, RELREQ*ABS(FINEST) )
     &     .OR. FUNCLS .LT. MINCLS ) THEN  
*     
*     Prepare to apply basic rule in (parts of) subregion with
*     largest error.
*     
         TOP = PONTRS(1)
         RGNCLS = RULCLS
         DO 600 I = 1,NDIM
            LOWER(I) = LOWERS(I,TOP)
            UPPER(I) = UPPERS(I,TOP)
            MESH(I) = MESHES(I,TOP)
            WIDTH(I) = (UPPER(I)-LOWER(I))/(2*MESH(I))
            RGNCLS = RGNCLS*MESH(I)
  600    CONTINUE
         CALL DIFFER(NDIM, LOWER, UPPER, WIDTH, WORK, WORK(NDIM+1),  
     &        FUNCTN, DIVAXN, DIFCLS)
         FUNCLS = FUNCLS + DIFCLS
         RGNCLS = RGNCLS*(MESH(DIVAXN)+1)/MESH(DIVAXN)
         IF ( FUNCLS + RGNCLS .LE. MAXCLS ) THEN
            IF ( SBRGNS + 1 .LE. MXRGNS ) THEN
*     
*     Prepare to subdivide into two pieces.
*    
               NWRGNS = 1
               WIDTH(DIVAXN) = WIDTH(DIVAXN)/2
            ELSE
               NWRGNS = 0
               WIDTH(DIVAXN) = WIDTH(DIVAXN)
     &                        *MESH(DIVAXN)/( MESH(DIVAXN) + 1 )
               MESHES(DIVAXN,TOP) = MESH(DIVAXN) + 1 
            ENDIF
            IF ( NWRGNS .GT. 0 ) THEN
*     
*     Only allow local subdivision when space is available.
*
               DO 700 J = SBRGNS+1,SBRGNS+NWRGNS
                  DO 800 I = 1,NDIM
                     LOWERS(I,J) = LOWER(I)
                     UPPERS(I,J) = UPPER(I)
                     MESHES(I,J) = MESH(I)
  800             CONTINUE
  700          CONTINUE
               UPPERS(DIVAXN,TOP) = LOWER(DIVAXN) + 2*WIDTH(DIVAXN)
               LOWERS(DIVAXN,SBRGNS+1) = UPPERS(DIVAXN,TOP)
            ENDIF
            FUNCLS = FUNCLS + RGNCLS
            CALL BASRUL(NDIM, LOWERS(1,TOP), UPPERS(1,TOP), WIDTH, 
     &           FUNCTN, WEGHTS, LENRUL, POINTS, WORK, WORK(NDIM+1), 
     &           ERRORS(TOP), VALUES(TOP))
            CALL TRESTR(TOP, SBRGNS, PONTRS, ERRORS)
            DO 900 I = SBRGNS+1, SBRGNS+NWRGNS
*     
*     Apply basic rule and store results in heap.
*     
               CALL BASRUL(NDIM, LOWERS(1,I), UPPERS(1,I), WIDTH,
     &              FUNCTN, WEGHTS, LENRUL, POINTS, WORK, WORK(NDIM+1),  
     &              ERRORS(I), VALUES(I))
               CALL TRESTR(I, I, PONTRS, ERRORS)
  900       CONTINUE
            SBRGNS = SBRGNS + NWRGNS
            GO TO 30
         ELSE
            INFORM = 1
         ENDIF
      ELSE
         INFORM = 0
      ENDIF
      MINCLS = FUNCLS
C
      RETURN
      END
      SUBROUTINE ADECDF(X,AK,IADEDF,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE ASYMMETRIC LAPLACE DISTRIBUTION
C              (OR ASYMMETRIC DOUBLE EXPONENTIAL)
C              WITH SHAPE PARAMETER = K.
C              THIS DISTRIBUTION IS DEFINED FOR ALL X AND HAS
C              THE PROBABILITY DENSITY FUNCTION
C                 ADECDF(X,K) = 1 - (1/(1+K*K))*
C                               EXP(-SQRT(2)*K*ABS(X))    X >= 0
C                 ADECDF(X,K) = (K*K/(1+K*K))*
C                               EXP((-SQRT(2)/K)*ABS(X))  X >= 0
C                 ADECDF(X,K) = (SQRT(2)*K/(1+K^2))*
C                               EXP((-SQRT(2)/K)*ABS(X))  X < 0
C     INPUT  ARGUMENTS--X     = THE SINGLE PRECISION VALUE AT
C                               WHICH THE CUMULATIVE DISTRIBUTION
C                               FUNCTION IS TO BE EVALUATED.
C                               X SHOULD BE NON-NEGATIVE.
C                     --AK    = THE SHAPE PARAMETER
C     OUTPUT ARGUMENTS--CDF   = THE SINGLE PRECISION CUMULATIVE
C                               DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION FUNCTION
C             VALUE CDF FOR THE ASYMMETRIC LAPLACE DISTRIBUTION
C             WITH SHAPE PARAMETER = K.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--EXP.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--KOTZ, KOZUBOWSKI, AND PODGORSKI, "THE LAPLACE
C                 DISTRIBUTION AND GENERALIZATIONS: A REVISIT WITH
C                 APPLICATIONS TO COMMUNICATIONS, ECONOMICS,
C                 ENGINEERING, AND FINANCE", BIRKHAUSR, 2001,
C                 PP. 134.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004.6
C     ORIGINAL VERSION--JUNE      2004.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DK
      DOUBLE PRECISION DCDF
      DOUBLE PRECISION DTERM1
C
      CHARACTER*4 IADEDF
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----DATA STATEMENTS-------------------------------------------------
C
C-----START POINT-----------------------------------------------------
C
C               ************************************
C               **  STEP 1--                      **
C               **  COMPUTE THE CDF     FUNCTION  **
C               ************************************
C
      IF(IADEDF.EQ.'K')THEN
        IF(AK.LE.0.0)THEN
          WRITE(ICOUT,5)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,48)AK
          CALL DPWRST('XXX','WRIT')
          CDF=0.0
          GOTO9000
        ENDIF
      ELSE
        AK=SQRT(2.0)/(AK + SQRT(2.0 + AK*AK))
      ENDIF
    5 FORMAT('***** ERROR: VALUE OF SHAPE PARAMETER (K) IN ADECDF ',
     1       'ROUTINE IS NEGATIVE.')
   48 FORMAT('      VALUE OF ARGUMENT IS: ',G15.7)
C
      DX=DBLE(X)
      DK=DBLE(AK)
C
      IF(X.LT.0.0)THEN
        DTERM1=DK*DK/(1.0D0 + DK*DK)
        DCDF=DTERM1*DEXP((-DSQRT(2.0D0)/DK)*DABS(DX))
      ELSE
        DTERM1=1.0D0/(1.0D0 + DK*DK)
        DCDF=1.0D0 - DTERM1*DEXP(-DSQRT(2.0D0)*DK*DABS(DX))
      ENDIF
      CDF=REAL(DCDF)
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE ADEPDF(X,AK,IADEDF,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE ASYMMETRIC LAPLACE DISTRIBUTION
C              (OR ASYMMETRIC DOUBLE EXPONENTIAL)
C              WITH SHAPE PARAMETER = K.
C              THIS DISTRIBUTION IS DEFINED FOR ALL X AND HAS
C              THE PROBABILITY DENSITY FUNCTION
C                 ADEPDF(X,K) = (SQRT(2)*K/(1+K^2))*
C                               EXP(-SQRT(2)*K*ABS(X))  X >= 0
C                 ADEPDF(X,K) = (SQRT(2)*K/(1+K^2))*
C                               EXP((-SQRT(2)/K)*ABS(X))  X < 0
C     INPUT  ARGUMENTS--X     = THE SINGLE PRECISION VALUE AT
C                               WHICH THE PROBABILITY DENSITY
C                               FUNCTION IS TO BE EVALUATED.
C                               X SHOULD BE NON-NEGATIVE.
C                     --AK    = THE SHAPE PARAMETER
C     OUTPUT ARGUMENTS--PDF   = THE SINGLE PRECISION PROBABILITY
C                               DENSITY FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY FUNCTION
C             VALUE PDF FOR THE ASYMMETRIC LAPLACE DISTRIBUTION
C             WITH SHAPE PARAMETER = K.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--EXP.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--KOTZ, KOZUBOWSKI, AND PODGORSKI, "THE LAPLACE
C                 DISTRIBUTION AND GENERALIZATIONS: A REVISIT WITH
C                 APPLICATIONS TO COMMUNICATIONS, ECONOMICS,
C                 ENGINEERING, AND FINANCE", BIRKHAUSR, 2001,
C                 PP. 134.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004.6
C     ORIGINAL VERSION--JUNE      2004.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DK
      DOUBLE PRECISION DPDF
      DOUBLE PRECISION DTERM1
C
      CHARACTER*4 IADEDF
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----DATA STATEMENTS-------------------------------------------------
C
C-----START POINT-----------------------------------------------------
C
C               ************************************
C               **  STEP 1--                      **
C               **  COMPUTE THE DENSITY FUNCTION  **
C               ************************************
C
      IF(IADEDF.EQ.'K')THEN
        IF(AK.LE.0.0)THEN
          WRITE(ICOUT,5)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,48)AK
          CALL DPWRST('XXX','WRIT')
          PDF=0.0
          GOTO9000
        ENDIF
      ELSE
        AK=SQRT(2.0)/(AK + SQRT(2.0 + AK*AK))
      ENDIF
    5 FORMAT('***** ERROR: VALUE OF SHAPE PARAMETER (K) IN ADEPDF ',
     1       'ROUTINE IS NEGATIVE.')
   48 FORMAT('      VALUE OF ARGUMENT IS: ',G15.7)
C
      DX=DBLE(X)
      DK=DBLE(AK)
C
      DTERM1=DSQRT(2.0D0)*DK/(1.0D0+DK*DK)
      IF(X.LT.0.0)THEN
        DPDF=DTERM1*DEXP((-DSQRT(2.0D0)/DK)*DABS(DX))
      ELSE
        DPDF=DTERM1*DEXP(-DSQRT(2.0D0)*DK*DABS(DX))
      ENDIF
      PDF=REAL(DPDF)
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE ADEPPF(P,AK,IADEDF,PPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE ASYMMETRIC LAPLACE DISTRIBUTION
C              (OR ASYMMETRIC DOUBLE EXPONENTIAL)
C              WITH SHAPE PARAMETER = K.
C              THIS DISTRIBUTION IS DEFINED FOR ALL X AND HAS
C              THE PERCENT POINT FUNCTION
C                 G(P,K) = (K/SQRT(2))*LOG[((1+K**2)/K**2)*P]
C                               0 < P < K**2/(1+K**2)
C                 G(P,K) = (-1/(K*SQRT(2)))*LOG[((1+K**2)*(1-P)]
C                               K**2/(1+K**2) < P < 1
C     INPUT  ARGUMENTS--P     = THE SINGLE PRECISION VALUE AT
C                               WHICH THE PERCENT POINT
C                               FUNCTION IS TO BE EVALUATED.
C                               P SHOULD BE IN THE INTERVAL (0,1).
C                     --AK    = THE SHAPE PARAMETER
C     OUTPUT ARGUMENTS--PPF   = THE SINGLE PRECISION PERCENT POINT
C                               FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PERCENT POINT FUNCTION
C             VALUE PPF FOR THE ASYMMETRIC LAPLACE DISTRIBUTION
C             WITH SHAPE PARAMETER = K.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--LOG.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--KOTZ, KOZUBOWSKI, AND PODGORSKI, "THE LAPLACE
C                 DISTRIBUTION AND GENERALIZATIONS: A REVISIT WITH
C                 APPLICATIONS TO COMMUNICATIONS, ECONOMICS,
C                 ENGINEERING, AND FINANCE", BIRKHAUSR, 2001,
C                 PP. 134.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004.6
C     ORIGINAL VERSION--JUNE      2004.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DP
      DOUBLE PRECISION DK
      DOUBLE PRECISION DPPF
      DOUBLE PRECISION DTERM1
C
      CHARACTER*4 IADEDF
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----DATA STATEMENTS-------------------------------------------------
C
C-----START POINT-----------------------------------------------------
C
C               ************************************
C               **  STEP 1--                      **
C               **  COMPUTE THE DENSITY FUNCTION  **
C               ************************************
C
      IF(P.LE.0.0.OR.P.GE.1.0)THEN
         WRITE(ICOUT,61)
   61    FORMAT('***** ERROR--THE FIRST  INPUT ARGUMENT ',
     1          'TO THE ADEPPF SUBROUTINE ')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,62)
   62    FORMAT('      IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL.')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,63)P
   63    FORMAT('      VALUE OF ARGUMENT = ',G15.7)
         CALL DPWRST('XXX','BUG ')
         PPF=0.0
         GOTO9000
      ENDIF
C
C
      IF(IADEDF.EQ.'K')THEN
        IF(AK.LE.0.0)THEN
          WRITE(ICOUT,5)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,48)AK
          CALL DPWRST('XXX','WRIT')
          PPF=0.0
          GOTO9000
        ENDIF
      ELSE
        AK=SQRT(2.0)/(AK + SQRT(2.0 + AK*AK))
      ENDIF
    5 FORMAT('***** ERROR: VALUE OF SHAPE PARAMETER (K) IN ADEPPF ',
     1       'ROUTINE IS NEGATIVE.')
   48 FORMAT('      VALUE OF ARGUMENT IS: ',G15.7)
C
      DP=DBLE(P)
      DK=DBLE(AK)
      PCUT=AK**2/(1.0+AK**2)
C
      IF(P.LT.PCUT)THEN
        DPPF=(DK/DSQRT(2.0D0))*DLOG(((1.0D0+DK*DK)/(DK*DK))*DP)
      ELSE
        DPPF=(-1.0D0/(DSQRT(2.0D0)*DK))*DLOG((1.0D0+DK*DK)*(1.0D0-DP))
      ENDIF
      PPF=REAL(DPPF)
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE ADERAN(N,AK,IADEDF,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE ASYMMETRIC DOUBLE EXPONENTIAL (LAPLACE)
C              DISTRIBUTION WITH SHAPE PARAMETER = AK.
C              THIS DISTRIBUTION IS DEFINED FOR ALL X AND HAS
C              THE PROBABILITY DENSITY FUNCTION
C                 ADEPDF(X,K) = (SQRT(2)*K/(1+K^2))*
C                               EXP(-SQRT(2)*K*ABS(X))  X >= 0
C                 ADEPDF(X,K) = (SQRT(2)*K/(1+K^2))*
C                               EXP((-SQRT(2)/K)*ABS(X))  X < 0
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --AK     = THE SHAPE (PARAMETER) FOR THE
C                                ASYMMETRIC DOUBLE EXPONENTIAL
C                                DISTRIBUTION.
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST N)
C                                INTO WHICH THE GENERATED
C                                RANDOM SAMPLE WILL BE PLACED.
C     OUTPUT--A RANDOM SAMPLE OF SIZE N
C             FROM THE ASYMMETRIC DOUBLE EXPONENTIAL DISTRIBUTION
C             WITH SHAPE PARAMETER = AK.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C                 --AK CAN BE ANY REAL NUMBER.
C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--KOTZ, KOZUBOWSKI, AND PODGORSKI, "THE LAPLACE
C                 DISTRIBUTION AND GENERALIZATIONS: A REVISIT WITH
C                 APPLICATIONS TO COMMUNICATIONS, ECONOMICS,
C                 ENGINEERING, AND FINANCE", BIRKHAUSR, 2001,
C                 PP. 134-149.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004.6
C     ORIGINAL VERSION--JUNE      2004.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
      DIMENSION Y(2)
C
      CHARACTER*4 IADEDF
C
      DOUBLE PRECISION U1
      DOUBLE PRECISION U2
      DOUBLE PRECISION DK
      DOUBLE PRECISION DPPF
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----DATA STATEMENTS-------------------------------------------------
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)THEN
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,6)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
      IF(IADEDF.EQ.'K')THEN
        IF(AK.LE.0.0)THEN
          WRITE(ICOUT,15)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,48)AK
          CALL DPWRST('XXX','WRIT')
          PDF=0.0
          GOTO9999
        ENDIF
      ELSE
        AK=SQRT(2.0)/(AK + SQRT(2.0 + AK*AK))
      ENDIF
   15 FORMAT('***** ERROR: VALUE OF SHAPE PARAMETER (K) IS ',
     1       'NON-POSITIVE.')
C
    5 FORMAT('***** ERROR--FOR THE ASYMMETRIC DOUBLE EXPONENTIAL ',
     1       'DISTRIBUTION,')
    6 FORMAT('       THE REQUESTED NUMBER OF RANDOM NUMBERS WAS ',
     1      'NON-POSITIVE.')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,'.')
   48 FORMAT('      VALUE OF ARGUMENT IS: ',G15.7)
C
C     USE PERCENT POINT TRANSFORMATION METHOD.
C
      NTEMP=2
      DK=DBLE(AK)
      DO100I=1,N
        CALL UNIRAN(NTEMP,ISEED,Y)
        U1=DBLE(Y(1))
        U2=DBLE(Y(2))
        DPPF=(1.0D0/DSQRT(2.0D0))*DLOG(U1**DK/(U2**(1.0D0/DK)))
        X(I)=REAL(DPPF)
  100 CONTINUE
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE ADJUS2(IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
C
C     PURPOSE--PACK < = INTO <=
C              PACK = < INTO =<
C              PACK > = INTO >=
C              PACK = > INTO =>
C              PACK < > INTO <>
C      NOTE--THIS PACKING IS DONE BECAUSE SUBROUTINE DPTYPE
C            AUTOMATICALLY PUTS SPACES AROUND
C            AN EQUAL SIGN AND PUTS THE EQUAL SIGN
C            IN A SEPARATE WORD.
C     NOTE--NUMARG IS CHANGED BY THIS SUBROUTINE.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--82/7
C     ORIGINAL VERSION--SEPTEMBER 1981.
C     UPDATED         --MAY       1982.
C     UPDATED         --MARCH     1988. ALLOW    NOT EQUAL   <> >< NOT=
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IHARG
      CHARACTER*4 IHARG2
      CHARACTER*4 IARGT
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DIMENSION IHARG(*)
      DIMENSION IHARG2(*)
      DIMENSION IARG(*)
      DIMENSION ARG(*)
      DIMENSION IARGT(*)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='ADJU'
      ISUBN2='S2  '
C
      IMAX=NUMARG-1
      IF(1.GT.IMAX)GOTO9000
      DO100I=1,IMAX
      IP1=I+1
      IF(IP1.GT.NUMARG)GOTO9000
      IF(IHARG(I).EQ.'<   '.AND.IHARG(IP1).EQ.'=   ')GOTO110
      IF(IHARG(I).EQ.'=   '.AND.IHARG(IP1).EQ.'<   ')GOTO120
      IF(IHARG(I).EQ.'>   '.AND.IHARG(IP1).EQ.'=   ')GOTO130
      IF(IHARG(I).EQ.'=   '.AND.IHARG(IP1).EQ.'>   ')GOTO140
      IF(IHARG(I).EQ.'<   '.AND.IHARG(IP1).EQ.'>   ')GOTO150
      IF(IHARG(I).EQ.'>   '.AND.IHARG(IP1).EQ.'<   ')GOTO160
      IF(IHARG(I).EQ.'NOT '.AND.IHARG(IP1).EQ.'=   ')GOTO170
      GOTO100
C
  110 CONTINUE
      IHARG(I)='<=  '
      IHARG2(I)='    '
      GOTO250
  120 CONTINUE
      IHARG(I)='=<  '
      IHARG2(I)='    '
      GOTO250
  130 CONTINUE
      IHARG(I)='>=  '
      IHARG2(I)='    '
      GOTO250
  140 CONTINUE
      IHARG(I)='=>  '
      IHARG2(I)='    '
      GOTO250
  150 CONTINUE
      IHARG(I)='<>  '
      IHARG2(I)='    '
      GOTO250
  160 CONTINUE
      IHARG(I)='><  '
      IHARG2(I)='    '
      GOTO250
  170 CONTINUE
      IHARG(I)='NOT='
      IHARG2(I)='    '
      GOTO250
C
  250 CONTINUE
      JMAX=NUMARG-1
      IF(IP1.GT.JMAX)GOTO265
      DO260J=IP1,JMAX
      JP1=J+1
      IHARG(J)=IHARG(JP1)
      IHARG2(J)=IHARG2(JP1)
      IARGT(J)=IARGT(JP1)
      IARG(J)=IARG(JP1)
      ARG(J)=ARG(JP1)
  260 CONTINUE
  265 CONTINUE
      NUMARG=NUMARG-1
  100 CONTINUE
C
 9000 CONTINUE
C
      RETURN
      END
      SUBROUTINE ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
C
C     PURPOSE--ADJUST THE IHARG,IHARG2, IARG, ARG, AND IARGT VECTORS
C              AS WELL AS THE VALUE OF NUMARG
C              WHEN HAVE MULTIPLE-WORD COMMANDS;
C              THE ADJUSTMENT RESULTS IN THE
C              FIRST AREGUMENT AFTER THE LAST WORD OF THE COMMAND
C              BEING MAPPED INTO IHARG(1), ETC.
C     NOTE--ILASTC IS THE CURRENT ARGUMENT NUMBER IN IHARG
C           OF THE CURRENT LAST WORD IN THE COMMAND PART
C           OF THE COMMAND STATEMENT.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--82/7
C     ORIGINAL VERSION--APRIL     1978.
C     UPDATED         --JUNE      1978.
C     UPDATED         --JANUARY   1981.
C     UPDATED         --JULY      1981.
C     UPDATED         --NOVEMBER  1981.
C     UPDATED         --MAY       1982.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IHARG
      CHARACTER*4 IHARG2
      CHARACTER*4 IARGT
C
      CHARACTER*4 IBUGAD
C
C---------------------------------------------------------------------
C
      DIMENSION IHARG(*)
      DIMENSION IHARG2(*)
      DIMENSION IARG(*)
      DIMENSION ARG(*)
      DIMENSION IARGT(*)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      IBUGAD='OFF'
C
      IF(IBUGAD.EQ.'OFF')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF ADJUST--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)ILASTC,NUMARG
   52 FORMAT('ILASTC,NUMARG = ',2I8)
      CALL DPWRST('XXX','BUG ')
      DO55I=1,NUMARG
      WRITE(ICOUT,56)I,IHARG(I),IHARG2(I),IARG(I),ARG(I),IARGT(I)
   56 FORMAT('I,IHARG(I),IHARG2(I),IARG(I),ARG(I),IARGT(I) = ',
     1I8,2X,A4,A4,I8,E15.7,2X,A4)
      CALL DPWRST('XXX','BUG ')
   55 CONTINUE
   90 CONTINUE
C
      ILASTP=ILASTC+1
      IF(ILASTP.GT.NUMARG)GOTO150
      J=0
      DO100I=ILASTP,NUMARG
      J=J+1
      IHARG(J)=IHARG(I)
      IHARG2(J)=IHARG2(I)
      IARG(J)=IARG(I)
      ARG(J)=ARG(I)
      IARGT(J)=IARGT(I)
  100 CONTINUE
      NUMARG=J
      GOTO9000
C
  150 CONTINUE
      NUMARG=0
      GOTO9000
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      IF(IBUGAD.EQ.'OFF')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF ADJUST--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)ILASTC,NUMARG
 9012 FORMAT('ILASTC,NUMARG = ',2I8)
      CALL DPWRST('XXX','BUG ')
      DO9015I=1,NUMARG
      WRITE(ICOUT,9016)I,IHARG(I),IHARG2(I),IARG(I),ARG(I),IARGT(I)
 9016 FORMAT('I,IHARG(I),IHARG2(I),IARG(I),ARG(I),IARGT(I) = ',
     1I8,2X,A4,A4,I8,E15.7,2X,A4)
      CALL DPWRST('XXX','BUG ')
 9015 CONTINUE
 9090 CONTINUE
C
      RETURN
      END
      FUNCTION AI (X)
C***BEGIN PROLOGUE  AI
C***PURPOSE  Evaluate the Airy function.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C10D
C***TYPE      SINGLE PRECISION (AI-S, DAI-D)
C***KEYWORDS  AIRY FUNCTION, FNLIB, SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C AI(X) computes the Airy function Ai(X)
C Series for AIF        on the interval -1.00000D+00 to  1.00000D+00
C                                        with weighted error   1.09E-19
C                                         log weighted error  18.96
C                               significant figures required  17.76
C                                    decimal places required  19.44
C
C Series for AIG        on the interval -1.00000D+00 to  1.00000D+00
C                                        with weighted error   1.51E-17
C                                         log weighted error  16.82
C                               significant figures required  15.19
C                                    decimal places required  17.27
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  AIE, CSEVL, INITS, R1MACH, R9AIMP, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770701  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   920618  Removed space from variable names.  (RWC, WRB)
C***END PROLOGUE  AI
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DIMENSION AIFCS(9), AIGCS(8)
      LOGICAL FIRST
      SAVE AIFCS, AIGCS, NAIF, NAIG, X3SML, XMAX, FIRST
      DATA AIFCS( 1) /   -.0379713584 9666999750E0 /
      DATA AIFCS( 2) /    .0591918885 3726363857E0 /
      DATA AIFCS( 3) /    .0009862928 0577279975E0 /
      DATA AIFCS( 4) /    .0000068488 4381907656E0 /
      DATA AIFCS( 5) /    .0000000259 4202596219E0 /
      DATA AIFCS( 6) /    .0000000000 6176612774E0 /
      DATA AIFCS( 7) /    .0000000000 0010092454E0 /
      DATA AIFCS( 8) /    .0000000000 0000012014E0 /
      DATA AIFCS( 9) /    .0000000000 0000000010E0 /
      DATA AIGCS( 1) /    .0181523655 8116127E0 /
      DATA AIGCS( 2) /    .0215725631 6601076E0 /
      DATA AIGCS( 3) /    .0002567835 6987483E0 /
      DATA AIGCS( 4) /    .0000014265 2141197E0 /
      DATA AIGCS( 5) /    .0000000045 7211492E0 /
      DATA AIGCS( 6) /    .0000000000 0952517E0 /
      DATA AIGCS( 7) /    .0000000000 0001392E0 /
      DATA AIGCS( 8) /    .0000000000 0000001E0 /
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  AI
      IF (FIRST) THEN
         NAIF = INITS (AIFCS, 9, 0.1*R1MACH(3))
         NAIG = INITS (AIGCS, 8, 0.1*R1MACH(3))
C
         X3SML = R1MACH(3)**0.3334
         XMAXT = (-1.5*LOG(R1MACH(1)))**0.6667
         XMAX = XMAXT - XMAXT*LOG(XMAXT)/
     *                   (4.0*SQRT(XMAXT)+1.0) - 0.01
      ENDIF
      FIRST = .FALSE.
C
      IF (X.GE.(-1.0)) GO TO 20
      CALL R9AIMP (X, XM, THETA)
      AI = XM * COS(THETA)
      RETURN
C
 20   IF (X.GT.1.0) GO TO 30
      Z = 0.0
      IF (ABS(X).GT.X3SML) Z = X**3
      AI = 0.375 + (CSEVL (Z, AIFCS, NAIF) - X*(0.25 +
     1  CSEVL (Z, AIGCS, NAIG)) )
      RETURN
C
 30   IF (X.GT.XMAX) GO TO 40
      AI = AIE(X) * EXP(-2.0*X*SQRT(X)/3.0)
      RETURN
C
 40   AI = 0.0
      WRITE(ICOUT,1)
      CALL DPWRST('XXX','BUG ')
    1 FORMAT('***** WARNING FROM AI, UNDERFLOW BECAUSE THE ',
     1       'VALUE OF X IS SO BIG.  ****')
      RETURN
C
      END
      FUNCTION AIE (X)
C***BEGIN PROLOGUE  AIE
C***PURPOSE  Calculate the Airy function for a negative argument and an
C            exponentially scaled Airy function for a non-negative
C            argument.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C10D
C***TYPE      SINGLE PRECISION (AIE-S, DAIE-D)
C***KEYWORDS  EXPONENTIALLY SCALED AIRY FUNCTION, FNLIB,
C             SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C AIE(X) computes the exponentially scaled Airy function for
C non-negative X.  It evaluates AI(X) for X .LE. 0.0 and
C EXP(ZETA)*AI(X) for X .GE. 0.0 where ZETA = (2.0/3.0)*(X**1.5).
C
C Series for AIF        on the interval -1.00000D+00 to  1.00000D+00
C                                        with weighted error   1.09E-19
C                                         log weighted error  18.96
C                               significant figures required  17.76
C                                    decimal places required  19.44
C
C Series for AIG        on the interval -1.00000D+00 to  1.00000D+00
C                                        with weighted error   1.51E-17
C                                         log weighted error  16.82
C                               significant figures required  15.19
C                                    decimal places required  17.27
C
C Series for AIP        on the interval  0.          to  1.00000D+00
C                                        with weighted error   5.10E-17
C                                         log weighted error  16.29
C                               significant figures required  14.41
C                                    decimal places required  17.06
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  CSEVL, INITS, R1MACH, R9AIMP
C***REVISION HISTORY  (YYMMDD)
C   770701  DATE WRITTEN
C   890206  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920618  Removed space from variable names.  (RWC, WRB)
C***END PROLOGUE  AIE
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DIMENSION AIFCS(9), AIGCS(8), AIPCS(34)
      LOGICAL FIRST
      SAVE AIFCS, AIGCS, AIPCS, NAIF, NAIG,
     1 NAIP, X3SML, X32SML, XBIG, FIRST
      DATA AIFCS( 1) /   -.0379713584 9666999750E0 /
      DATA AIFCS( 2) /    .0591918885 3726363857E0 /
      DATA AIFCS( 3) /    .0009862928 0577279975E0 /
      DATA AIFCS( 4) /    .0000068488 4381907656E0 /
      DATA AIFCS( 5) /    .0000000259 4202596219E0 /
      DATA AIFCS( 6) /    .0000000000 6176612774E0 /
      DATA AIFCS( 7) /    .0000000000 0010092454E0 /
      DATA AIFCS( 8) /    .0000000000 0000012014E0 /
      DATA AIFCS( 9) /    .0000000000 0000000010E0 /
      DATA AIGCS( 1) /    .0181523655 8116127E0 /
      DATA AIGCS( 2) /    .0215725631 6601076E0 /
      DATA AIGCS( 3) /    .0002567835 6987483E0 /
      DATA AIGCS( 4) /    .0000014265 2141197E0 /
      DATA AIGCS( 5) /    .0000000045 7211492E0 /
      DATA AIGCS( 6) /    .0000000000 0952517E0 /
      DATA AIGCS( 7) /    .0000000000 0001392E0 /
      DATA AIGCS( 8) /    .0000000000 0000001E0 /
      DATA AIPCS( 1) /   -.0187519297 793868E0 /
      DATA AIPCS( 2) /   -.0091443848 250055E0 /
      DATA AIPCS( 3) /    .0009010457 337825E0 /
      DATA AIPCS( 4) /   -.0001394184 127221E0 /
      DATA AIPCS( 5) /    .0000273815 815785E0 /
      DATA AIPCS( 6) /   -.0000062750 421119E0 /
      DATA AIPCS( 7) /    .0000016064 844184E0 /
      DATA AIPCS( 8) /   -.0000004476 392158E0 /
      DATA AIPCS( 9) /    .0000001334 635874E0 /
      DATA AIPCS(10) /   -.0000000420 735334E0 /
      DATA AIPCS(11) /    .0000000139 021990E0 /
      DATA AIPCS(12) /   -.0000000047 831848E0 /
      DATA AIPCS(13) /    .0000000017 047897E0 /
      DATA AIPCS(14) /   -.0000000006 268389E0 /
      DATA AIPCS(15) /    .0000000002 369824E0 /
      DATA AIPCS(16) /   -.0000000000 918641E0 /
      DATA AIPCS(17) /    .0000000000 364278E0 /
      DATA AIPCS(18) /   -.0000000000 147475E0 /
      DATA AIPCS(19) /    .0000000000 060851E0 /
      DATA AIPCS(20) /   -.0000000000 025552E0 /
      DATA AIPCS(21) /    .0000000000 010906E0 /
      DATA AIPCS(22) /   -.0000000000 004725E0 /
      DATA AIPCS(23) /    .0000000000 002076E0 /
      DATA AIPCS(24) /   -.0000000000 000924E0 /
      DATA AIPCS(25) /    .0000000000 000417E0 /
      DATA AIPCS(26) /   -.0000000000 000190E0 /
      DATA AIPCS(27) /    .0000000000 000087E0 /
      DATA AIPCS(28) /   -.0000000000 000040E0 /
      DATA AIPCS(29) /    .0000000000 000019E0 /
      DATA AIPCS(30) /   -.0000000000 000009E0 /
      DATA AIPCS(31) /    .0000000000 000004E0 /
      DATA AIPCS(32) /   -.0000000000 000002E0 /
      DATA AIPCS(33) /    .0000000000 000001E0 /
      DATA AIPCS(34) /   -.0000000000 000000E0 /
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  AIE
      IF (FIRST) THEN
         ETA = 0.1*R1MACH(3)
         NAIF  = INITS (AIFCS, 9, ETA)
         NAIG  = INITS (AIGCS, 8, ETA)
         NAIP  = INITS (AIPCS, 34, ETA)
C
         X3SML = ETA**0.3333
         X32SML = 1.3104*X3SML**2
         XBIG = R1MACH(2)**0.6666
      ENDIF
      FIRST = .FALSE.
C
      IF (X.GE.(-1.0)) GO TO 20
      CALL R9AIMP (X, XM, THETA)
      AIE = XM * COS(THETA)
      RETURN
C
 20   IF (X.GT.1.0) GO TO 30
      Z = 0.0
      IF (ABS(X).GT.X3SML) Z = X**3
      AIE = 0.375 + (CSEVL (Z, AIFCS, NAIF) - X*(0.25 +
     1  CSEVL (Z, AIGCS, NAIG)) )
      IF (X.GT.X32SML) AIE = AIE * EXP(2.0*X*SQRT(X)/3.0)
      RETURN
C
 30   SQRTX = SQRT(X)
      Z = -1.0
      IF (X.LT.XBIG) Z = 2.0/(X*SQRTX) - 1.0
      AIE = (.28125 + CSEVL (Z, AIPCS, NAIP))/SQRT(SQRTX)
      RETURN
C
      END
      DOUBLE PRECISION FUNCTION AIRINT(XVALUE)
C
C   DESCRIPTION:
C
C      This function calculates the integral of the Airy function Ai,
C      defined as
C
C         AIRINT(x) = {integral 0 to x} Ai(t) dt
C
C      The program uses Chebyshev expansions, the coefficients of which
C      are given to 20 decimal places.
C
C
C   ERROR RETURNS:
C
C      If the argument is too large and negative, it is impossible
C      to accurately compute the necessary SIN and COS functions.
C      An error message is printed, and the program returns the
C      value -2/3 (the value at -infinity).
C
C
C   MACHINE-DEPENDENT CONSTANTS:
C
C      NTERM1 - INTEGER - The no. of terms to be used from the array
C                          AAINT1. The recommended value is such that
C                             ABS(AAINT1(NTERM1)) < EPS/100,
C                          subject to 1 <= NTERM1 <= 25.
C
C      NTERM2 - INTEGER - The no. of terms to be used from the array
C                          AAINT2. The recommended value is such that
C                             ABS(AAINT2(NTERM2)) < EPS/100,
C                          subject to 1 <= NTERM2 <= 21.
C
C      NTERM3 - INTEGER - The no. of terms to be used from the array
C                          AAINT3. The recommended value is such that
C                             ABS(AAINT3(NTERM3)) < EPS/100,
C                          subject to 1 <= NTERM3 <= 40.
C 
C      NTERM4 - INTEGER - The no. of terms to be used from the array
C                          AAINT4. The recommended value is such that
C                             ABS(AAINT4(NTERM4)) < EPS/100,
C                          subject to 1 <= NTERM4 <= 17.
C
C      NTERM5 - INTEGER - The no. of terms to be used from the array
C                          AAINT5. The recommended value is such that
C                             ABS(AAINT5(NTERM5)) < EPS/100,
C                          subject to 1 <= NTERM5 <= 17.
C
C      XLOW1 - DOUBLE PRECISION - The value such that, if |x| < XLOW1,
C                          AIRINT(x) = x * Ai(0)
C                     to machine precision. The recommended value is
C                          2 * EPSNEG.
C
C      XHIGH1 - DOUBLE PRECISION - The value such that, if x > XHIGH1,
C                          AIRINT(x) = 1/3,
C                      to machine precision. The recommended value is
C                          (-1.5*LOG(EPSNEG)) ** (2/3).
C
C      XNEG1 - DOUBLE PRECISION - The value such that, if x < XNEG1,
C                     the trigonometric functions in the asymptotic
C                     expansion cannot be calculated accurately.
C                     The recommended value is
C                          -(1/((EPS)**2/3))
C
C      For values of EPS and EPSNEG, refer to the file MACHCON.TXT.
C
C     The machine-dependent constants are computed internally by
C     using the D1MACH subroutine.
C
C
C   INTRINSIC FUNCTIONS USED:
C                            COS, EXP, SIN, SQRT
C
C
C   OTHER MISCFUN SUBROUTINES USED:
C
C          CHEVAL , ERRPRN, D1MACH
C
C
C   AUTHOR: Dr. Allan J. MacLeod,
C           Dept. of Mathematics and Statistics,
C           Univ. of Paisley,
C           High St.,
C           Paisley,
C           SCOTLAND.
C           PA1 2BE
C 
C           (e-mail:macl_ms0@paisley.ac.uk)
C
C
C   LATEST REVISION:  23 January, 1996
C
      INTEGER NTERM1,NTERM2,NTERM3,NTERM4,NTERM5
      DOUBLE PRECISION AAINT1(0:25),AAINT2(0:21),AAINT3(0:40),
     1     AAINT4(0:17),AAINT5(0:17),
     2     AIRZER,ARG,CHEVAL,EIGHT,FORTY1,FOUR,FR996,GVAL,
     3     HVAL,NINE,NINHUN,ONE,ONEHUN,PIBY4,PITIM6,RT2B3P,T,TEMP,
     4     THREE,TWO,X,XHIGH1,XLOW1,XNEG1,XVALUE,Z,ZERO
CCCCC CHARACTER FNNAME*6,ERRMSG*46
CCCCC DATA FNNAME/'AIRINT'/
CCCCC DATA ERRMSG/'FUNCTION TOO NEGATIVE FOR ACCURATE COMPUTATION'/
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DATA AAINT1(0)/  0.37713 51769 46836 95526  D    0/
      DATA AAINT1(1)/ -0.13318 86843 24079 47431  D    0/
      DATA AAINT1(2)/  0.31524 97374 78288 4809   D   -1/
      DATA AAINT1(3)/ -0.31854 30764 36574 077    D   -2/
      DATA AAINT1(4)/ -0.87398 76469 86219 15     D   -3/
      DATA AAINT1(5)/  0.46699 49765 53969 71     D   -3/
      DATA AAINT1(6)/ -0.95449 36738 98369 2      D   -4/
      DATA AAINT1(7)/  0.54270 56871 56716        D   -5/
      DATA AAINT1(8)/  0.23949 64062 52188        D   -5/
      DATA AAINT1(9)/ -0.75690 27020 5649         D   -6/
      DATA AAINT1(10)/ 0.90501 38584 518          D   -7/
      DATA AAINT1(11)/ 0.32052 94560 43           D   -8/
      DATA AAINT1(12)/-0.30382 55364 44           D   -8/
      DATA AAINT1(13)/ 0.48900 11859 6            D   -9/
      DATA AAINT1(14)/-0.18398 20572              D  -10/
      DATA AAINT1(15)/-0.71124 7519               D  -11/
      DATA AAINT1(16)/ 0.15177 4419               D  -11/
      DATA AAINT1(17)/-0.10801 922                D  -12/
      DATA AAINT1(18)/-0.96354 2                  D  -14/
      DATA AAINT1(19)/ 0.31342 5                  D  -14/
      DATA AAINT1(20)/-0.29446                    D  -15/
      DATA AAINT1(21)/-0.477                      D  -17/
      DATA AAINT1(22)/ 0.461                      D  -17/
      DATA AAINT1(23)/-0.53                       D  -18/
      DATA AAINT1(24)/ 0.1                        D  -19/
      DATA AAINT1(25)/ 0.1                        D  -19/
      DATA AAINT2(0)/  1.92002 52408 19840 09769  D    0/
      DATA AAINT2(1)/ -0.42200 49417 25628 7021   D   -1/
      DATA AAINT2(2)/ -0.23945 77229 65939 223    D   -2/
      DATA AAINT2(3)/ -0.19564 07048 33529 71     D   -3/
      DATA AAINT2(4)/ -0.15472 52891 05611 2      D   -4/
      DATA AAINT2(5)/ -0.14049 01861 37889        D   -5/
      DATA AAINT2(6)/ -0.12128 01427 1367         D   -6/
      DATA AAINT2(7)/ -0.11791 86050 192          D   -7/
      DATA AAINT2(8)/ -0.10431 55787 88           D   -8/
      DATA AAINT2(9)/ -0.10908 20929 3            D   -9/
      DATA AAINT2(10)/-0.92963 3045               D  -11/
      DATA AAINT2(11)/-0.11094 6520               D  -11/
      DATA AAINT2(12)/-0.78164 83                 D  -13/
      DATA AAINT2(13)/-0.13196 61                 D  -13/
      DATA AAINT2(14)/-0.36823                    D  -15/
      DATA AAINT2(15)/-0.21505                    D  -15/
      DATA AAINT2(16)/ 0.1238                     D  -16/
      DATA AAINT2(17)/-0.557                      D  -17/
      DATA AAINT2(18)/ 0.84                       D  -18/
      DATA AAINT2(19)/-0.21                       D  -18/
      DATA AAINT2(20)/ 0.4                        D  -19/
      DATA AAINT2(21)/-0.1                        D  -19/
      DATA AAINT3(0)/  0.47985 89326 47910 52053  D    0/
      DATA AAINT3(1)/ -0.19272 37512 61696 08863  D    0/
      DATA AAINT3(2)/  0.20511 54129 52542 8189   D   -1/
      DATA AAINT3(3)/  0.63320 00070 73248 8786   D   -1/
      DATA AAINT3(4)/ -0.50933 22261 84575 4082   D   -1/
      DATA AAINT3(5)/  0.12844 24078 66166 3016   D   -1/
      DATA AAINT3(6)/  0.27601 37088 98947 9413   D   -1/
      DATA AAINT3(7)/ -0.15470 66673 86664 9507   D   -1/
      DATA AAINT3(8)/ -0.14968 64655 38931 6026   D   -1/
      DATA AAINT3(9)/  0.33661 76141 73574 541    D   -2/
      DATA AAINT3(10)/ 0.53085 11635 18892 985    D   -2/
      DATA AAINT3(11)/ 0.41371 22645 85550 81     D   -3/
      DATA AAINT3(12)/-0.10249 05799 26726 266    D   -2/
      DATA AAINT3(13)/-0.32508 22167 20258 53     D   -3/
      DATA AAINT3(14)/ 0.86086 60957 16921 3      D   -4/
      DATA AAINT3(15)/ 0.66713 67298 12077 5      D   -4/
      DATA AAINT3(16)/ 0.44920 59993 18095        D   -5/
      DATA AAINT3(17)/-0.67042 72309 58249        D   -5/
      DATA AAINT3(18)/-0.19663 65700 85009        D   -5/
      DATA AAINT3(19)/ 0.22229 67740 7226         D   -6/
      DATA AAINT3(20)/ 0.22332 22294 9137         D   -6/
      DATA AAINT3(21)/ 0.28033 13766 457          D   -7/
      DATA AAINT3(22)/-0.11556 51663 619          D   -7/
      DATA AAINT3(23)/-0.43306 98217 36           D   -8/
      DATA AAINT3(24)/-0.62277 77938              D  -10/
      DATA AAINT3(25)/ 0.26432 66490 3            D   -9/
      DATA AAINT3(26)/ 0.53338 81114              D  -10/
      DATA AAINT3(27)/-0.52295 7269               D  -11/
      DATA AAINT3(28)/-0.38222 9283               D  -11/
      DATA AAINT3(29)/-0.40958 233                D  -12/
      DATA AAINT3(30)/ 0.11515 622                D  -12/
      DATA AAINT3(31)/ 0.38757 66                 D  -13/
      DATA AAINT3(32)/ 0.14028 3                  D  -14/
      DATA AAINT3(33)/-0.14152 6                  D  -14/
      DATA AAINT3(34)/-0.28746                    D  -15/
      DATA AAINT3(35)/ 0.923                      D  -17/
      DATA AAINT3(36)/ 0.1224                     D  -16/
      DATA AAINT3(37)/ 0.157                      D  -17/
      DATA AAINT3(38)/-0.19                       D  -18/
      DATA AAINT3(39)/-0.8                        D  -19/
      DATA AAINT3(40)/-0.1                        D  -19/
      DATA AAINT4/1.99653 30582 85227 30048  D    0,
     1           -0.18754 11776 05417 759    D   -2,
     2           -0.15377 53628 03057 50     D   -3,
     3           -0.12831 12967 68234 9      D   -4,
     4           -0.10812 84819 64162        D   -5,
     5           -0.91821 31174 057          D   -7,
     6           -0.78416 05909 60           D   -8,
     7           -0.67292 45387 8            D   -9,
     8           -0.57963 25198              D  -10,
     9           -0.50104 0991               D  -11,
     X           -0.43420 222                D  -12,
     1           -0.37743 05                 D  -13,
     2           -0.32847 3                  D  -14,
     3           -0.28700                    D  -15,
     4           -0.2502                     D  -16,
     5           -0.220                      D  -17,
     6           -0.19                       D  -18,
     7           -0.2                        D  -19/
      DATA AAINT5/1.13024 60203 44657 16133  D    0,
     1           -0.46471 80646 39872 334    D   -2,
     2           -0.35137 41338 26932 03     D   -3,
     3           -0.27681 17872 54518 5      D   -4,
     4           -0.22205 74525 58107        D   -5,
     5           -0.18089 14236 5974         D   -6,
     6           -0.14876 13383 373          D   -7,
     7           -0.12351 53881 68           D   -8,
     8           -0.10310 10425 7            D   -9,
     9           -0.86749 3013               D  -11,
     X           -0.73080 054                D  -12,
     1           -0.62235 61                 D  -13,
     2           -0.52512 8                  D  -14,
     3           -0.45677                    D  -15,
     4           -0.3748                     D  -16,
     5           -0.356                      D  -17,
     6           -0.23                       D  -18,
     7           -0.4                        D  -19/
      DATA ZERO,ONE,TWO/ 0.0 D 0 , 1.0 D 0 , 2.0 D 0 /
      DATA THREE,FOUR,EIGHT/ 3.0 D 0 , 4.0 D 0 , 8.0 D 0 /
      DATA NINE,FORTY1,ONEHUN/ 9.0 D 0 , 41.0 D 0 , 100.0 D 0/
      DATA NINHUN,FR996/ 900.0 D 0 , 4996.0 D 0 /
      DATA PIBY4/0.78539 81633 97448 30962 D 0/
      DATA PITIM6/18.84955 59215 38759 43078 D 0/
      DATA RT2B3P/0.46065 88659 61780 63902 D 0/
      DATA AIRZER/0.35502 80538 87817 23926 D 0/
C
C   Start computation
C
      X = XVALUE
C
C   Compute the machine-dependent constants.
C
      Z = D1MACH(3)
      XLOW1 = TWO * Z
      ARG = D1MACH(4)
      XNEG1 = - ONE / ( ARG ** (TWO/THREE) )
C
C   Error test
C
      IF ( X .LT. XNEG1 ) THEN
CCCCCC   CALL ERRPRN(FNNAME,ERRMSG)
         WRITE(ICOUT,999)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,101)X
         CALL DPWRST('XXX','BUG ')
         AIRINT = -TWO / THREE
         RETURN
      ENDIF
  999 FORMAT(1X)
  101 FORMAT('***** ERROR FROM AIRINT--FUNCTION TOO NEGATIVE FOR ',
     1       'ACCURATE COMPUTATION, ARGUMENT = ',G15.7)
C
C  continue with machine-dependent constants
C 
      T = ARG / ONEHUN
      IF ( X .GE. ZERO ) THEN
         DO 10 NTERM1 = 25 , 0 , -1
            IF ( ABS(AAINT1(NTERM1)) .GT. T ) GOTO 19
 10      CONTINUE
 19      DO 20 NTERM2 = 21 , 0 , -1
            IF ( ABS(AAINT2(NTERM2)) .GT. T ) GOTO 29
 20      CONTINUE
 29      XHIGH1 = ( -THREE*LOG(Z)/TWO ) ** (TWO/THREE)
      ELSE
         DO 30 NTERM3 = 40 , 0 , -1
            IF ( ABS(AAINT3(NTERM3)) .GT. T ) GOTO 39
 30      CONTINUE
 39      DO 40 NTERM4 = 17 , 0 , -1
            IF ( ABS(AAINT4(NTERM4)) .GT. T ) GOTO 49
 40      CONTINUE
 49      DO 50 NTERM5 = 17 , 0 , -1
            IF ( ABS(AAINT5(NTERM5)) .GT. T ) GOTO 59
 50      CONTINUE
 59   ENDIF
C
C   Code for x >= 0
C
      IF ( X .GE. ZERO ) THEN
         IF ( X .LE. FOUR ) THEN
            IF ( X .LT. XLOW1 ) THEN
               AIRINT = AIRZER * X
            ELSE
               T = X / TWO - ONE
               AIRINT = CHEVAL(NTERM1,AAINT1,T) * X
            ENDIF
         ELSE
            IF ( X .GT. XHIGH1 ) THEN
               TEMP = ZERO
            ELSE 
               Z = ( X + X ) * SQRT(X) / THREE
               TEMP = THREE * Z
               T = ( FORTY1 - TEMP ) / ( NINE + TEMP )
               TEMP = EXP(-Z) * CHEVAL(NTERM2,AAINT2,T) / SQRT(PITIM6*Z)
            ENDIF
            AIRINT = ONE / THREE - TEMP
         ENDIF
      ELSE
C
C   Code for x < 0
C
         IF ( X .GE. -EIGHT ) THEN
            IF ( X .GT. -XLOW1 ) THEN
               AIRINT = AIRZER * X
            ELSE
               T = -X / FOUR - ONE
               AIRINT = X * CHEVAL(NTERM3,AAINT3,T)
            ENDIF
         ELSE
            Z = - ( X + X ) * SQRT(-X) / THREE
            ARG = Z + PIBY4
            TEMP = NINE * Z * Z
            T = ( FR996 - TEMP ) / ( NINHUN + TEMP)
            GVAL = CHEVAL(NTERM4,AAINT4,T)
            HVAL = CHEVAL(NTERM5,AAINT5,T)
            TEMP = GVAL * COS(ARG) + HVAL * SIN(ARG) / Z
            AIRINT = RT2B3P * TEMP / SQRT(Z) - TWO / THREE
         ENDIF
      ENDIF
      RETURN
      END
      DOUBLE PRECISION FUNCTION AIRYGI(XVALUE)
C
C   DESCRIPTION:
C
C      This subroutine computes the modified Airy function Gi(x),
C      defined as
C
C        AIRYGI(x) = [ Integral{0 to infinity} sin(x*t+t^3/3) dt ] / pi
C
C      The approximation uses Chebyshev expansions with the coefficients 
C      given to 20 decimal places.
C
C
C   ERROR RETURNS:
C
C      If x < -XHIGH1*XHIGH1 (see below for definition of XHIGH1), then
C      the trig. functions needed for the asymptotic expansion of Bi(x)
C      cannot be computed to any accuracy. An error message is printed
C      and the code returns the value 0.0.
C 
C
C   MACHINE-DEPENDENT CONSTANTS:
C
C      NTERM1 - INTEGER - The no. of terms to be used from the array
C                         ARGIP1. The recommended value is such that
C                                ABS(ARGIP1(NTERM1)) < EPS/100
C                         subject to 1 <= NTERM1 <= 30.
C
C      NTERM2 - INTEGER - The no. of terms to be used from the array
C                         ARGIP2. The recommended value is such that
C                                ABS(ARGIP2(NTERM2)) < EPS/100
C                         subject to 1 <= NTERM2 <= 29.
C
C      NTERM3 - INTEGER - The no. of terms to be used from the array
C                         ARGIN1. The recommended value is such that
C                                ABS(ARGIN1(NTERM3)) < EPS/100
C                         subject to 1 <= NTERM3 <= 42.
C
C      NTERM4 - INTEGER - The no. of terms to be used from the array
C                         ARBIN1. The recommended value is such that
C                                ABS(ARBIN1(NTERM4)) < EPS/100
C                         subject to 1 <= NTERM4 <= 10.
C
C      NTERM5 - INTEGER - The no. of terms to be used from the array
C                         ARBIN2. The recommended value is such that
C                                ABS(ARBIN2(NTERM5)) < EPS/100
C                         subject to 1 <= NTERM5 <= 11.
C
C      NTERM6 - INTEGER - The no. of terms to be used from the array
C                         ARGH2. The recommended value is such that
C                                ABS(ARHIN1(NTERM6)) < EPS/100
C                         subject to 1 <= NTERM6 <= 15.
C
C      XLOW1 - DOUBLE PRECISION - The value such that, if -XLOW1 < x < XLOW1,
C                     then AIRYGI = Gi(0) to machine precision.
C                     The recommended value is   EPS.
C
C      XHIGH1 - DOUBLE PRECISION - The value such that, if x > XHIGH1, then
C                      AIRYGI = 1/(Pi*x) to machine precision.
C                      Also used for error test - see above.
C                      The recommended value is
C                          cube root( 2/EPS ).
C
C      XHIGH2 - DOUBLE PRECISION - The value above which AIRYGI = 0.0.
C                      The recommended value is 
C                          1/(Pi*XMIN).
C
C      XHIGH3 - DOUBLE PRECISION - The value such that, if x < XHIGH3,
C                      then the Chebyshev expansions for the
C                      asymptotic form of Bi(x) are not needed.
C                      The recommended value is
C                          -8 * cube root( 2/EPSNEG ).
C
C      For values of EPS, EPSNEG, and XMIN refer to the file
C      MACHCON.TXT.
C
C     The machine-dependent constants are computed internally by
C     using the D1MACH subroutine.
C
C
C   INTRINSIC FUNCTIONS USED:
C                             COS , SIN , SQRT
C
C
C   OTHER MISCFUN SUBROUTINES USED:
C
C          CHEVAL , ERRPRN, D1MACH
C
C
C   AUTHOR:
C          Dr. Allan J. Macleod,
C          Dept. of Mathematics and Statistics,
C          University of Paisley,
C          High St.,
C          Paisley,
C          SCOTLAND.
C
C          (e-mail: macl_ms0@paisley.ac.uk)
C
C
C   LATEST UPDATE:
C                 23 January, 1996
C                          
      INTEGER NTERM1,NTERM2,NTERM3,NTERM4,NTERM5,NTERM6
      DOUBLE PRECISION ARGIP1(0:30),ARGIP2(0:29),ARGIN1(0:42),
     1     ARBIN1(0:10),ARBIN2(0:11),ARHIN1(0:15),
     2     ARG,BI,CHEB1,CHEB2,CHEVAL,COSZ,FIVE,FIVE14,FOUR,
     3     GIZERO,MINATE,NINE,ONE,ONEBPI,ONEHUN,ONE76,ONE024,PIBY4,
     4     RTPIIN,SEVEN,SEVEN2,SINZ,T,TEMP,THREE,TWELHU,TWENT8,
     5     X,XCUBE,XHIGH1,XHIGH2,XHIGH3,XLOW1,XMINUS,
     6     XVALUE,Z,ZERO,ZETA
CCCCC CHARACTER FNNAME*6,ERRMSG*46
CCCCC DATA FNNAME/'AIRYGI'/
CCCCC DATA ERRMSG/'ARGUMENT TOO NEGATIVE FOR ACCURATE COMPUTATION'/
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DATA ARGIP1(0)/  0.26585 77079 50227 45082  D    0/
      DATA ARGIP1(1)/ -0.10500 33309 75019 22907  D    0/
      DATA ARGIP1(2)/  0.84134 74753 28454 492    D   -2/
      DATA ARGIP1(3)/  0.20210 67387 81343 9541   D   -1/
      DATA ARGIP1(4)/ -0.15595 76113 86355 2234   D   -1/
      DATA ARGIP1(5)/  0.56434 29390 43256 481    D   -2/
      DATA ARGIP1(6)/ -0.59776 84482 66558 09     D   -3/
      DATA ARGIP1(7)/ -0.42833 85026 48677 28     D   -3/
      DATA ARGIP1(8)/  0.22605 66238 09090 27     D   -3/
      DATA ARGIP1(9)/ -0.36083 32945 59226 0      D   -4/
      DATA ARGIP1(10)/-0.78551 89887 88901        D   -5/
      DATA ARGIP1(11)/ 0.47325 24807 46370        D   -5/
      DATA ARGIP1(12)/-0.59743 51397 7694         D   -6/
      DATA ARGIP1(13)/-0.15917 60916 5602         D   -6/
      DATA ARGIP1(14)/ 0.63361 29065 570          D   -7/
      DATA ARGIP1(15)/-0.27609 02326 48           D   -8/
      DATA ARGIP1(16)/-0.25606 41540 85           D   -8/
      DATA ARGIP1(17)/ 0.47798 67685 6            D   -9/
      DATA ARGIP1(18)/ 0.44881 31863              D  -10/
      DATA ARGIP1(19)/-0.23465 08882              D  -10/
      DATA ARGIP1(20)/ 0.76839 085                D  -12/
      DATA ARGIP1(21)/ 0.73227 985                D  -12/
      DATA ARGIP1(22)/-0.85136 87                 D  -13/
      DATA ARGIP1(23)/-0.16302 01                 D  -13/
      DATA ARGIP1(24)/ 0.35676 9                  D  -14/
      DATA ARGIP1(25)/ 0.25001                    D  -15/
      DATA ARGIP1(26)/-0.10859                    D  -15/
      DATA ARGIP1(27)/-0.158                      D  -17/
      DATA ARGIP1(28)/ 0.275                      D  -17/
      DATA ARGIP1(29)/-0.5                        D  -19/
      DATA ARGIP1(30)/-0.6                        D  -19/
      DATA ARGIP2(0)/  2.00473 71227 58014 86391  D    0/
      DATA ARGIP2(1)/  0.29418 41393 64406 724    D   -2/
      DATA ARGIP2(2)/  0.71369 24900 63401 67     D   -3/
      DATA ARGIP2(3)/  0.17526 56343 05022 67     D   -3/
      DATA ARGIP2(4)/  0.43591 82094 02988 2      D   -4/
      DATA ARGIP2(5)/  0.10926 26947 60430 7      D   -4/
      DATA ARGIP2(6)/  0.27238 24183 99029        D   -5/
      DATA ARGIP2(7)/  0.66230 90094 7687         D   -6/
      DATA ARGIP2(8)/  0.15425 32337 0315         D   -6/
      DATA ARGIP2(9)/  0.34184 65242 306          D   -7/
      DATA ARGIP2(10)/ 0.72815 77248 94           D   -8/
      DATA ARGIP2(11)/ 0.15158 85254 52           D   -8/
      DATA ARGIP2(12)/ 0.30940 04803 9            D   -9/
      DATA ARGIP2(13)/ 0.61496 72614              D  -10/
      DATA ARGIP2(14)/ 0.12028 77045              D  -10/
      DATA ARGIP2(15)/ 0.23369 0586               D  -11/
      DATA ARGIP2(16)/ 0.43778 068                D  -12/
      DATA ARGIP2(17)/ 0.79964 47                 D  -13/
      DATA ARGIP2(18)/ 0.14940 75                 D  -13/
      DATA ARGIP2(19)/ 0.24679 0                  D  -14/
      DATA ARGIP2(20)/ 0.37672                    D  -15/
      DATA ARGIP2(21)/ 0.7701                     D  -16/
      DATA ARGIP2(22)/ 0.354                      D  -17/
      DATA ARGIP2(23)/-0.49                       D  -18/
      DATA ARGIP2(24)/ 0.62                       D  -18/
      DATA ARGIP2(25)/-0.40                       D  -18/
      DATA ARGIP2(26)/-0.1                        D  -19/
      DATA ARGIP2(27)/ 0.2                        D  -19/
      DATA ARGIP2(28)/-0.3                        D  -19/
      DATA ARGIP2(29)/ 0.1                        D  -19/
      DATA ARGIN1(0)/ -0.20118 96505 67320 89130  D    0/
      DATA ARGIN1(1)/ -0.72441 75303 32453 0499   D   -1/
      DATA ARGIN1(2)/  0.45050 18923 89478 0120   D   -1/
      DATA ARGIN1(3)/ -0.24221 37112 20787 91099  D    0/
      DATA ARGIN1(4)/  0.27178 84964 36167 8294   D   -1/
      DATA ARGIN1(5)/ -0.57293 21004 81817 9697   D   -1/
      DATA ARGIN1(6)/ -0.18382 10786 03377 63587  D    0/
      DATA ARGIN1(7)/  0.77515 46082 14947 5511   D   -1/
      DATA ARGIN1(8)/  0.18386 56473 39275 60387  D    0/
      DATA ARGIN1(9)/  0.29215 04250 18556 7173   D   -1/
      DATA ARGIN1(10)/-0.61422 94846 78801 8811   D   -1/
      DATA ARGIN1(11)/-0.29993 12505 79461 6238   D   -1/
      DATA ARGIN1(12)/ 0.58593 71183 27706 636    D   -2/
      DATA ARGIN1(13)/ 0.82222 16584 97402 529    D   -2/
      DATA ARGIN1(14)/ 0.13257 98171 66846 893    D   -2/
      DATA ARGIN1(15)/-0.96248 31076 65651 26     D   -3/
      DATA ARGIN1(16)/-0.45065 51599 82118 07     D   -3/
      DATA ARGIN1(17)/ 0.77242 34743 25474        D   -5/
      DATA ARGIN1(18)/ 0.54818 74134 75805 2      D   -4/
      DATA ARGIN1(19)/ 0.12458 98039 74287 6      D   -4/
      DATA ARGIN1(20)/-0.24619 68910 92083        D   -5/
      DATA ARGIN1(21)/-0.16915 41835 45285        D   -5/
      DATA ARGIN1(22)/-0.16769 15316 9442         D   -6/
      DATA ARGIN1(23)/ 0.96365 09337 672          D   -7/
      DATA ARGIN1(24)/ 0.32533 14928 030          D   -7/
      DATA ARGIN1(25)/ 0.50918 04231              D  -10/
      DATA ARGIN1(26)/-0.20918 04535 53           D   -8/
      DATA ARGIN1(27)/-0.41237 38787 0            D   -9/
      DATA ARGIN1(28)/ 0.41633 38253              D  -10/
      DATA ARGIN1(29)/ 0.30325 32117              D  -10/
      DATA ARGIN1(30)/ 0.34058 0529               D  -11/
      DATA ARGIN1(31)/-0.88444 592                D  -12/
      DATA ARGIN1(32)/-0.31639 612                D  -12/
      DATA ARGIN1(33)/-0.15050 76                 D  -13/
      DATA ARGIN1(34)/ 0.11041 48                 D  -13/
      DATA ARGIN1(35)/ 0.24650 8                  D  -14/
      DATA ARGIN1(36)/-0.3107                     D  -16/
      DATA ARGIN1(37)/-0.9851                     D  -16/
      DATA ARGIN1(38)/-0.1453                     D  -16/
      DATA ARGIN1(39)/ 0.118                      D  -17/
      DATA ARGIN1(40)/ 0.67                       D  -18/
      DATA ARGIN1(41)/ 0.6                        D  -19/
      DATA ARGIN1(42)/-0.1                        D  -19/
      DATA ARBIN1/1.99983 76358 35861 55980  D    0,
     1           -0.81046 60923 66941 8      D   -4,
     2            0.13475 66598 4689         D   -6,
     3           -0.70855 84714 3            D   -9,
     4            0.74818 4187               D  -11,
     5           -0.12902 774                D  -12,
     6            0.32250 4                  D  -14,
     7           -0.10809                    D  -15,
     8            0.460                      D  -17,
     9           -0.24                       D  -18,
     X            0.1                        D  -19/
      DATA ARBIN2/0.13872 35645 38791 20276  D    0,
     1           -0.82392 86225 55822 8      D   -4,
     2            0.26720 91950 9866         D   -6,
     3           -0.20742 36853 68           D   -8,
     4            0.28733 92593              D  -10,
     5           -0.60873 521                D  -12,
     6            0.17924 89                 D  -13,
     7           -0.68760                    D  -15,
     8            0.3280                     D  -16,
     9           -0.188                      D  -17,
     X            0.13                       D  -18,
     1           -0.1                        D  -19/
      DATA ARHIN1/1.99647 72039 97796 50525  D    0,
     1           -0.18756 37794 07173 213    D   -2,
     2           -0.12186 47089 77873 39     D   -3,
     3           -0.81402 16096 59287        D   -5,
     4           -0.55050 92595 3537         D   -6,
     5           -0.37630 08043 303          D   -7,
     6           -0.25885 83623 65           D   -8,
     7           -0.17931 82926 5            D   -9,
     8           -0.12459 16873              D  -10,
     9           -0.87171 247                D  -12,
     X           -0.60849 43                 D  -13,
     1           -0.43117 8                  D  -14,
     2           -0.29787                    D  -15,
     3           -0.2210                     D  -16,
     4           -0.136                      D  -17,
     5           -0.14                       D  -18/
      DATA ZERO,ONE,THREE,FOUR/ 0.0 D 0 , 1.0 D 0 , 3.0 D 0 , 4.0 D 0 /
      DATA FIVE,SEVEN,MINATE/ 5.0 D 0 , 7.0 D 0 , -8.0 D 0 /
      DATA NINE,TWENT8,SEVEN2/ 9.0 D 0 , 28.0 D 0 , 72.0 D 0 /
      DATA ONEHUN,ONE76,FIVE14/ 100.0 D 0 , 176.0 D 0 , 514.0 D 0 /
      DATA ONE024,TWELHU/ 1024.0 D 0 , 1200.0 D 0 /
      DATA GIZERO/0.20497 55424 82000 24505 D 0/
      DATA ONEBPI/0.31830 98861 83790 67154 D 0/
      DATA PIBY4/0.78539 81633 97448 30962 D 0/
      DATA RTPIIN/0.56418 95835 47756 28695 D 0/
C
C   Start computation
C
      X = XVALUE
C
C   Compute the machine-dependent constants.
C
      Z = D1MACH(3)
      XLOW1 = Z
      ARG = D1MACH(4)
      XHIGH1 = ONE / ARG 
      XHIGH1 = ( XHIGH1 + XHIGH1 ) ** (ONE/THREE)
C
C   Error test 
C
      IF ( X .LT. -XHIGH1*XHIGH1 ) THEN
CCCCC    CALL ERRPRN(FNNAME,ERRMSG)
         WRITE(ICOUT,999)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,101)X
         CALL DPWRST('XXX','BUG ')
         AIRYGI = ZERO
         RETURN
      ENDIF
  999 FORMAT(1X)
  101 FORMAT('***** ERROR FROM AIRYGI--ARGUMENT TOO NEGATIVE ',
     1       'FOR ACCURATE COMPUTATION, ARGUMENT = ',G15.7)
C
C  continue with machine-dependent constants
C 
      T = ARG / ONEHUN
      IF ( X .GE. ZERO ) THEN
         DO 10 NTERM1 = 30 , 0 , -1
            IF ( ABS(ARGIP1(NTERM1)) .GT. T ) GOTO 19
 10      CONTINUE
 19      DO 20 NTERM2 = 29 , 0 , -1
            IF ( ABS(ARGIP2(NTERM2)) .GT. T ) GOTO 29
 20      CONTINUE
 29      TEMP = FOUR * PIBY4
         XHIGH2 = ONE / ( TEMP * D1MACH(1) )
      ELSE
         DO 30 NTERM3 = 42 , 0 , -1
            IF ( ABS(ARGIN1(NTERM3)) .GT. T ) GOTO 39
 30      CONTINUE
 39      DO 40 NTERM4 = 10 , 0 , -1
            IF ( ABS(ARBIN1(NTERM4)) .GT. T ) GOTO 49
 40      CONTINUE
 49      DO 50 NTERM5 = 11 , 0 , -1
            IF ( ABS(ARBIN2(NTERM5)) .GT. T ) GOTO 59
 50      CONTINUE
 59      DO 60 NTERM6 = 15 , 0 , -1
            IF ( ABS(ARHIN1(NTERM6)) .GT. T ) GOTO 69
 60      CONTINUE
 69      TEMP = ONE / Z
         XHIGH3 = MINATE * ( TEMP + TEMP ) ** (ONE/THREE)
      ENDIF
C
C   Code for x >= 0.0
C
      IF ( X .GE. ZERO ) THEN
         IF ( X .LE. SEVEN ) THEN
            IF ( X .LT. XLOW1 ) THEN
               AIRYGI = GIZERO
            ELSE
               T = ( NINE * X - TWENT8 ) / ( X + TWENT8 )
               AIRYGI = CHEVAL ( NTERM1 , ARGIP1 , T )
            ENDIF
         ELSE
            IF ( X .GT. XHIGH1 ) THEN
               IF ( X .GT. XHIGH2 ) THEN
                  AIRYGI = ZERO
               ELSE
                  AIRYGI = ONEBPI/X
               ENDIF
            ELSE
               XCUBE = X * X * X
               T = ( TWELHU - XCUBE ) / ( FIVE14 + XCUBE )
               AIRYGI = ONEBPI * CHEVAL(NTERM2,ARGIP2,T) / X
            ENDIF
         ENDIF
      ELSE
C
C   Code for x < 0.0
C
         IF ( X .GE. MINATE ) THEN
            IF ( X .GT. -XLOW1 ) THEN
               AIRYGI = GIZERO
            ELSE
               T = -( X + FOUR ) / FOUR
               AIRYGI = CHEVAL(NTERM3,ARGIN1,T)
            ENDIF
         ELSE
            XMINUS = -X
            T = XMINUS * SQRT(XMINUS)
            ZETA = ( T + T ) / THREE
            TEMP = RTPIIN / SQRT(SQRT(XMINUS))
            COSZ = COS ( ZETA + PIBY4 )
            SINZ = SIN ( ZETA + PIBY4 ) / ZETA
            XCUBE = X * X * X
            IF ( X .GT. XHIGH3 ) THEN
               T = - ( ONE024 / ( XCUBE ) + ONE )
               CHEB1 = CHEVAL(NTERM4,ARBIN1,T)
               CHEB2 = CHEVAL(NTERM5,ARBIN2,T)
               BI = ( COSZ * CHEB1 + SINZ * CHEB2 ) * TEMP
            ELSE
               BI = ( COSZ + SINZ * FIVE / SEVEN2 ) * TEMP
            ENDIF
            T = ( XCUBE + TWELHU ) / ( ONE76 - XCUBE )
            AIRYGI = BI + CHEVAL(NTERM6,ARHIN1,T) * ONEBPI / X
         ENDIF
      ENDIF
      RETURN
      END
      DOUBLE PRECISION FUNCTION AIRYHI(XVALUE)
C
C   DESCRIPTION:
C
C      This subroutine computes the modified Airy function Hi(x),
C      defined as
C
C         AIRYHI(x) = [ Integral{0 to infinity} exp(x*t-t^3/3) dt ] / pi
C
C      The approximation uses Chebyshev expansions with the coefficients 
C      given to 20 decimal places.
C
C
C   ERROR RETURNS:
C
C      If x > XHIGH1 (see below for definition of XHIGH1), then
C      the asymptotic expansion of Hi(x) will cause an overflow.
C      An error message is printed and the code returns the largest
C      floating-pt number as the result.
C 
C
C   MACHINE-DEPENDENT CONSTANTS:
C
C      NTERM1 - INTEGER - The no. of terms to be used from the array
C                         ARHIP. The recommended value is such that
C                                ABS(ARHIP(NTERM1)) < EPS/100
C                         subject to 1 <= NTERM1 <= 31.
C
C      NTERM2 - INTEGER - The no. of terms to be used from the array
C                         ARBIP. The recommended value is such that
C                                ABS(ARBIP(NTERM2)) < EPS/100
C                         subject to 1 <= NTERM2 <= 23.
C
C      NTERM3 - INTEGER - The no. of terms to be used from the array
C                         ARGIP. The recommended value is such that
C                                ABS(ARGIP1(NTERM3)) < EPS/100
C                         subject to 1 <= NTERM3 <= 29.
C
C      NTERM4 - INTEGER - The no. of terms to be used from the array
C                         ARHIN1. The recommended value is such that
C                                ABS(ARHIN1(NTERM4)) < EPS/100
C                         subject to 1 <= NTERM4 <= 21.
C
C      NTERM5 - INTEGER - The no. of terms to be used from the array
C                         ARHIN2. The recommended value is such that
C                                ABS(ARHIN2(NTERM5)) < EPS/100
C                         subject to 1 <= NTERM5 <= 15.
C
C      XLOW1 - DOUBLE PRECISION - The value such that, if -XLOW1 < x < XLOW1,
C                     then AIRYGI = Hi(0) to machine precision.
C                     The recommended value is   EPS.
C
C      XHIGH1 - DOUBLE PRECISION - The value such that, if x > XHIGH1, then
C                      overflow might occur. The recommended value is
C                      computed as follows:
C                           compute Z = 1.5*LOG(XMAX)
C                        XHIGH1 = ( Z + LOG(Z)/4 + LOG(PI)/2 )**(2/3)
C
C      XNEG1 - DOUBLE PRECISION - The value below which AIRYHI = 0.0.
C                     The recommended value is 
C                          -1/(Pi*XMIN).
C
C      XNEG2 - DOUBLE PRECISION - The value such that, if x < XNEG2, then
C                      AIRYHI = -1/(Pi*x) to machine precision.
C                      The recommended value is
C                          -cube root( 2/EPS ).
C
C      XMAX - DOUBLE PRECISION - The largest possible floating-pt. number.
C                    This is the value given to the function
C                    if x > XHIGH1.
C
C      For values of EPS, EPSNEG, XMIN  and XMAX refer to the file
C      MACHCON.TXT.
C
C     The machine-dependent constants are computed internally by
C     using the D1MACH subroutine.
C
C
C   INTRINSIC FUNCTIONS USED:
C                            EXP , LOG , SQRT
C
C
C   OTHER MISCFUN SUBROUTINES USED:
C
C          CHEVAL , ERRPRN, D1MACH
C
C
C   AUTHOR:
C          Dr. Allan J. Macleod,
C          Dept. of Mathematics and Statistics,
C          University of Paisley,
C          High St.,
C          Paisley,
C          SCOTLAND.
C
C          (e-mail: macl_ms0@paisley.ac.uk)
C
C
C   LATEST UPDATE:
C                  23 January, 1996
C                         
      INTEGER NTERM1,NTERM2,NTERM3,NTERM4,NTERM5
      DOUBLE PRECISION ARHIP(0:31),ARBIP(0:23),ARGIP1(0:29),
     1     ARHIN1(0:21),ARHIN2(0:15),
     2     BI,CHEVAL,FIVE14,FOUR,GI,HIZERO,LNRTPI,
     3     MINATE,ONE,ONEBPI,ONEHUN,ONE76,SEVEN,T,TEMP,
     4     THREE,THRE43,TWELHU,TWELVE,TWO,X,XCUBE,
     5     XHIGH1,XLOW1,XMAX,XNEG1,XNEG2,XVALUE,
     6     Z,ZERO,ZETA
CCCCC CHARACTER FNNAME*6,ERRMSG*30
CCCCC DATA FNNAME/'AIRYHI'/
CCCCC DATA ERRMSG/'ARGUMENT TO FUNCTION TOO LARGE'/
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DATA ARHIP(0)/ 1.24013 56256 17628 31114  D    0/
      DATA ARHIP(1)/ 0.64856 34197 39265 35804  D    0/
      DATA ARHIP(2)/ 0.55236 25259 21149 03246  D    0/
      DATA ARHIP(3)/ 0.20975 12207 38575 66794  D    0/
      DATA ARHIP(4)/ 0.12025 66911 80523 73568  D    0/
      DATA ARHIP(5)/ 0.37682 24931 09539 3785   D   -1/
      DATA ARHIP(6)/ 0.16510 88671 54807 1651   D   -1/
      DATA ARHIP(7)/ 0.45592 27552 11570 993    D   -2/
      DATA ARHIP(8)/ 0.16182 84804 77635 013    D   -2/
      DATA ARHIP(9)/ 0.40841 28250 81266 63     D   -3/
      DATA ARHIP(10)/0.12196 47972 13940 51     D   -3/
      DATA ARHIP(11)/0.28650 64098 65761 0      D   -4/
      DATA ARHIP(12)/0.74222 15564 24344        D   -5/
      DATA ARHIP(13)/0.16353 62319 32831        D   -5/
      DATA ARHIP(14)/0.37713 90818 8749         D   -6/
      DATA ARHIP(15)/0.78158 00336 008          D   -7/
      DATA ARHIP(16)/0.16384 47121 370          D   -7/
      DATA ARHIP(17)/0.31985 76659 92           D   -8/
      DATA ARHIP(18)/0.61933 90530 7            D   -9/
      DATA ARHIP(19)/0.11411 16119 1            D   -9/
      DATA ARHIP(20)/0.20649 23454              D  -10/
      DATA ARHIP(21)/0.36001 8664               D  -11/
      DATA ARHIP(22)/0.61401 849                D  -12/
      DATA ARHIP(23)/0.10162 125                D  -12/
      DATA ARHIP(24)/0.16437 01                 D  -13/
      DATA ARHIP(25)/0.25908 4                  D  -14/
      DATA ARHIP(26)/0.39931                    D  -15/
      DATA ARHIP(27)/0.6014                     D  -16/
      DATA ARHIP(28)/0.886                      D  -17/
      DATA ARHIP(29)/0.128                      D  -17/
      DATA ARHIP(30)/0.18                       D  -18/
      DATA ARHIP(31)/0.3                        D  -19/
      DATA ARBIP(0)/  2.00582 13820 97590 64905  D    0/
      DATA ARBIP(1)/  0.29447 84491 70441 549    D   -2/
      DATA ARBIP(2)/  0.34897 54514 77535 5      D   -4/
      DATA ARBIP(3)/  0.83389 73337 4343         D   -6/
      DATA ARBIP(4)/  0.31362 15471 813          D   -7/
      DATA ARBIP(5)/  0.16786 53060 15           D   -8/
      DATA ARBIP(6)/  0.12217 93405 9            D   -9/
      DATA ARBIP(7)/  0.11915 84139              D  -10/
      DATA ARBIP(8)/  0.15414 2553               D  -11/
      DATA ARBIP(9)/  0.24844 455                D  -12/
      DATA ARBIP(10)/ 0.42130 12                 D  -13/
      DATA ARBIP(11)/ 0.50529 3                  D  -14/
      DATA ARBIP(12)/-0.60032                    D  -15/
      DATA ARBIP(13)/-0.65474                    D  -15/
      DATA ARBIP(14)/-0.22364                    D  -15/
      DATA ARBIP(15)/-0.3015                     D  -16/
      DATA ARBIP(16)/ 0.959                      D  -17/
      DATA ARBIP(17)/ 0.616                      D  -17/
      DATA ARBIP(18)/ 0.97                       D  -18/
      DATA ARBIP(19)/-0.37                       D  -18/
      DATA ARBIP(20)/-0.21                       D  -18/
      DATA ARBIP(21)/-0.1                        D  -19/
      DATA ARBIP(22)/ 0.2                        D  -19/
      DATA ARBIP(23)/ 0.1                        D  -19/
      DATA ARGIP1(0)/  2.00473 71227 58014 86391  D    0/
      DATA ARGIP1(1)/  0.29418 41393 64406 724    D   -2/
      DATA ARGIP1(2)/  0.71369 24900 63401 67     D   -3/
      DATA ARGIP1(3)/  0.17526 56343 05022 67     D   -3/
      DATA ARGIP1(4)/  0.43591 82094 02988 2      D   -4/
      DATA ARGIP1(5)/  0.10926 26947 60430 7      D   -4/
      DATA ARGIP1(6)/  0.27238 24183 99029        D   -5/
      DATA ARGIP1(7)/  0.66230 90094 7687         D   -6/
      DATA ARGIP1(8)/  0.15425 32337 0315         D   -6/
      DATA ARGIP1(9)/  0.34184 65242 306          D   -7/
      DATA ARGIP1(10)/ 0.72815 77248 94           D   -8/
      DATA ARGIP1(11)/ 0.15158 85254 52           D   -8/
      DATA ARGIP1(12)/ 0.30940 04803 9            D   -9/
      DATA ARGIP1(13)/ 0.61496 72614              D  -10/
      DATA ARGIP1(14)/ 0.12028 77045              D  -10/
      DATA ARGIP1(15)/ 0.23369 0586               D  -11/
      DATA ARGIP1(16)/ 0.43778 068                D  -12/
      DATA ARGIP1(17)/ 0.79964 47                 D  -13/
      DATA ARGIP1(18)/ 0.14940 75                 D  -13/
      DATA ARGIP1(19)/ 0.24679 0                  D  -14/
      DATA ARGIP1(20)/ 0.37672                    D  -15/
      DATA ARGIP1(21)/ 0.7701                     D  -16/
      DATA ARGIP1(22)/ 0.354                      D  -17/
      DATA ARGIP1(23)/-0.49                       D  -18/
      DATA ARGIP1(24)/ 0.62                       D  -18/
      DATA ARGIP1(25)/-0.40                       D  -18/
      DATA ARGIP1(26)/-0.1                        D  -19/
      DATA ARGIP1(27)/ 0.2                        D  -19/
      DATA ARGIP1(28)/-0.3                        D  -19/
      DATA ARGIP1(29)/ 0.1                        D  -19/
      DATA ARHIN1(0)/  0.31481 01720 64234 04116  D    0/
      DATA ARHIN1(1)/ -0.16414 49921 65889 64341  D    0/
      DATA ARHIN1(2)/  0.61766 51597 73091 3071   D   -1/
      DATA ARHIN1(3)/ -0.19718 81185 93593 3028   D   -1/
      DATA ARHIN1(4)/  0.53690 28300 23331 343    D   -2/
      DATA ARHIN1(5)/ -0.12497 70684 39663 038    D   -2/
      DATA ARHIN1(6)/  0.24835 51559 69949 33     D   -3/
      DATA ARHIN1(7)/ -0.41870 24096 74663 0      D   -4/
      DATA ARHIN1(8)/  0.59094 54379 79124        D   -5/
      DATA ARHIN1(9)/ -0.68063 54118 4345         D   -6/
      DATA ARHIN1(10)/ 0.60728 97629 164          D   -7/
      DATA ARHIN1(11)/-0.36713 03492 42           D   -8/
      DATA ARHIN1(12)/ 0.70780 17552              D  -10/
      DATA ARHIN1(13)/ 0.11878 94334              D  -10/
      DATA ARHIN1(14)/-0.12089 8723               D  -11/
      DATA ARHIN1(15)/ 0.11896 56                 D  -13/
      DATA ARHIN1(16)/ 0.59412 8                  D  -14/
      DATA ARHIN1(17)/-0.32257                    D  -15/
      DATA ARHIN1(18)/-0.2290                     D  -16/
      DATA ARHIN1(19)/ 0.253                      D  -17/
      DATA ARHIN1(20)/ 0.9                        D  -19/
      DATA ARHIN1(21)/-0.2                        D  -19/
      DATA ARHIN2/1.99647 72039 97796 50525  D    0,
     1           -0.18756 37794 07173 213    D   -2,
     2           -0.12186 47089 77873 39     D   -3,
     3           -0.81402 16096 59287        D   -5,
     4           -0.55050 92595 3537         D   -6,
     5           -0.37630 08043 303          D   -7,
     6           -0.25885 83623 65           D   -8,
     7           -0.17931 82926 5            D   -9,
     8           -0.12459 16873              D  -10,
     9           -0.87171 247                D  -12,
     X           -0.60849 43                 D  -13,
     1           -0.43117 8                  D  -14,
     2           -0.29787                    D  -15,
     3           -0.2210                     D  -16,
     4           -0.136                      D  -17,
     5           -0.14                       D  -18/
      DATA ZERO,ONE,TWO/ 0.0 D 0 , 1.0 D 0 , 2.0 D 0/
      DATA THREE,FOUR,SEVEN/ 3.0 D 0 , 4.0 D 0 , 7.0 D 0 /
      DATA MINATE,TWELVE,ONE76/ -8.0 D 0 , 12.0 D 0 , 176.0 D 0 /
      DATA THRE43,FIVE14,TWELHU/ 343.0 D 0 , 514.0 D 0 , 1200.0 D 0 /
      DATA ONEHUN/100.0 D 0/
      DATA HIZERO/0.40995 10849 64000 49010 D 0/
      DATA LNRTPI/0.57236 49429 24700 08707 D 0/
      DATA ONEBPI/0.31830 98861 83790 67154 D 0/
C
C   Start computation
C
      X = XVALUE
C
C   Compute the machine-dependent constants.
C
      XMAX = D1MACH(2)
      TEMP = THREE * LOG(XMAX) / TWO
      ZETA = ( TEMP + LOG(TEMP)/FOUR - LOG(ONEBPI)/TWO )
      XHIGH1 = ZETA ** (TWO/THREE)
C
C   Error test
C
      IF ( X .GT. XHIGH1 ) THEN
CCCCC    CALL ERRPRN(FNNAME,ERRMSG)
         WRITE(ICOUT,999)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,101)X
         CALL DPWRST('XXX','BUG ')
         AIRYHI = XMAX
         RETURN
      ENDIF
  999 FORMAT(1X)
  101 FORMAT('***** ERROR FROM AIRYHI--ARGUMENT TO FUNCTION ',
     1        'TOO LARGE, ARGUMENT = ',G15.7)
C
C  continue with machine-dependent constants
C 
      Z = D1MACH(3)
      XLOW1 = Z
      T = Z / ONEHUN
      IF ( X .GE. ZERO ) THEN
         DO 10 NTERM1 = 31 , 0 , -1
            IF ( ABS(ARHIP(NTERM1)) .GT. T ) GOTO 19
 10      CONTINUE
 19      DO 20 NTERM2 = 23 , 0 , -1
            IF ( ABS(ARBIP(NTERM2)) .GT. T ) GOTO 29
 20      CONTINUE
 29      DO 30 NTERM3 = 29 , 0 , -1
            IF ( ABS(ARGIP1(NTERM3)) .GT. T ) GOTO 39
 30      CONTINUE
 39      CONTINUE
      ELSE
         DO 40 NTERM4 = 21 , 0 , -1
            IF ( ABS(ARHIN1(NTERM4)) .GT. T ) GOTO 49
 40      CONTINUE
 49      DO 50 NTERM5 = 15 , 0 , -1
            IF ( ABS(ARHIN2(NTERM5)) .GT. T ) GOTO 59
 50      CONTINUE
 59      TEMP = ONE / ONEBPI
         XNEG1 = - ONE / ( TEMP * D1MACH(1) )
         XNEG2 = - ( ( TWO / Z ) ** (ONE/THREE) )
      ENDIF
C
C   Code for x >= 0.0
C
      IF ( X .GE. ZERO ) THEN
         IF ( X .LE. SEVEN ) THEN
            IF ( X .LT. XLOW1 ) THEN
               AIRYHI = HIZERO
            ELSE
               T = ( X + X ) / SEVEN - ONE
               TEMP = ( X + X + X ) / TWO
               AIRYHI = EXP(TEMP) * CHEVAL(NTERM1,ARHIP,T)
            ENDIF
         ELSE
            XCUBE = X * X * X
            TEMP = SQRT(XCUBE)
            ZETA = ( TEMP + TEMP ) / THREE
            T = TWO * ( SQRT(THRE43/XCUBE) ) - ONE
            TEMP = CHEVAL(NTERM2,ARBIP,T)
            TEMP = ZETA + LOG(TEMP) - LOG(X) / FOUR - LNRTPI
            BI = EXP(TEMP)
            T = ( TWELHU - XCUBE ) / ( XCUBE + FIVE14 )
            GI = CHEVAL(NTERM3,ARGIP1,T) * ONEBPI / X
            AIRYHI = BI - GI
         ENDIF
      ELSE
C
C   Code for x < 0.0
C
         IF ( X .GE. MINATE ) THEN
            IF ( X .GT. -XLOW1 ) THEN
               AIRYHI = HIZERO
            ELSE
               T = ( FOUR * X + TWELVE ) / ( X - TWELVE )
               AIRYHI = CHEVAL(NTERM4,ARHIN1,T)
            ENDIF
         ELSE
            IF ( X .LT. XNEG1 ) THEN
               AIRYHI = ZERO
            ELSE
               IF ( X .LT. XNEG2 ) THEN
                  TEMP = ONE
               ELSE
                  XCUBE = X * X * X
                  T = ( XCUBE + TWELHU ) / ( ONE76 - XCUBE )
                  TEMP = CHEVAL(NTERM5,ARHIN2,T)
               ENDIF
               AIRYHI = - TEMP * ONEBPI / X
            ENDIF
         ENDIF
      ENDIF
      RETURN
      END 
      FUNCTION ALI (X)
C***BEGIN PROLOGUE  ALI
C***PURPOSE  Compute the logarithmic integral.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C5
C***TYPE      SINGLE PRECISION (ALI-S, DLI-D)
C***KEYWORDS  FNLIB, LOGARITHMIC INTEGRAL, SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C ALI(X) computes the logarithmic integral; i.e., the
C integral from 0.0 to X of (1.0/ln(t))dt.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  EI, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770601  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C***END PROLOGUE  ALI
C***FIRST EXECUTABLE STATEMENT  ALI
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      IF (X .LE. 0.0) THEN
        WRITE(ICOUT,1)
        CALL DPWRST('XXX','BUG ')
    1   FORMAT('***** ERORR FROM ALI, THE LOG INTEGRAL IS UNDEFINED ',
     1         'FOR NON-POSITIVE X.  *****')
        RETURN
      ENDIF
      IF (X .EQ. 1.0) THEN
        WRITE(ICOUT,2)
    2   FORMAT('***** ERORR FROM ALI, THE LOG INTEGRAL IS UNDEFINED ',
     1         'FOR X = 1.  *****')
        CALL DPWRST('XXX','BUG ')
        RETURN
      ENDIF
C
      ALI = EI (LOG(X) )
C
      RETURN
      END
      FUNCTION ALNREL(X)
C***BEGIN PROLOGUE  ALNREL
C***DATE WRITTEN   770401   (YYMMDD)
C***REVISION DATE  820801   (YYMMDD)
C***CATEGORY NO.  C4B
C***KEYWORDS  ELEMENTARY FUNCTION,LOGARITHM,RELATIVE
C***AUTHOR  FULLERTON, W., (LANL)
C***PURPOSE  Evaluates ln(1+X) accurate in the sense of relative error.
C***DESCRIPTION
C
C ALNREL(X) evaluates ln(1+X) accurately in the sense of relative
C error when X is very small.  This routine must be used to
C maintain relative error accuracy whenever X is small and
C accurately known.
C
C Series for ALNR       on the interval -3.75000D-01 to  3.75000D-01
C                                        with weighted error   1.93E-17
C                                         log weighted error  16.72
C                               significant figures required  16.44
C                                    decimal places required  17.40
C***REFERENCES  (NONE)
C***ROUTINES CALLED  CSEVL,INITS,R1MACH,XERROR
C***END PROLOGUE  ALNREL
      DIMENSION ALNRCS(23)
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DATA ALNRCS( 1) /   1.0378693562 743770E0 /
      DATA ALNRCS( 2) /   -.1336430150 4908918E0 /
      DATA ALNRCS( 3) /    .0194082491 35520563E0 /
      DATA ALNRCS( 4) /   -.0030107551 12753577E0 /
      DATA ALNRCS( 5) /    .0004869461 47971548E0 /
      DATA ALNRCS( 6) /   -.0000810548 81893175E0 /
      DATA ALNRCS( 7) /    .0000137788 47799559E0 /
      DATA ALNRCS( 8) /   -.0000023802 21089435E0 /
      DATA ALNRCS( 9) /    .0000004164 04162138E0 /
      DATA ALNRCS(10) /   -.0000000735 95828378E0 /
      DATA ALNRCS(11) /    .0000000131 17611876E0 /
      DATA ALNRCS(12) /   -.0000000023 54670931E0 /
      DATA ALNRCS(13) /    .0000000004 25227732E0 /
      DATA ALNRCS(14) /   -.0000000000 77190894E0 /
      DATA ALNRCS(15) /    .0000000000 14075746E0 /
      DATA ALNRCS(16) /   -.0000000000 02576907E0 /
      DATA ALNRCS(17) /    .0000000000 00473424E0 /
      DATA ALNRCS(18) /   -.0000000000 00087249E0 /
      DATA ALNRCS(19) /    .0000000000 00016124E0 /
      DATA ALNRCS(20) /   -.0000000000 00002987E0 /
      DATA ALNRCS(21) /    .0000000000 00000554E0 /
      DATA ALNRCS(22) /   -.0000000000 00000103E0 /
      DATA ALNRCS(23) /    .0000000000 00000019E0 /
      DATA NLNREL, XMIN /0, 0./
C***FIRST EXECUTABLE STATEMENT  ALNREL
      IF (NLNREL.NE.0) GO TO 10
      NLNREL = INITS (ALNRCS, 23, 0.1*R1MACH(3))
      XMIN = -1.0 + SQRT(R1MACH(4))
C
 10   IF (X.LE.(-1.0)) THEN
CCCCC   CALL XERROR ( 'ALNREL  X IS LE -1', 18, 2, 2)
        WRITE(ICOUT,101)
        CALL DPWRST('XXX','BUG ')
        RETURN
      ENDIF
 101  FORMAT('***** INTERNAL ERROR FROM ALNREL: ARGUMENT LESS THAN ',
     1'OR EQUAL TO -1')
      IF (X.LT.XMIN) THEN
CCCCC    CALL XERROR ( 'ALNREL  ANSWER LT HALF PRECISION BEC
CCCCC1AUSE X TOO NEAR -1', 54,    1, 1)
        WRITE(ICOUT,102)
        CALL DPWRST('XXX','BUG ')
CCCCC   RETURN
      ENDIF
 102  FORMAT('***** INTERNAL WARNING FROM ALNREL: ANSWER IS LESS THAN'
     1,' HALF PRECISION BECAUSE ARGUMENT TOO NEAR -1')
C
      IF (ABS(X).LE.0.375) ALNREL = X*(1. -
     1  X*CSEVL (X/.375, ALNRCS, NLNREL))
      IF (ABS(X).GT.0.375) ALNREL = ALOG (1.0+X)
C
      RETURN
      END
      DOUBLE PRECISION FUNCTION ALNORM(X, UPPER)
C
C       EVALUATES THE TAIL AREA OF THE STANDARDIZED NORMAL CURVE FROM
C       X TO INFINITY IF UPPER IS .TRUE. OR FROM MINUS INFINITY TO X
C       IF UPPER IS .FALSE.
C
C  NOTE NOVEMBER 2001: MODIFY UTZERO.  ALTHOUGH NOT NECESSARY
C  WHEN USING ALNORM FOR SIMPLY COMPUTING PERCENT POINTS,
C  EXTENDING RANGE IS HELPFUL FOR USE WITH FUNCTIONS THAT
C  USE ALNORM IN INTERMEDIATE COMPUTATIONS.
C
      DOUBLE PRECISION LTONE,UTZERO,ZERO,HALF,ONE,CON,
     $ A1,A2,A3,A4,A5,A6,A7,B1,B2,
     $ B3,B4,B5,B6,B7,B8,B9,B10,B11,B12,X,Y,Z,ZEXP
      LOGICAL UPPER,UP
C
C       LTONE AND UTZERO MUST BE SET TO SUIT THE PARTICULAR COMPUTER
C
CCCCC DATA LTONE, UTZERO /7.0D0, 18.66D0/
      DATA LTONE, UTZERO /7.0D0, 38.00D0/
CCCCC DATA LTONE, UTZERO /7.0D0, 100.00D0/
      DATA ZERO,HALF,ONE,CON /0.0D0,0.5D0,1.0D0,1.28D0/
      DATA          A1,             A2,            A3,
     $              A4,             A5,            A6,
     $              A7
     $ /0.398942280444D0, 0.399903438504D0, 5.75885480458D0,
     $   29.8213557808D0,  2.62433121679D0, 48.6959930692D0,
     $   5.92885724438D0/
      DATA          B1,             B2,             B3,
     $              B4,             B5,             B6,
     $              B7,             B8,             B9,
     $             B10,            B11,            B12
     $ /0.398942280385D0,      3.8052D-8,    1.00000615302D0,
     $   3.98064794D-4,     1.98615381364D0, 0.151679116635D0,
     $   5.29330324926D0,   4.8385912808D0,  15.1508972451D0,
     $  0.742380924027D0,   30.789933034D0,  3.99019417011D0/
C
      ZEXP(Z) = DEXP(Z)
C
      UP = UPPER
      Z = X
      IF (Z .GE. ZERO) GOTO 10
      UP = .NOT. UP
      Z = -Z
  10  IF (Z .LE. LTONE .OR. UP .AND. Z .LE. UTZERO) GOTO 20
      ALNORM = ZERO
      GOTO 40
  20  Y = HALF * Z * Z
      IF (Z .GT. CON) GOTO 30
C
      ALNORM = HALF - Z * (A1- A2 * Y / (Y + A3- A4 / (Y + A5 + A6 /
     $ (Y + A7))))
      GOTO 40
C
  30  ALNORM = B1* ZEXP(-Y)/(Z - B2 + B3/ (Z +B4 +B5/(Z -B6 +B7/
     $ (Z +B8 -B9/ (Z +B10 +B11/ (Z + B12))))))
C
  40  IF (.NOT. UP) ALNORM = ONE - ALNORM
      RETURN
      END
      double precision function alogam (x, ifault)
c-----------------------------------------------------------------------
c  Name:       ALOGAM
c
c  Purpose:    Value of the log-gamma function.
c
c  Usage:      ALOGAM (X, IFAULT)
c
c  Arguments:
c     X      - Value at which the log-gamma function is to be evaluated.
c              (Input)
c     IFAULT  - Error indicator.  (Output)
c               IFAULT  DEFINITION
c                 0     No error
c                 1     X .LT. 0
c     ALGAMA - The value of the log-gamma function at XX.  (Output)
c-----------------------------------------------------------------------
c
c        Algorithm ACM 291, Comm. ACM. (1966) Vol. 9, P. 684
c
c        Evaluates natural logarithm of gamma(x)
c        for X greater than zero.
c
c                                  SPECIFICATIONS FOR ARGUMENTS
      integer    ifault
      double precision x
c                                  SPECIFICATIONS FOR LOCAL VARIABLES
      double precision f, y, z
c                                  SPECIFICATIONS FOR SAVE VARIABLES
      double precision a1, a2, a3, a4, a5, half, one, seven, zero
      save       a1, a2, a3, a4, a5, half, one, seven, zero
c                                  SPECIFICATIONS FOR INTRINSICS
      intrinsic  dlog
      double precision dlog
      double precision zlog
c
c        The following constants are dlog(2PI)/2,
c        half, zero, one, seven
c
      data a1, a2, a3, a4, a5/0.918938533204673d0, 0.000595238095238d0,
     &     0.000793650793651d0, 0.002777777777778d0, 
     &     0.083333333333333d0/
      data half, zero, one, seven/0.5d0, 0.0d0, 1.0d0, 7.0d0/
c
      zlog(f) = dlog(f)
c
      alogam = zero
      ifault = 1
      if (x .lt. zero) return
      ifault = 0
      y      = x
      f      = zero
      if (y .ge. seven) go to 30
      f = y
   10 y = y + one
      if (y .ge. seven) go to 20
      f = f*y
      go to 10
   20 f = -zlog(f)
   30 z = one/(y*y)
      alogam = f + (y-half)*zlog(y) - y + a1 + (((-a2*z+a3)*z-a4)*z+a5)
     &         /y
      return
      end
      SUBROUTINE ALDCDF(X,ALPHA,BETA,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE
C              ASYMMETRIC LOG DOUBLE EXPONENTIAL (LAPLACE)
C              DISTRIBUTION.
C              THIS DISTRIBUTION IS DEFINED FOR ALL POSITIVE X AND
C              HAS THE CUMULATIVE DISTRIBUTION FUNCTION
C              F(X;ALPHA,BETA)
C                  = (ALPHA/(ALPHA+BETA))*X**BETA          0 < X < 1
C                  = 1 - (BETA/(ALPHA+BETA))*X**(-ALPHA)   X >= 1
C     INPUT  ARGUMENTS--X      = THE DOUBLE PRECISION VALUE AT
C                                WHICH THE CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C                     --ALPHA  = THE DOUBLE PRECISION FIRST
C                                SHAPE PARAMETER
C                     --BETA   = THE DOUBLE PRECISION SECOND
C                                SHAPE PARAMETER
C     OUTPUT ARGUMENTS--CDF    = THE DOUBLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION CUMULATIVE DISTRIBUTION
C             FUNCTION VALUE CDF.
C     PRINTING--NONE.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--EXP, LOG.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN. 
C     REFERENCES--KOZUBOWSKI AND PODGORSKI (2003), "LOG-LAPLACE
C                 DISTRIBUTIONS", INTERNATIONAL MATHEMATICAL
C                 JOURNAL, 3, 467-495.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899
C                 PHONE:  301-975-2899
C     ORIGINAL VERSION--MARCH     2006. 
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DOUBLE PRECISION X
      DOUBLE PRECISION ALPHA
      DOUBLE PRECISION BETA
      DOUBLE PRECISION CDF
      DOUBLE PRECISION DC
      DOUBLE PRECISION DTERM
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS.
C
      CDF=0.0D0
C
      IF(ALPHA.LE.0.0D0)THEN
        WRITE(ICOUT,25)
   25   FORMAT('***** ERROR--THE FIRST SHAPE PARAMETER TO THE ',
     1         'ALDCDF SUBROUTINE IS NON-POSITIVE')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ALPHA
   46   FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
      IF(BETA.LE.0.0D0)THEN
        WRITE(ICOUT,35)
   35   FORMAT('***** ERROR--THE SECOND SHAPE PARAMETER TO THE ',
     1         'ALDCDF SUBROUTINE IS NON-POSITIVE')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)BETA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
C
C-----START POINT-----------------------------------------------------
C
      IF(X.LE.0.0D0)THEN
        CDF=0.0D0
      ELSEIF(X.LT.1.0D0)THEN
        DC=DLOG(ALPHA) - DLOG(ALPHA+BETA)
        CDF=DC + BETA*DLOG(X)
        CDF=DEXP(CDF)
      ELSE
        DC=DLOG(BETA) - DLOG(ALPHA+BETA)
        CDF=(-ALPHA)*DLOG(X)
        CDF=1.0D0 - DEXP(DC+CDF)
      ENDIF
C
 9000 CONTINUE
      RETURN
      END 
      SUBROUTINE ALDPDF(X,ALPHA,BETA,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE
C              ASYMMETRIC LOG DOUBLE EXPONENTIAL (LAPLACE)
C              DISTRIBUTION.
C              THIS DISTRIBUTION IS DEFINED FOR ALL POSITIVE X AND
C              HAS THE PROBABILITY DENSITY FUNCTION
C              f(X;ALPHA,BETA)
C                  = C*X**(BETA-1)      0 < X < 1
C                  = C*X**(-ALPHA-1)    X >= 1
C                                       ALPHA, BETA > 0
C              WITH C = ALPHA*BETA/(ALPHA + BETA)
C     INPUT  ARGUMENTS--X      = THE DOUBLE PRECISION VALUE AT
C                                WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C                     --ALPHA  = THE DOUBLE PRECISION FIRST
C                                SHAPE PARAMETER
C                     --BETA   = THE DOUBLE PRECISION SECOND
C                                SHAPE PARAMETER
C     OUTPUT ARGUMENTS--PDF    = THE DOUBLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE PDF.
C     PRINTING--NONE.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--EXP, LOG.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN. 
C     REFERENCES--KOZUBOWSKI AND PODGORSKI (2003), "LOG-LAPLACE
C                 DISTRIBUTIONS", INTERNATIONAL MATHEMATICAL
C                 JOURNAL, 3, 467-495.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899
C                 PHONE:  301-975-2899
C     ORIGINAL VERSION--MARCH     2006. 
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DOUBLE PRECISION X
      DOUBLE PRECISION ALPHA
      DOUBLE PRECISION BETA
      DOUBLE PRECISION PDF
      DOUBLE PRECISION DC
      DOUBLE PRECISION DTERM
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS.
C
      PDF=0.0D0
C
      IF(X.LE.0.0D0)THEN
        WRITE(ICOUT,15)
   15   FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO THE ',
     1         'ALDPDF SUBROUTINE IS NON-POSITIVE')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
   46   FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
      IF(ALPHA.LE.0.0D0)THEN
        WRITE(ICOUT,25)
   25   FORMAT('***** ERROR--THE FIRST SHAPE PARAMETER TO THE ',
     1         'ALDPDF SUBROUTINE IS NON-POSITIVE')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ALPHA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
      IF(BETA.LE.0.0D0)THEN
        WRITE(ICOUT,35)
   35   FORMAT('***** ERROR--THE SECOND SHAPE PARAMETER TO THE ',
     1         'ALDPDF SUBROUTINE IS NON-POSITIVE')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)BETA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
C-----START POINT-----------------------------------------------------
C
      DC=DLOG(ALPHA) + DLOG(BETA) - DLOG(ALPHA+BETA)
C
      IF(X.LT.1.0D0)THEN
        DTERM=(BETA-1.0D0)*DLOG(X)
      ELSE
        DTERM=(-ALPHA-1.0D0)*DLOG(X)
      ENDIF
      PDF=DEXP(DC + DTERM)
C
 9000 CONTINUE
      RETURN
      END 
      SUBROUTINE ALDPPF(P,ALPHA,BETA,PPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE
C              ASYMMETRIC LOG DOUBLE EXPONENTIAL
C              (LAPLACE) DISTRIBUTION.
C              THIS DISTRIBUTION IS DEFINED FOR ALL POSITIVE X AND
C              HAS THE PERCENT POINT FUNCTION
C              G(P;ALPHA,BETA) = [P**((ALPHA+BETA)/ALPHA)]**(1/BETA)
C                                0 <= P <= ALPHA/(ALPHA+BETA)
C                              = [(1-P)**((ALPHA+BETA)/BETA)]**(-1/ALPHA)
C                                ALPHA/(ALPHA+BETA) < P < 1
C              NOTE THAT THE PERCENT POINT FUNCTION OF A DISTRIBUTION
C              IS IDENTICALLY THE SAME AS THE INVERSE CUMULATIVE
C              DISTRIBUTION FUNCTION OF THE DISTRIBUTION.
C     INPUT  ARGUMENTS--P      = THE DOUBLE PRECISION VALUE
C                                (BETWEEN 0.0 AND 1.0)
C                                AT WHICH THE PERCENT POINT
C                                FUNCTION IS TO BE EVALUATED.
C                     --ALPHA  = THE DOUBLE PRECISION FIRST
C                                SHAPE PARAMETER
C                     --BETA   = THE DOUBLE PRECISION SECOND
C                                SHAPE PARAMETER
C     OUTPUT ARGUMENTS--PPF    = THE DOUBLE PRECISION PERCENT
C                                POINT FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION PERCENT POINT
C             FUNCTION VALUE PPF.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--P SHOULD BE BETWEEN 0.0 AND 1.0, EXCLUSIVELY.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--DLOG, DEXP.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--KOZUBOWSKI AND PODGORSKI (2003), "LOG-LAPLACE
C                 DISTRIBUTIONS", INTERNATIONAL MATHEMATICAL
C                 JOURNAL, 3, 467-495.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2899
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2006/3
C     ORIGINAL VERSION--MARCH     2006.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DOUBLE PRECISION P
      DOUBLE PRECISION ALPHA
      DOUBLE PRECISION BETA
      DOUBLE PRECISION PPF
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      PPF=0.0D0
C
      IF(P.LT.0.0D0 .OR. P.GE.1.0D0)THEN
        WRITE(ICOUT,15)
   15   FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO THE ',
     1         'ALDPPF SUBROUTINE')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,16)
   16   FORMAT('      IS OUTSIDE THE ALLOWABLE (0,1] INTERVAL.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)P
   46   FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
      IF(ALPHA.LE.0.0D0)THEN
        WRITE(ICOUT,25)
   25   FORMAT('***** ERROR--THE FIRST SHAPE PARAMETER TO THE ',
     1         'ALDPPF SUBROUTINE IS NON-POSITIVE')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ALPHA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
      IF(BETA.LE.0.0D0)THEN
        WRITE(ICOUT,35)
   35   FORMAT('***** ERROR--THE SECOND SHAPE PARAMETER TO THE ',
     1         'ALDPPF SUBROUTINE IS NON-POSITIVE')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)BETA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
      DCUT=ALPHA/(ALPHA+BETA)
      IF(P.EQ.0.0D0)THEN
        PPF=0.0D0
      ELSEIF(P.LE.DCUT)THEN
        DTERM1=(ALPHA+BETA)/ALPHA
        DTERM2=(1.0D0/BETA)*DLOG(P*DTERM1)
        PPF=DEXP(DTERM2)
      ELSE
        DTERM1=(ALPHA+BETA)/BETA
        DTERM2=(-1.0D0/ALPHA)*DLOG((1.0D0-P)*DTERM1)
        PPF=DEXP(DTERM2)
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE ALDRAN(N,ALPHA,BETA,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE ASYMMETRIC LOG DOUBLE EXPONENTIAL DISTRIBUTION
C              WITH TAIL LENGTH PARAMETERS ALPHA AND BETA.
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --ALPHA  = THE SINGLE PRECISION VALUE OF THE
C                                FIRST (POSITIVE) SHAPE PARAMETER.
C                     --BETA   = THE SINGLE PRECISION VALUE OF THE
C                                SECOND (POSITIVE) SHAPE PARAMETER.
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST N)
C                                INTO WHICH THE GENERATED
C                                RANDOM SAMPLE WILL BE PLACED.
C     OUTPUT--A RANDOM SAMPLE OF SIZE N FROM THE
C             ASYMMETRIC LOG DOUBLE EXPONENTIAL DISTRIBUTION
C             WITH SHAPE PARAMETERS ALPHA AND BETA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C                 --ALPHA AND BETA SHOULD BE POSITIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--KOZUBOWSKI AND PODGORSKI, "LOG-LAPLACE
C                 DISTRIBUTIONS", PAPER DOWNLOADED FROM THEIR
C                 WEB SITE.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2006.3
C     ORIGINAL VERSION--MARCH     2006.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
      DIMENSION Y(2)
C
      DOUBLE PRECISION DALPHA
      DOUBLE PRECISION DBETA
      DOUBLE PRECISION DY1
      DOUBLE PRECISION DY2
      DOUBLE PRECISION DTEMP
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)THEN
        WRITE(ICOUT, 5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT, 6)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
      IF(ALPHA.LE.0.0)THEN
        WRITE(ICOUT,15)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,16)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ALPHA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
      IF(BETA.LE.0.0)THEN
        WRITE(ICOUT,25)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,16)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)BETA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
    5 FORMAT('***** ERROR--THE REQUESTED NUMBER OF ASYMMETRIC ',
     1       'LOG DOUBLE EXPONENTIAL')
    6 FORMAT('      RANDOM NUMBERS IS NON-POSITIVE.')
   15 FORMAT('***** ERROR--THE FIRST SHAPE PARAMETER FOR THE')
   25 FORMAT('***** ERROR--THE SECOND SHAPE PARAMETER FOR THE')
   16 FORMAT('      ASYMMETRIC LOG DOUBLE EXPONENTIAL RANDOM ',
     1       'NUMBERS IS NON-POSITIVE.')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
C
C     NOTE 3/2006: ASYMMETRIC LOG DOUBLE EXPONENTIAL CAN BE
C                  REPRESENTED AS
C                     U1**(1/ALPHA)/U2**(1/BETA)
C
C     EARLY TESTING INDICATES THAT RATIO OF UNIFORMS METHOD
C     SEEMS TO GENERATE SOME EXCESSIVELY LARGE RANDOM NUMBERS,
C     SO STICK WITH PPF METHOD FOR NOW.
C
      DALPHA=DBLE(ALPHA)
      DBETA=DBLE(BETA)
C
      IALG=0
      IF(IALG.EQ.0)THEN
        CALL UNIRAN(N,ISEED,X)
        DO100I=1,N
          CALL ALDPPF(DBLE(X(I)),DALPHA,DBETA,DTEMP)
          X(I)=REAL(DTEMP)
  100   CONTINUE
      ELSE
        NTEMP=2
        DO200I=1,N
          CALL UNIRAN(NTEMP,ISEED,Y)
          DY1=DBLE(Y(1))
          DY2=DBLE(Y(2))
          X(I)=REAL(DY1**(1.0D0/DBETA)/DY2**(1.0D0/DALPHA))
  200   CONTINUE
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE ALPCDF(X,ALPHA,BETA,CDF)
C
C     NOTE--ALPHA CDF IS:
C              ALPCDF(X,ALPHA) = NORCDF(ALPHA-BETA/X)/NORCDF(ALPHA)
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--95/4
C     ORIGINAL VERSION--APRIL     1995.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      CDF=0.0
C
      IF(ALPHA.LE.0.0 .OR. BETA.LE.0.0)THEN
        WRITE(ICOUT,101)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,103)ALPHA
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,104)BETA
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
      IF(X.LT.0.0)THEN
        WRITE(ICOUT,201)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,202)X
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ELSEIF(X.EQ.0.0)THEN
        CDF=0.0
        GOTO9999
      ENDIF
  101 FORMAT('***** FATAL DIAGNOSTIC--EITHER THE ALPHA OR BETA IS ',
     1       '      NON-POSITIVE.')
  103 FORMAT('      THE VALUE OF ALPHA IS ',E15.7)
  104 FORMAT('      THE VALUE OF BETA IS ',E15.7,'       ******')
  201 FORMAT('***** FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT IS ',
     1       '      NEGATIVE.')
  202 FORMAT('      IT HAS THE VALUE ',E15.7,'       ******')
C
      CALL NORCDF(ALPHA,TERM1)
      TERM2=ALPHA-(BETA/X)
      CALL NORCDF(TERM2,TERM3)
      CDF=TERM3/TERM1
      GOTO9999
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE ALPCHA(X,ALPHA,BETA,HAZ)
C
C     NOTE--ALPHA PDF IS:
C              ALPPDF(X,ALPHA,BETA) = NORPDF(ALPHA-BETA/X)*
C                                     BETA/[X**2*NORCDF(ALPHA)]
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--98/4
C     ORIGINAL VERSION--APRIL     1998.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
      DOUBLE PRECISION DCDF
      DOUBLE PRECISION DHAZ
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      HAZ=0.0
C
      IF(ALPHA.LE.0.0 .OR. BETA.LE.0.0)THEN
        WRITE(ICOUT,101)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,103)ALPHA
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,104)BETA
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
      IF(X.LT.0.0)THEN
        WRITE(ICOUT,201)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,202)X
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ELSEIF(X.EQ.0)THEN
        HAZ=0.0
        GOTO9999
      ENDIF
  101 FORMAT('***** FATAL DIAGNOSTIC--EITHER THE ALPHA OR BETA IS ',
     1       '      NON-POSITIVE.')
  103 FORMAT('      THE VALUE OF ALPHA IS ',E15.7)
  104 FORMAT('      THE VALUE OF BETA IS ',E15.7,'       ******')
  201 FORMAT('***** FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT IS ',
     1       '      NEGATIVE.')
  202 FORMAT('      IT HAS THE VALUE ',E15.7,'       ******')
C
      CALL NODCDF(DBLE(ALPHA),DTERM1)
      DTERM2=DBLE(ALPHA-(BETA/X))
      CALL NODCDF(DTERM2,DTERM3)
      DCDF=DTERM3/DTERM1
C
      DCDF=1.0D0-DCDF
      IF(DCDF.GT.0.0D0)THEN
        DHAZ=-DLOG(DCDF)
        HAZ=REAL(DHAZ)
      ELSE
        HAZ=0.0
        WRITE(ICOUT,302)X
        CALL DPWRST('XXX','BUG ')
      ENDIF
  302 FORMAT('**** CDF ESSENTIALLY 1, CUMULATIVE HAZARD SET TO 0.')
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE ALPHAZ(X,ALPHA,BETA,HAZ)
C
C     NOTE--ALPHA PDF IS:
C              ALPPDF(X,ALPHA,BETA) = NORPDF(ALPHA-BETA/X)*
C                                     BETA/[X**2*NORCDF(ALPHA)]
C           HAZARD FUNCTION IS:
C              H(X,A,B) = B*NORPDF(T)/(X**2*(NORCDF(A) - NORCDF(T)))
C              WHERE T = ALPHA - BETA/X
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--98/4
C     ORIGINAL VERSION--APRIL     1998.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
      DOUBLE PRECISION DTERM4
      DOUBLE PRECISION DTERM5
C
      DOUBLE PRECISION DT
      DOUBLE PRECISION DHAZ
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      HAZ=0.0
C
      IF(ALPHA.LE.0.0 .OR. BETA.LE.0.0)THEN
        WRITE(ICOUT,101)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,103)ALPHA
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,104)BETA
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
      IF(X.LT.0.0)THEN
        HAZ=0.0
        WRITE(ICOUT,201)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,202)X
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
  101 FORMAT('***** FATAL DIAGNOSTIC--EITHER THE ALPHA OR BETA IS ',
     1       '      NON-POSITIVE.')
  103 FORMAT('      THE VALUE OF ALPHA IS ',E15.7)
  104 FORMAT('      THE VALUE OF BETA IS ',E15.7,'       ******')
  201 FORMAT('***** FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT IS ',
     1       '      NEGATIVE.')
  202 FORMAT('      IT HAS THE VALUE ',E15.7,'       ******')
  206 FORMAT('***** FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT IS ',
     1       '      EQUAL TO THE SECOND INPUT ARGUMENT.')
C
C  3 CASES:
C      1) T = ALPHA - X/BETA < ALPHA
C      2) T = ALPHA - X/BETA = ALPHA
C      2) T = ALPHA - X/BETA > ALPHA
C THE HAZARD FUNCTION IS UNDEFINED FOR CASES 2 AND 3.
C
      T=ALPHA - (BETA/X)
      IF(T.GE.ALPHA)THEN
        WRITE(ICOUT,902)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,903)X,ALPHA,BETA
        CALL DPWRST('XXX','BUG ')
  902 FORMAT('**** ERROR: HAZARD FUNCTION IS UNDEFINED FOR ',
     1       'ALPHA - BETA/X >= ALPHA, HAZARD SET TO 0.')
  903 FORMAT('     X = ',E15.7, ' ALPHA = ',E15.7,' BETA = ',E15.7)
      ENDIF
      DT=DBLE(T)
      CALL NODCDF(DT,DTERM3)
      CALL NODCDF(DBLE(ALPHA),DTERM4)
      DTERM4=DTERM4-DTERM3
      IF(DTERM4.EQ.0.0D0)THEN
        HAZ=0.0
        GOTO9999
      ENDIF
C
      DTERM1=DLOG(DBLE(BETA))
      CALL NORPDF(T,TERM2)
      DTERM2=DLOG(DBLE(TERM2))
      DTERM3=2*DLOG(DBLE(X))
      DTERM4=DLOG(DTERM4)
      DTERM5=DTERM1 + DTERM2 - DTERM3 - DTERM4
      DHAZ=0.0D0
      IF(DTERM5.LE.1.0D80)DHAZ=DEXP(DTERM5)
      HAZ=REAL(DHAZ)
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE ALPPDF(X,ALPHA,BETA,PDF)
C
C     NOTE--ALPHA PDF IS:
C              ALPPDF(X,ALPHA,BETA) = NORPDF(ALPHA-BETA/X)*
C                                     BETA/[X**2*NORCDF(ALPHA)]
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--95/4
C     ORIGINAL VERSION--APRIL     1995.
C     UPDATED         --JULY      1995.   DEFINE DPDF AS DOUBLE PREC.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
      DOUBLE PRECISION DTERM4
      DOUBLE PRECISION DTERM5
      DOUBLE PRECISION DTERM7
C
CCCCC THE FOLLOWING LINE WAS ADDED     JULY 1995
      DOUBLE PRECISION DPDF
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DATA EPS/0.1E-16/
C
C-----START POINT-----------------------------------------------------
C
      PDF=0.0
C
      IF(ALPHA.LE.0.0 .OR. BETA.LE.0.0)THEN
        WRITE(ICOUT,101)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,103)ALPHA
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,104)BETA
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
      IF(X.LT.0.0)THEN
        WRITE(ICOUT,201)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,202)X
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ELSEIF(X.EQ.0)THEN
        PDF=0.0
        GOTO9999
      ENDIF
  101 FORMAT('***** FATAL DIAGNOSTIC--EITHER THE ALPHA OR BETA IS ',
     1       '      NON-POSITIVE.')
  103 FORMAT('      THE VALUE OF ALPHA IS ',E15.7)
  104 FORMAT('      THE VALUE OF BETA IS ',E15.7,'       ******')
  201 FORMAT('***** FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT IS ',
     1       '      NEGATIVE.')
  202 FORMAT('      IT HAS THE VALUE ',E15.7,'       ******')
C
      TERM1=ALPHA - (BETA/X)
      CALL NORPDF(TERM1,TERM2)
      IF(TERM2.LT.EPS)TERM2=EPS
      DTERM2=DLOG(DBLE(TERM2))
      DTERM3=DLOG(DBLE(BETA))
      DTERM4=2.0D0*DLOG(DBLE(X))
      CALL NORCDF(ALPHA,TERM5)
      DTERM5=DLOG(DBLE(TERM5))
      DTERM7=DTERM2 + DTERM3 - DTERM4 - DTERM5
C
      DPDF=DEXP(DTERM7)
      PDF=REAL(DPDF)
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE ALPPPF(P,ALPHA,BETA,PPF)
C
C     NOTE--ALPHA PPF IS:
C              ALPPPF(P,ALPHA,BETA) = 
C                           BETA/[ALPHA - NORPPF(P*NORCDF(ALPHA))]
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--95/4
C     ORIGINAL VERSION--APRIL     1995.
C     UPDATED         --JULY      1995.   DEFINE DPPF AS DOUBLE PREC.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C
      DOUBLE PRECISION DELTA
C
CCCCC THE FOLLOWING LINE WAS ADDED     JULY 1995
      DOUBLE PRECISION DPPF
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      PPF=0.0
C
      IF(P.LE.0.0 .OR. P.GE.1.0)THEN
        WRITE(ICOUT,1)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)P
        CALL DPWRST('XXX','BUG ')
        PPF=0.0
        GOTO9999
      ENDIF
      IF(ALPHA.LE.0.0 .OR. BETA.LE.0.0)THEN
        WRITE(ICOUT,101)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,103)ALPHA
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,104)BETA
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
    1 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ',
     1' ALPPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
  101 FORMAT('***** FATAL DIAGNOSTIC--EITHER THE ALPHA OR BETA IS ',
     1       '      NON-POSITIVE.')
  103 FORMAT('      THE VALUE OF ALPHA IS ',E15.7)
  104 FORMAT('      THE VALUE OF BETA IS ',E15.7,'       ******')
C
      CALL NORCDF(ALPHA,TERM1)
      TERM2=P*TERM1
      CALL NORPPF(TERM2,TERM3)
      DELTA=DBLE(ALPHA-TERM3)
      IF(DELTA.GE.0.D0)THEN
        DPPF=DBLE(BETA)/DELTA
        PPF=REAL(DPPF)
      ELSE
        WRITE(ICOUT,301)P
        CALL DPWRST('XXX','BUG ')
        PPF=0.0
      ENDIF
  301 FORMAT('***** FATAL DIAGNOSTIC--P VALUE OF ',F8.5,' RESULTS IN',
     1       ' AN INFINITE PPF VALUE.')
      GOTO9999
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE ALPRAN(N,ALPHA,BETA,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE ALPHA DISTRIBUTION
C              WITH SHAPE PARAMETER VALUES = ALPHA, BETA.
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --ALPHA  = THE SINGLE PRECISION VALUE OF THE
C                                FIRST SHAPE PARAMETER.
C                                ALPHA SHOULD BE POSITIVE.
C                     --BETA  = THE SINGLE PRECISION VALUE OF THE
C                                SECOND SHAPE PARAMETER.
C                                BETA SHOULD BE POSITIVE.
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST N)
C                                INTO WHICH THE GENERATED
C                                RANDOM SAMPLE WILL BE PLACED.
C     OUTPUT--A RANDOM SAMPLE OF SIZE N
C             FROM THE ALPHA DISTRIBUTION
C             WITH SHAPE PARAMETER VALUES = ALPHA AND BETA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C                 --ALPHA SHOULD BE POSITIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2001.10
C     ORIGINAL VERSION--OCTOBER   2001.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)THEN
        WRITE(ICOUT, 5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
    5 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ',
     1'ALPRAN SUBROUTINE IS NON-POSITIVE *****')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
C
C     GENERATE N UNIFORM (0,1) RANDOM NUMBERS;
C
      CALL UNIRAN(N,ISEED,X)
C
C     GENERATE N ALPHA DISTRIBUTION RANDOM NUMBERS
C     USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD.
C
      DO100I=1,N
        CALL ALPPPF(X(I),ALPHA,BETA,XTEMP)
        X(I)=XTEMP
  100 CONTINUE
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE ANDYK (NTOT, NBCH, XPS, XPSU, 
     $           IPBCH, NTIE, ISIZE, WK3, IWK2, ADKSTA)
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      DIMENSION XPS(*), XPSU(*), NTIE(*), 
     $          ISIZE(*), WK3(*),   IWK2(*),
     $          IPBCH(*)
C
C       NTOT  -- TOTAL NUMBER OF DATA VALUES (INPUT)
C       NBCH  -- NUMBER OF BATCHES (INPUT)
C       XPS   -- DATA, POOLED AND SORTED (INPUT)
C       XPSU  -- UNIQUE VALUES OF XPS (OUTPUT)
C       IPBCH -- BATCH NUMBERS FOR XPS (INPUT)
C       NTIE  -- NUMBER OF TIES AT EACH VALUE OF XPSU (OUTPUT)
C       ISIZE -- BATCH SIZES (INPUT)
C       WK3, IWK2  -- SCRATCH WORK ARRAYS
C       ADKSTA  -- K-SAMPLE A-D STATISTIC (OUTPUT)
C
C         K-SAMPLE ANDERSON-DARLING TEST -- 
C            INCLUDING CORRECTION FOR TIES.
C
      ADKSTA = 0.D0    
      DO 10 K=1, NBCH
         CALL ANDY2 (K, ADVAL,
     $           NTOT, NBCH, XPS, XPSU, IPBCH, NTIE,
     $           ISIZE, WK3, IWK2)
      ADKSTA = ADKSTA +ADVAL
10    CONTINUE
C
      ADKSTA = ADKSTA *(NTOT -1.D0) /(NTOT *(NBCH -1.D0))
      RETURN
      END
      SUBROUTINE ANDY2  (K, ADVAL,
     $           NTOT, NBCH, XPS, XPSU, IPBCH, 
     $           NTIE, ISIZE, WK3, IWK2)
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      DIMENSION XPS(NTOT),   XPSU(NTOT), IPBCH(NTOT),
     $          NTIE(NTOT),  ISIZE(NBCH), WK3(NTOT),  
     $          IWK2(NTOT)
C
C      -- DETERMINE THE UNIQUE VALUES, NUMBER OF TIES AND
C         NUMBER OF TIES IN KTH BATCH.
      DO 10 I=1, NTOT
         XPSU (I) = XPS (I)
         NTIE (I) = 1
         IF (IPBCH (I) .EQ. K) THEN
            IWK2  (I) = 1
         ELSE
            IWK2  (I) = 0
         END IF
10    CONTINUE
C
      I    = 2
      NDIS = NTOT               
C     DO WHILE (I .LE. NDIS)  
11    CONTINUE
      IF (I .GT. NDIS) GO TO 12                         
         IF (XPSU (I) .EQ. XPSU (I-1)) THEN             
            NTIE  (I-1) = NTIE  (I-1) + NTIE  (I)          
            IWK2  (I-1) = IWK2  (I-1) + IWK2  (I)        
            NDIS        = NDIS -1                          
            DO 20 J=I, NDIS                                  
               XPSU  (J) = XPSU  (J+1)                     
               NTIE  (J) = NTIE  (J+1)                   
               IWK2  (J) = IWK2  (J+1)                   
20         CONTINUE                                
         ELSE                                          
            I = I +1                                     
         END IF                                       
      GO TO 11
12    CONTINUE
C     END DO                                           
C
C      -- DETERMINE THE FIJ.
      XOLD = 0.0D0
      IOLD = 0
      DO 30 I=1, NDIS
         WK3 (I) = XOLD  +.5D0 *(IWK2 (I)  +IOLD)
         XOLD    = WK3 (I)
         IOLD    = IWK2 (I)
30    CONTINUE
C
C     -- CALCULATE THE ANDERSON-DARLING STATISTIC
      ADVAL = 0.D0
      NSUM  = 0
      DO 50 I=1, NDIS
         FIJ   = WK3 (I) 
         HJ    = NSUM    + .5D0 *NTIE  (I)
         NSUM  = NSUM    +       NTIE (I)
         ADVAL = ADVAL   + NTIE (I) *(NTOT*FIJ -ISIZE(K)*HJ) **2
     $                  /(HJ *(NTOT-HJ) -.25D0 *NTOT*NTIE(I))
50    CONTINUE
      ADVAL = ADVAL / (ISIZE (K) *NTOT)
      RETURN
      END
      SUBROUTINE ANGCDF(X,CDF)
C
C     NOTE--ANGLIT CDF IS:
C              ANGCDF(X) = [SIN(X + PI/4)]**2  -PI/4 <= X <= PI/4
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--95/9
C     ORIGINAL VERSION--SEPTEMBER 1995.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DATA PI/3.1415926535898E0/
C
C-----START POINT-----------------------------------------------------
C
      CDF=0.0
      IF(X.LT.-PI/4.0)THEN
        CDF=0.0
      ELSEIF(X.GT.PI/4.0)THEN
        CDF=1.0
      ELSE
        CDF=SIN(X+PI/4.0)*SIN(X+PI/4)
      ENDIF
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE ANGPDF(X,PDF)
C
C     NOTE--ANGLIT PDF IS:
C              ANGPDF(X) = SIN(2X + PI/2)  -PI/4 <= X <= PI/4
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--95/9
C     ORIGINAL VERSION--SEPTEMBER 1995.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DATA PI/3.1415926535898E0/
C
C-----START POINT-----------------------------------------------------
C
      PDF=0.0
      IF(X.LT.-PI/4.0 .OR. X.GT.PI/4.0)THEN
        WRITE(ICOUT,301)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,302)X
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
  301 FORMAT('***** FATAL DIAGNOSTIC--THE INPUT ARGUMENT IS NOT IN 
     1       THE INTERVAL (-PI/4,PI/4).')
  302 FORMAT('      IT HAS THE VALUE ',E15.7)
C
      PDF=SIN(2*X+PI/2.0)
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE ANGPPF(P,PPF)
C
C     NOTE--ALGORITHM ADDED SEPTEMBER 1995
C           G(P) = ARCSIN(SQRT(P))-PI/4
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--95/9
C     ORIGINAL VERSION--SEPTEMBER 1995.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DATA PI/3.1415926535898E0/
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(P.LT.0.0.OR.P.GT.1.0)GOTO50
      GOTO90
   50 WRITE(ICOUT,1)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)P
      CALL DPWRST('XXX','BUG ')
      PPF=0.0
      RETURN
   90 CONTINUE
    1 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ',
     1' ANGPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
      PPF=ASIN(SQRT(P))-PI/4.0
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE ANGRAN(N,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE ANGLIT DISTRIBUTION
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST N)
C                                INTO WHICH THE GENERATED
C                                RANDOM SAMPLE WILL BE PLACED.
C     OUTPUT--A RANDOM SAMPLE OF SIZE N
C             FROM THE ANGLIT DISTRIBUTION
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--2001/10
C     ORIGINAL VERSION--OCTOBER   2001.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)GOTO50
      GOTO90
   50 WRITE(ICOUT, 5)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,47)N
      CALL DPWRST('XXX','BUG ')
      RETURN
   90 CONTINUE
    5 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ',
     1'ANGRAN SUBROUTINE IS NON-POSITIVE *****')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
C
C     GENERATE N UNIFORM (0,1) RANDOM NUMBERS;
C
      CALL UNIRAN(N,ISEED,X)
C
C     GENERATE N ANGLIT RANDOM NUMBERS
C     USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD.
C
      DO100I=1,N
      CALL ANGPPF(X(I),XTEMP)
      X(I)=XTEMP
  100 CONTINUE
C
      RETURN
      END
      SUBROUTINE ARL2(DELTA, K, H, S0, ARL, ARLFIR, IFAULT)
C
C        ALGORITHM AS 258.1  APPL.STATIST. (1990), VOL.39, NO.3
C
C        Computes the average run length for a cumulative
C        sum control scheme
C
      REAL DELTA, K, H, S0, ARL, ARLFIR
      INTEGER IFAULT
      REAL ARLH, ARLHF, ARLL, ARLLF, BIGARL, BIGDEL
      INTEGER JFAULT
      DATA BIGARL / 1.E30 / , BIGDEL / 5.0 /
C
      IFAULT = 0
      IF (DELTA .LT. 0.0) THEN
         IFAULT = 1
      ELSE
C
C        Compute ARL's for upper tail.
C
         CALL ARL1(DELTA, K, H, S0, ARLH, ARLHF, IFAULT)
         IF (IFAULT .EQ. 0) THEN
C
C        If DELTA=0, then ARL's for lower tail are the same as for
C        the upper.
C
            IF (DELTA .EQ. 0.0) THEN
               ARLLF = ARLHF
               ARLL = ARLH
C
C        If DELTA is too large, skip the low-side ARL calculation.
C
            ELSE IF (DELTA .GT. BIGDEL) THEN
               ARLL = BIGARL
               ARLLF = BIGARL
            ELSE
C
C        Otherwise compute ARL's for lower tail.
C
               CALL ARL1(-DELTA, K, H, S0, ARLL, ARLLF, JFAULT)
C
C        Set lower ARL's large if negative JFAULT .GT. 0
C
               IF (ARLL .LE. ARLH .OR. ARLLF .LE. ARLHF .OR.
     *             ARLL .LT. ARLLF .OR. JFAULT .GT. 0) THEN
                  ARLL = BIGARL
                  ARLLF = BIGARL
               END IF
            END IF
C
C        Compute two-sided ARL for S0=0.0
C
            ARL = ARLH / (1.0 + ARLH / ARLL)
C
C        Compute two-sided ARL for specified value of S0.
C
            ARLFIR = ARLHF / (1.0 + ARLH / ARLL) +
     *               ARLH / (ARLH / ARLLF + ARLL / ARLLF) - ARL
C
C        Set IFAULT=3 if two-sided ARL's are lower bounds.
C
            IF (IFAULT .EQ. 0 .AND. S0 .GT. H / 2.0 + K) IFAULT = 3
         END IF
      END IF
      RETURN
      END
      SUBROUTINE ARL1(DELTA, K, H, S0, ARL, ARLFIR, IFAULT)
C
C        ALGORITHM AS 258.2  APPL.STATIST. (1990), VOL.39, NO.3
C
      REAL DELTA, K, H, S0, ARL, ARLFIR
      INTEGER IFAULT
      INTEGER N, N1, N2, I, J
      REAL XN
      DOUBLE PRECISION XCOND
      PARAMETER (N=12, N1=N + 1, N2=N + 2, XN=N, XCOND=100.D0)
      INTEGER IPVT(N1)
CCCCC REAL P1, P2
      DOUBLE PRECISION ALNORM
      DOUBLE PRECISION A(N1, N1), B(N1), R(N1), W(N2),
     *                 C, E1, E2, RCOND, S, T
      EXTERNAL ALNORM
C
C        N is the degree of the polynomial approximation.
C        XCOND defines the criterion for singularity:
C              XCOND+RCOND .LE. XCOND,
C        where RCOND is the reciprocal of the condition number.
C
      IFAULT = 0
      IF (K .LT. 0.0 .OR. H .LT. 0.0 .OR. S0 .LT. 0.0 .OR.
     *    S0 .GT. H) THEN
         IFAULT = 1
      ELSE IF (H .EQ. 0.0) THEN
         AK=REAL(K)
         ARL = 1.0 / ALNORM(DBLE(DELTA - AK), .FALSE.)
         ARLFIR = ARL
      ELSE
C
C        Set C.
C
         C = MAX(0.0, K - DELTA)
C
C        For each point S at which the polynomial approximation is to be
C        evaluated...
C
         DO 40 I = 0, N
C
C        Compute S
C
            S = H * I / XN
C
C        Calculate necessary exponentials in S.
C
            E1 = EXP(C * S)
            E2 = EXP((S + DELTA - K) * C + C * C / 2.0)
C
C        Apply left-hand-side of integral equation.
C
            T = E1
            DO 10 J = 1, N + 1
               A(I + 1, J) = T
               T = T * S
   10       CONTINUE
C
C        Apply lower integration limit.
C
            CALL MOMENT(-S - DELTA - C + K, -S - DELTA - C + K, N, R, W)
            DO 20 J = 1, N + 1
               A(I + 1, J) = A(I + 1, J) - R(J) * E2
   20       CONTINUE
C
C        Apply upper integration limit.
C
            CALL MOMENT(H - S - DELTA - C + K, -S - DELTA - C + K, N, R,
     *                  W)
            DO 30 J = 1, N + 1
               A(I + 1, J) = A(I + 1, J) + R(J) * E2
   30       CONTINUE
C
C        Apply term '1 + L(0) F(-S-DELTA+K)'.
C
            AK=REAL(K)
            A(I + 1, 1) = A(I + 1, 1) - ALNORM(-S - DELTA + AK,
     *                    .FALSE.)
            B(I + 1) = 1.0
   40    CONTINUE
C
C        Normalize the simultaneous equations
C
         DO 70 I = 1, N + 1
            S = 0.0
            DO 50 J = 1, N + 1
               S = MAX(S, ABS(A(I, J)))
   50       CONTINUE
            B(I) = B(I) / S
            DO 60 J = 1, N + 1
               A(I, J) = A(I, J) / S
   60       CONTINUE
   70    CONTINUE
         DO 100 J = 1, N + 1
            W(J) = 0.0
            DO 80 I = 1, N + 1
               W(J) = MAX(W(J), ABS(A(I, J)))
   80       CONTINUE
            DO 90 I = 1, N + 1
               A(I, J) = A(I, J) / W(J)
   90       CONTINUE
  100    CONTINUE
C
C        Factor matrix A.  If equations are singular to working
C        precision, IFAULT=2.
C
C        ***************************************
C        SUBROUTINE DGECO(A,LDA,N,IPVT,RCOND,Z)
C        on entry:
C        A:     the matrix to be factored.
C        LDA:   the leading dimension of array A.
C        N:     the order of the matrix A.
C        on return:
C        A:     the lu factorization of A.
C        IPVT:  pivot indices.
C        RCOND: an estimate of the reciprocal condition of A.
C        Z:     a working vector.
C        ***************************************
C
         CALL DGECO(A, N + 1, N + 1, IPVT, RCOND, R)
         IF (XCOND + RCOND .EQ. XCOND) THEN
            IFAULT = 2
         ELSE
C
C        Solve for the polynomial coefficients
C
C        ***************************************
C        SUBROUTINE DGESL(A,LDA,N,IPVT,B,JOB)
C        on entry:
C        A:     the output from dgeco.
C        LDA:   the leading dimension of array A.
C        N:     the order of the matrix A.
C        IPVT:  the pivot vector from dgeco.
C        B:     the right hand side vector.
C        JOB:   = 0       to solve A*X=B.
C               = nonzero to solve trans(A)*X=B.
C        on return:
C        B:     the solution vector X.
C        ***************************************
C
            CALL DGESL(A, N + 1, N + 1, IPVT, B, 0)
C
C        Get ARL and ARLFIR.
C
            ARL = B(1) / W(1)
            ARLFIR = 0.0
            DO 110 I = 0, N
               ARLFIR = S0 * ARLFIR + B(N - I + 1) / W(N - I + 1)
  110       CONTINUE
            ARLFIR = ARLFIR * EXP(C * S0)
         END IF
      END IF
      RETURN
      END
      SUBROUTINE ARSCDF(X,CDF)
C
C     NOTE--ARCSIN CDF IS:
C              ARSCDF(X) = (2/PI)*ARCSIN(SQRT(X))  0 < X < 1
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--95/9
C     ORIGINAL VERSION--SEPTEMBER 1995.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DATA PI/3.1415926535898E0/
C
C-----START POINT-----------------------------------------------------
C
      CDF=0.0
      IF(X.LE.0.0)THEN
        CDF=0.0
      ELSEIF(X.GE.1.0)THEN
        CDF=1.0
      ELSE
        CDF=(2.0/PI)*ASIN(SQRT(X))
      ENDIF
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE ARSPDF(X,PDF)
C
C     NOTE--ARCSIN PDF IS:
C              ARSPDF(X) = (1/PI)*(1/SQRT(X*(1-x)))  0 < x < 1
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--95/9
C     ORIGINAL VERSION--SEPTEMBER 1995.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DATA PI/3.1415926535898E0/
C
C-----START POINT-----------------------------------------------------
C
      PDF=0.0
      IF(X.LE.0.0 .OR. X.GE.1.0)THEN
        WRITE(ICOUT,301)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,302)X
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
  301 FORMAT('***** FATAL DIAGNOSTIC--THE INPUT ARGUMENT IS NOT IN 
     1       THE INTERVAL (0,1).')
  302 FORMAT('      IT HAS THE VALUE ',E15.7)
C
      PDF=1.0/(PI*SQRT(X*(1.0-X)))
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE ARSPPF(P,PPF)
C
C     NOTE--ALGORITHM ADDED SEPTEMBER 1995
C           ARSPPF(P) = (SIN(PI*P/2))**2
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--95/9
C     ORIGINAL VERSION--SEPTEMBER 1995.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DATA PI/3.1415926535898E0/
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(P.LT.0.0.OR.P.GT.1.0)GOTO50
      GOTO90
   50 WRITE(ICOUT,1)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)P
      CALL DPWRST('XXX','BUG ')
      PPF=0.0
      RETURN
   90 CONTINUE
    1 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ',
     1' ARSPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
      PPF=SIN(PI*P/2.0)*SIN(PI*P/2.0)
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE ARSRAN(N,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE ARCSIN DISTRIBUTION
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST N)
C                                INTO WHICH THE GENERATED
C                                RANDOM SAMPLE WILL BE PLACED.
C     OUTPUT--A RANDOM SAMPLE OF SIZE N
C             FROM THE ARCSIN DISTRIBUTION
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--2001/10
C     ORIGINAL VERSION--OCTOBER   2001.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)GOTO50
      GOTO90
   50 WRITE(ICOUT, 5)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,47)N
      CALL DPWRST('XXX','BUG ')
      RETURN
   90 CONTINUE
    5 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ',
     1'ARSRAN SUBROUTINE IS NON-POSITIVE *****')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
C
C     GENERATE N UNIFORM (0,1) RANDOM NUMBERS;
C
      CALL UNIRAN(N,ISEED,X)
C
C     GENERATE N ARCSIN RANDOM NUMBERS
C     USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD.
C
      DO100I=1,N
      CALL ARSPPF(X(I),XTEMP)
      X(I)=XTEMP
  100 CONTINUE
C
      RETURN
      END
      SUBROUTINE ASYIK (X, FNU, KODE, FLGIK, RA, ARG, IN, Y)
C***BEGIN PROLOGUE  ASYIK
C***SUBSIDIARY
C***PURPOSE  Subsidiary to BESI and BESK
C***LIBRARY   SLATEC
C***TYPE      SINGLE PRECISION (ASYIK-S, DASYIK-D)
C***AUTHOR  Amos, D. E., (SNLA)
C***DESCRIPTION
C
C                    ASYIK computes Bessel functions I and K
C                  for arguments X.GT.0.0 and orders FNU.GE.35
C                  on FLGIK = 1 and FLGIK = -1 respectively.
C
C                                    INPUT
C
C      X    - argument, X.GT.0.0E0
C      FNU  - order of first Bessel function
C      KODE - a parameter to indicate the scaling option
C             KODE=1 returns Y(I)=        I/SUB(FNU+I-1)/(X), I=1,IN
C                    or      Y(I)=        K/SUB(FNU+I-1)/(X), I=1,IN
C                    on FLGIK = 1.0E0 or FLGIK = -1.0E0
C             KODE=2 returns Y(I)=EXP(-X)*I/SUB(FNU+I-1)/(X), I=1,IN
C                    or      Y(I)=EXP( X)*K/SUB(FNU+I-1)/(X), I=1,IN
C                    on FLGIK = 1.0E0 or FLGIK = -1.0E0
C     FLGIK - selection parameter for I or K function
C             FLGIK =  1.0E0 gives the I function
C             FLGIK = -1.0E0 gives the K function
C        RA - SQRT(1.+Z*Z), Z=X/FNU
C       ARG - argument of the leading exponential
C        IN - number of functions desired, IN=1 or 2
C
C                                    OUTPUT
C
C         Y - a vector whose first in components contain the sequence
C
C     Abstract
C         ASYIK implements the uniform asymptotic expansion of
C         the I and K Bessel functions for FNU.GE.35 and real
C         X.GT.0.0E0. The forms are identical except for a change
C         in sign of some of the terms. This change in sign is
C         accomplished by means of the flag FLGIK = 1 or -1.
C
C***SEE ALSO  BESI, BESK
C***ROUTINES CALLED  R1MACH
C***REVISION HISTORY  (YYMMDD)
C   750101  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900328  Added TYPE section.  (WRB)
C   910408  Updated the AUTHOR section.  (WRB)
C***END PROLOGUE  ASYIK
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C
      INTEGER IN, J, JN, K, KK, KODE, L
      REAL AK,AP,ARG,C, COEF,CON,ETX,FLGIK,FN, FNU,GLN,RA,S1,S2,
     1 T, TOL, T2, X, Y, Z
      DIMENSION Y(*), C(65), CON(2)
      SAVE CON, C
      DATA CON(1), CON(2)  /
     1        3.98942280401432678E-01,    1.25331413731550025E+00/
      DATA C(1), C(2), C(3), C(4), C(5), C(6), C(7), C(8), C(9), C(10),
     1     C(11), C(12), C(13), C(14), C(15), C(16), C(17), C(18),
     2     C(19), C(20), C(21), C(22), C(23), C(24)/
     3       -2.08333333333333E-01,        1.25000000000000E-01,
     4        3.34201388888889E-01,       -4.01041666666667E-01,
     5        7.03125000000000E-02,       -1.02581259645062E+00,
     6        1.84646267361111E+00,       -8.91210937500000E-01,
     7        7.32421875000000E-02,        4.66958442342625E+00,
     8       -1.12070026162230E+01,        8.78912353515625E+00,
     9       -2.36408691406250E+00,        1.12152099609375E-01,
     1       -2.82120725582002E+01,        8.46362176746007E+01,
     2       -9.18182415432400E+01,        4.25349987453885E+01,
     3       -7.36879435947963E+00,        2.27108001708984E-01,
     4        2.12570130039217E+02,       -7.65252468141182E+02,
     5        1.05999045252800E+03,       -6.99579627376133E+02/
      DATA C(25), C(26), C(27), C(28), C(29), C(30), C(31), C(32),
     1     C(33), C(34), C(35), C(36), C(37), C(38), C(39), C(40),
     2     C(41), C(42), C(43), C(44), C(45), C(46), C(47), C(48)/
     3        2.18190511744212E+02,       -2.64914304869516E+01,
     4        5.72501420974731E-01,       -1.91945766231841E+03,
     5        8.06172218173731E+03,       -1.35865500064341E+04,
     6        1.16553933368645E+04,       -5.30564697861340E+03,
     7        1.20090291321635E+03,       -1.08090919788395E+02,
     8        1.72772750258446E+00,        2.02042913309661E+04,
     9       -9.69805983886375E+04,        1.92547001232532E+05,
     1       -2.03400177280416E+05,        1.22200464983017E+05,
     2       -4.11926549688976E+04,        7.10951430248936E+03,
     3       -4.93915304773088E+02,        6.07404200127348E+00,
     4       -2.42919187900551E+05,        1.31176361466298E+06,
     5       -2.99801591853811E+06,        3.76327129765640E+06/
      DATA C(49), C(50), C(51), C(52), C(53), C(54), C(55), C(56),
     1     C(57), C(58), C(59), C(60), C(61), C(62), C(63), C(64),
     2     C(65)/
     3       -2.81356322658653E+06,        1.26836527332162E+06,
     4       -3.31645172484564E+05,        4.52187689813627E+04,
     5       -2.49983048181121E+03,        2.43805296995561E+01,
     6        3.28446985307204E+06,       -1.97068191184322E+07,
     7        5.09526024926646E+07,       -7.41051482115327E+07,
     8        6.63445122747290E+07,       -3.75671766607634E+07,
     9        1.32887671664218E+07,       -2.78561812808645E+06,
     1        3.08186404612662E+05,       -1.38860897537170E+04,
     2        1.10017140269247E+02/
C***FIRST EXECUTABLE STATEMENT  ASYIK
      TOL = R1MACH(3)
      TOL = MAX(TOL,1.0E-15)
      FN = FNU
      Z  = (3.0E0-FLGIK)/2.0E0
      KK = INT(Z)
      DO 50 JN=1,IN
        IF (JN.EQ.1) GO TO 10
        FN = FN - FLGIK
        Z = X/FN
        RA = SQRT(1.0E0+Z*Z)
        GLN = LOG((1.0E0+RA)/Z)
        ETX = KODE - 1
        T = RA*(1.0E0-ETX) + ETX/(Z+RA)
        ARG = FN*(T-GLN)*FLGIK
   10   COEF = EXP(ARG)
        T = 1.0E0/RA
        T2 = T*T
        T = T/FN
        T = SIGN(T,FLGIK)
        S2 = 1.0E0
        AP = 1.0E0
        L = 0
        DO 30 K=2,11
          L = L + 1
          S1 = C(L)
          DO 20 J=2,K
            L = L + 1
            S1 = S1*T2 + C(L)
   20     CONTINUE
          AP = AP*T
          AK = AP*S1
          S2 = S2 + AK
          IF (MAX(ABS(AK),ABS(AP)) .LT. TOL) GO TO 40
   30   CONTINUE
   40   CONTINUE
      T = ABS(T)
      Y(JN) = S2*COEF*SQRT(T)*CON(KK)
   50 CONTINUE
      RETURN
      END
      SUBROUTINE ASYJY (FUNJY, X, FNU, FLGJY, IN, Y, WK, IFLW)
C***BEGIN PROLOGUE  ASYJY
C***SUBSIDIARY
C***PURPOSE  Subsidiary to BESJ and BESY
C***LIBRARY   SLATEC
C***TYPE      SINGLE PRECISION (ASYJY-S, DASYJY-D)
C***AUTHOR  Amos, D. E., (SNLA)
C***DESCRIPTION
C
C                 ASYJY computes Bessel functions J and Y
C               for arguments X.GT.0.0 and orders FNU.GE.35.0
C               on FLGJY = 1 and FLGJY = -1 respectively
C
C                                  INPUT
C
C      FUNJY - external function JAIRY or YAIRY
C          X - argument, X.GT.0.0E0
C        FNU - order of the first Bessel function
C      FLGJY - selection flag
C              FLGJY =  1.0E0 gives the J function
C              FLGJY = -1.0E0 gives the Y function
C         IN - number of functions desired, IN = 1 or 2
C
C                                  OUTPUT
C
C         Y  - a vector whose first in components contain the sequence
C       IFLW - a flag indicating underflow or overflow
C                    return variables for BESJ only
C      WK(1) = 1 - (X/FNU)**2 = W**2
C      WK(2) = SQRT(ABS(WK(1)))
C      WK(3) = ABS(WK(2) - ATAN(WK(2)))  or
C              ABS(LN((1 + WK(2))/(X/FNU)) - WK(2))
C            = ABS((2/3)*ZETA**(3/2))
C      WK(4) = FNU*WK(3)
C      WK(5) = (1.5*WK(3)*FNU)**(1/3) = SQRT(ZETA)*FNU**(1/3)
C      WK(6) = SIGN(1.,W**2)*WK(5)**2 = SIGN(1.,W**2)*ZETA*FNU**(2/3)
C      WK(7) = FNU**(1/3)
C
C     Abstract
C         ASYJY implements the uniform asymptotic expansion of
C         the J and Y Bessel functions for FNU.GE.35 and real
C         X.GT.0.0E0. The forms are identical except for a change
C         in sign of some of the terms. This change in sign is
C         accomplished by means of the flag FLGJY = 1 or -1. On
C         FLGJY = 1 the AIRY functions AI(X) and DAI(X) are
C         supplied by the external function JAIRY, and on
C         FLGJY = -1 the AIRY functions BI(X) and DBI(X) are
C         supplied by the external function YAIRY.
C
C***SEE ALSO  BESJ, BESY
C***ROUTINES CALLED  I1MACH, R1MACH
C***REVISION HISTORY  (YYMMDD)
C   750101  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   891009  Removed unreferenced variable.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900328  Added TYPE section.  (WRB)
C   910408  Updated the AUTHOR section.  (WRB)
C***END PROLOGUE  ASYJY
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      INTEGER I, IFLW, IN, J, JN,JR,JU,K, KB,KLAST,KMAX,KP1, KS, KSP1,
     * KSTEMP, L, LR, LRP1, ISETA, ISETB
      REAL ABW2, AKM, ALFA, ALFA1, ALFA2, AP, AR, ASUM, AZ,
     * BETA, BETA1, BETA2, BETA3, BR, BSUM, C, CON1, CON2,
     * CON548,CR,CRZ32, DFI,ELIM, DR,FI, FLGJY, FN, FNU,
     * FN2, GAMA, PHI,  RCZ, RDEN, RELB, RFN2,  RTZ, RZDEN,
     * SA, SB, SUMA, SUMB, S1, TA, TAU, TB, TFN, TOL, TOLS, T2, UPOL,
     *  WK, X, XX, Y, Z, Z32
      DIMENSION Y(*), WK(*), C(65)
      DIMENSION ALFA(26,4), BETA(26,5)
      DIMENSION ALFA1(26,2), ALFA2(26,2)
      DIMENSION BETA1(26,2), BETA2(26,2), BETA3(26,1)
      DIMENSION GAMA(26), KMAX(5), AR(8), BR(10), UPOL(10)
      DIMENSION CR(10), DR(10)
      EQUIVALENCE (ALFA(1,1),ALFA1(1,1))
      EQUIVALENCE (ALFA(1,3),ALFA2(1,1))
      EQUIVALENCE (BETA(1,1),BETA1(1,1))
      EQUIVALENCE (BETA(1,3),BETA2(1,1))
      EQUIVALENCE (BETA(1,5),BETA3(1,1))
      SAVE TOLS, CON1, CON2, CON548, AR, BR, C, ALFA1, ALFA2,
     1 BETA1, BETA2, BETA3, GAMA
      DATA TOLS            /-6.90775527898214E+00/
      DATA CON1,CON2,CON548/
     1 6.66666666666667E-01, 3.33333333333333E-01, 1.04166666666667E-01/
      DATA  AR(1),  AR(2),  AR(3),  AR(4),  AR(5),  AR(6),  AR(7),
     A      AR(8)          / 8.35503472222222E-02, 1.28226574556327E-01,
     1 2.91849026464140E-01, 8.81627267443758E-01, 3.32140828186277E+00,
     2 1.49957629868626E+01, 7.89230130115865E+01, 4.74451538868264E+02/
      DATA  BR(1), BR(2), BR(3), BR(4), BR(5), BR(6), BR(7), BR(8),
     A      BR(9), BR(10)  /-1.45833333333333E-01,-9.87413194444444E-02,
     1-1.43312053915895E-01,-3.17227202678414E-01,-9.42429147957120E-01,
     2-3.51120304082635E+00,-1.57272636203680E+01,-8.22814390971859E+01,
     3-4.92355370523671E+02,-3.31621856854797E+03/
      DATA C(1), C(2), C(3), C(4), C(5), C(6), C(7), C(8), C(9), C(10),
     1     C(11), C(12), C(13), C(14), C(15), C(16), C(17), C(18),
     2     C(19), C(20), C(21), C(22), C(23), C(24)/
     3       -2.08333333333333E-01,        1.25000000000000E-01,
     4        3.34201388888889E-01,       -4.01041666666667E-01,
     5        7.03125000000000E-02,       -1.02581259645062E+00,
     6        1.84646267361111E+00,       -8.91210937500000E-01,
     7        7.32421875000000E-02,        4.66958442342625E+00,
     8       -1.12070026162230E+01,        8.78912353515625E+00,
     9       -2.36408691406250E+00,        1.12152099609375E-01,
     A       -2.82120725582002E+01,        8.46362176746007E+01,
     B       -9.18182415432400E+01,        4.25349987453885E+01,
     C       -7.36879435947963E+00,        2.27108001708984E-01,
     D        2.12570130039217E+02,       -7.65252468141182E+02,
     E        1.05999045252800E+03,       -6.99579627376133E+02/
      DATA C(25), C(26), C(27), C(28), C(29), C(30), C(31), C(32),
     1     C(33), C(34), C(35), C(36), C(37), C(38), C(39), C(40),
     2     C(41), C(42), C(43), C(44), C(45), C(46), C(47), C(48)/
     3        2.18190511744212E+02,       -2.64914304869516E+01,
     4        5.72501420974731E-01,       -1.91945766231841E+03,
     5        8.06172218173731E+03,       -1.35865500064341E+04,
     6        1.16553933368645E+04,       -5.30564697861340E+03,
     7        1.20090291321635E+03,       -1.08090919788395E+02,
     8        1.72772750258446E+00,        2.02042913309661E+04,
     9       -9.69805983886375E+04,        1.92547001232532E+05,
     A       -2.03400177280416E+05,        1.22200464983017E+05,
     B       -4.11926549688976E+04,        7.10951430248936E+03,
     C       -4.93915304773088E+02,        6.07404200127348E+00,
     D       -2.42919187900551E+05,        1.31176361466298E+06,
     E       -2.99801591853811E+06,        3.76327129765640E+06/
      DATA C(49), C(50), C(51), C(52), C(53), C(54), C(55), C(56),
     1     C(57), C(58), C(59), C(60), C(61), C(62), C(63), C(64),
     2     C(65)/
     3       -2.81356322658653E+06,        1.26836527332162E+06,
     4       -3.31645172484564E+05,        4.52187689813627E+04,
     5       -2.49983048181121E+03,        2.43805296995561E+01,
     6        3.28446985307204E+06,       -1.97068191184322E+07,
     7        5.09526024926646E+07,       -7.41051482115327E+07,
     8        6.63445122747290E+07,       -3.75671766607634E+07,
     9        1.32887671664218E+07,       -2.78561812808645E+06,
     A        3.08186404612662E+05,       -1.38860897537170E+04,
     B        1.10017140269247E+02/
      DATA ALFA1(1,1), ALFA1(2,1), ALFA1(3,1), ALFA1(4,1), ALFA1(5,1),
     1     ALFA1(6,1), ALFA1(7,1), ALFA1(8,1), ALFA1(9,1), ALFA1(10,1),
     2     ALFA1(11,1),ALFA1(12,1),ALFA1(13,1),ALFA1(14,1),ALFA1(15,1),
     3     ALFA1(16,1),ALFA1(17,1),ALFA1(18,1),ALFA1(19,1),ALFA1(20,1),
     4     ALFA1(21,1),ALFA1(22,1),ALFA1(23,1),ALFA1(24,1),ALFA1(25,1),
     5     ALFA1(26,1)     /-4.44444444444444E-03,-9.22077922077922E-04,
     6-8.84892884892885E-05, 1.65927687832450E-04, 2.46691372741793E-04,
     7 2.65995589346255E-04, 2.61824297061501E-04, 2.48730437344656E-04,
     8 2.32721040083232E-04, 2.16362485712365E-04, 2.00738858762752E-04,
     9 1.86267636637545E-04, 1.73060775917876E-04, 1.61091705929016E-04,
     1 1.50274774160908E-04, 1.40503497391270E-04, 1.31668816545923E-04,
     2 1.23667445598253E-04, 1.16405271474738E-04, 1.09798298372713E-04,
     3 1.03772410422993E-04, 9.82626078369363E-05, 9.32120517249503E-05,
     4 8.85710852478712E-05, 8.42963105715700E-05, 8.03497548407791E-05/
      DATA ALFA1(1,2), ALFA1(2,2), ALFA1(3,2), ALFA1(4,2), ALFA1(5,2),
     1     ALFA1(6,2), ALFA1(7,2), ALFA1(8,2), ALFA1(9,2), ALFA1(10,2),
     2     ALFA1(11,2),ALFA1(12,2),ALFA1(13,2),ALFA1(14,2),ALFA1(15,2),
     3     ALFA1(16,2),ALFA1(17,2),ALFA1(18,2),ALFA1(19,2),ALFA1(20,2),
     4     ALFA1(21,2),ALFA1(22,2),ALFA1(23,2),ALFA1(24,2),ALFA1(25,2),
     5     ALFA1(26,2)     / 6.93735541354589E-04, 2.32241745182922E-04,
     6-1.41986273556691E-05,-1.16444931672049E-04,-1.50803558053049E-04,
     7-1.55121924918096E-04,-1.46809756646466E-04,-1.33815503867491E-04,
     8-1.19744975684254E-04,-1.06184319207974E-04,-9.37699549891194E-05,
     9-8.26923045588193E-05,-7.29374348155221E-05,-6.44042357721016E-05,
     1-5.69611566009369E-05,-5.04731044303562E-05,-4.48134868008883E-05,
     2-3.98688727717599E-05,-3.55400532972042E-05,-3.17414256609022E-05,
     3-2.83996793904175E-05,-2.54522720634871E-05,-2.28459297164725E-05,
     4-2.05352753106481E-05,-1.84816217627666E-05,-1.66519330021394E-05/
      DATA ALFA2(1,1), ALFA2(2,1), ALFA2(3,1), ALFA2(4,1), ALFA2(5,1),
     1     ALFA2(6,1), ALFA2(7,1), ALFA2(8,1), ALFA2(9,1), ALFA2(10,1),
     2     ALFA2(11,1),ALFA2(12,1),ALFA2(13,1),ALFA2(14,1),ALFA2(15,1),
     3     ALFA2(16,1),ALFA2(17,1),ALFA2(18,1),ALFA2(19,1),ALFA2(20,1),
     4     ALFA2(21,1),ALFA2(22,1),ALFA2(23,1),ALFA2(24,1),ALFA2(25,1),
     5     ALFA2(26,1)     /-3.54211971457744E-04,-1.56161263945159E-04,
     6 3.04465503594936E-05, 1.30198655773243E-04, 1.67471106699712E-04,
     7 1.70222587683593E-04, 1.56501427608595E-04, 1.36339170977445E-04,
     8 1.14886692029825E-04, 9.45869093034688E-05, 7.64498419250898E-05,
     9 6.07570334965197E-05, 4.74394299290509E-05, 3.62757512005344E-05,
     1 2.69939714979225E-05, 1.93210938247939E-05, 1.30056674793963E-05,
     2 7.82620866744497E-06, 3.59257485819352E-06, 1.44040049814252E-07,
     3-2.65396769697939E-06,-4.91346867098486E-06,-6.72739296091248E-06,
     4-8.17269379678658E-06,-9.31304715093561E-06,-1.02011418798016E-05/
      DATA ALFA2(1,2), ALFA2(2,2), ALFA2(3,2), ALFA2(4,2), ALFA2(5,2),
     1     ALFA2(6,2), ALFA2(7,2), ALFA2(8,2), ALFA2(9,2), ALFA2(10,2),
     2     ALFA2(11,2),ALFA2(12,2),ALFA2(13,2),ALFA2(14,2),ALFA2(15,2),
     3     ALFA2(16,2),ALFA2(17,2),ALFA2(18,2),ALFA2(19,2),ALFA2(20,2),
     4     ALFA2(21,2),ALFA2(22,2),ALFA2(23,2),ALFA2(24,2),ALFA2(25,2),
     5     ALFA2(26,2)     / 3.78194199201773E-04, 2.02471952761816E-04,
     6-6.37938506318862E-05,-2.38598230603006E-04,-3.10916256027362E-04,
     7-3.13680115247576E-04,-2.78950273791323E-04,-2.28564082619141E-04,
     8-1.75245280340847E-04,-1.25544063060690E-04,-8.22982872820208E-05,
     9-4.62860730588116E-05,-1.72334302366962E-05, 5.60690482304602E-06,
     1 2.31395443148287E-05, 3.62642745856794E-05, 4.58006124490189E-05,
     2 5.24595294959114E-05, 5.68396208545815E-05, 5.94349820393104E-05,
     3 6.06478527578422E-05, 6.08023907788436E-05, 6.01577894539460E-05,
     4 5.89199657344698E-05, 5.72515823777593E-05, 5.52804375585853E-05/
      DATA BETA1(1,1), BETA1(2,1), BETA1(3,1), BETA1(4,1), BETA1(5,1),
     1     BETA1(6,1), BETA1(7,1), BETA1(8,1), BETA1(9,1), BETA1(10,1),
     2     BETA1(11,1),BETA1(12,1),BETA1(13,1),BETA1(14,1),BETA1(15,1),
     3     BETA1(16,1),BETA1(17,1),BETA1(18,1),BETA1(19,1),BETA1(20,1),
     4     BETA1(21,1),BETA1(22,1),BETA1(23,1),BETA1(24,1),BETA1(25,1),
     5     BETA1(26,1)     / 1.79988721413553E-02, 5.59964911064388E-03,
     6 2.88501402231133E-03, 1.80096606761054E-03, 1.24753110589199E-03,
     7 9.22878876572938E-04, 7.14430421727287E-04, 5.71787281789705E-04,
     8 4.69431007606482E-04, 3.93232835462917E-04, 3.34818889318298E-04,
     9 2.88952148495752E-04, 2.52211615549573E-04, 2.22280580798883E-04,
     1 1.97541838033063E-04, 1.76836855019718E-04, 1.59316899661821E-04,
     2 1.44347930197334E-04, 1.31448068119965E-04, 1.20245444949303E-04,
     3 1.10449144504599E-04, 1.01828770740567E-04, 9.41998224204238E-05,
     4 8.74130545753834E-05, 8.13466262162801E-05, 7.59002269646219E-05/
      DATA BETA1(1,2), BETA1(2,2), BETA1(3,2), BETA1(4,2), BETA1(5,2),
     1     BETA1(6,2), BETA1(7,2), BETA1(8,2), BETA1(9,2), BETA1(10,2),
     2     BETA1(11,2),BETA1(12,2),BETA1(13,2),BETA1(14,2),BETA1(15,2),
     3     BETA1(16,2),BETA1(17,2),BETA1(18,2),BETA1(19,2),BETA1(20,2),
     4     BETA1(21,2),BETA1(22,2),BETA1(23,2),BETA1(24,2),BETA1(25,2),
     5     BETA1(26,2)     /-1.49282953213429E-03,-8.78204709546389E-04,
     6-5.02916549572035E-04,-2.94822138512746E-04,-1.75463996970783E-04,
     7-1.04008550460816E-04,-5.96141953046458E-05,-3.12038929076098E-05,
     8-1.26089735980230E-05,-2.42892608575730E-07, 8.05996165414274E-06,
     9 1.36507009262147E-05, 1.73964125472926E-05, 1.98672978842134E-05,
     1 2.14463263790823E-05, 2.23954659232457E-05, 2.28967783814713E-05,
     2 2.30785389811178E-05, 2.30321976080909E-05, 2.28236073720349E-05,
     3 2.25005881105292E-05, 2.20981015361991E-05, 2.16418427448104E-05,
     4 2.11507649256221E-05, 2.06388749782171E-05, 2.01165241997082E-05/
      DATA BETA2(1,1), BETA2(2,1), BETA2(3,1), BETA2(4,1), BETA2(5,1),
     1     BETA2(6,1), BETA2(7,1), BETA2(8,1), BETA2(9,1), BETA2(10,1),
     2     BETA2(11,1),BETA2(12,1),BETA2(13,1),BETA2(14,1),BETA2(15,1),
     3     BETA2(16,1),BETA2(17,1),BETA2(18,1),BETA2(19,1),BETA2(20,1),
     4     BETA2(21,1),BETA2(22,1),BETA2(23,1),BETA2(24,1),BETA2(25,1),
     5     BETA2(26,1)     / 5.52213076721293E-04, 4.47932581552385E-04,
     6 2.79520653992021E-04, 1.52468156198447E-04, 6.93271105657044E-05,
     7 1.76258683069991E-05,-1.35744996343269E-05,-3.17972413350427E-05,
     8-4.18861861696693E-05,-4.69004889379141E-05,-4.87665447413787E-05,
     9-4.87010031186735E-05,-4.74755620890087E-05,-4.55813058138628E-05,
     1-4.33309644511266E-05,-4.09230193157750E-05,-3.84822638603221E-05,
     2-3.60857167535411E-05,-3.37793306123367E-05,-3.15888560772110E-05,
     3-2.95269561750807E-05,-2.75978914828336E-05,-2.58006174666884E-05,
     4-2.41308356761280E-05,-2.25823509518346E-05,-2.11479656768913E-05/
      DATA BETA2(1,2), BETA2(2,2), BETA2(3,2), BETA2(4,2), BETA2(5,2),
     1     BETA2(6,2), BETA2(7,2), BETA2(8,2), BETA2(9,2), BETA2(10,2),
     2     BETA2(11,2),BETA2(12,2),BETA2(13,2),BETA2(14,2),BETA2(15,2),
     3     BETA2(16,2),BETA2(17,2),BETA2(18,2),BETA2(19,2),BETA2(20,2),
     4     BETA2(21,2),BETA2(22,2),BETA2(23,2),BETA2(24,2),BETA2(25,2),
     5     BETA2(26,2)     /-4.74617796559960E-04,-4.77864567147321E-04,
     6-3.20390228067038E-04,-1.61105016119962E-04,-4.25778101285435E-05,
     7 3.44571294294968E-05, 7.97092684075675E-05, 1.03138236708272E-04,
     8 1.12466775262204E-04, 1.13103642108481E-04, 1.08651634848774E-04,
     9 1.01437951597662E-04, 9.29298396593364E-05, 8.40293133016090E-05,
     1 7.52727991349134E-05, 6.69632521975731E-05, 5.92564547323195E-05,
     2 5.22169308826976E-05, 4.58539485165361E-05, 4.01445513891487E-05,
     3 3.50481730031328E-05, 3.05157995034347E-05, 2.64956119950516E-05,
     4 2.29363633690998E-05, 1.97893056664022E-05, 1.70091984636413E-05/
      DATA BETA3(1,1), BETA3(2,1), BETA3(3,1), BETA3(4,1), BETA3(5,1),
     1     BETA3(6,1), BETA3(7,1), BETA3(8,1), BETA3(9,1), BETA3(10,1),
     2     BETA3(11,1),BETA3(12,1),BETA3(13,1),BETA3(14,1),BETA3(15,1),
     3     BETA3(16,1),BETA3(17,1),BETA3(18,1),BETA3(19,1),BETA3(20,1),
     4     BETA3(21,1),BETA3(22,1),BETA3(23,1),BETA3(24,1),BETA3(25,1),
     5     BETA3(26,1)     / 7.36465810572578E-04, 8.72790805146194E-04,
     6 6.22614862573135E-04, 2.85998154194304E-04, 3.84737672879366E-06,
     7-1.87906003636972E-04,-2.97603646594555E-04,-3.45998126832656E-04,
     8-3.53382470916038E-04,-3.35715635775049E-04,-3.04321124789040E-04,
     9-2.66722723047613E-04,-2.27654214122820E-04,-1.89922611854562E-04,
     1-1.55058918599094E-04,-1.23778240761874E-04,-9.62926147717644E-05,
     2-7.25178327714425E-05,-5.22070028895634E-05,-3.50347750511901E-05,
     3-2.06489761035552E-05,-8.70106096849767E-06, 1.13698686675100E-06,
     4 9.16426474122779E-06, 1.56477785428873E-05, 2.08223629482467E-05/
      DATA GAMA(1),   GAMA(2),   GAMA(3),   GAMA(4),   GAMA(5),
     1     GAMA(6),   GAMA(7),   GAMA(8),   GAMA(9),   GAMA(10),
     2     GAMA(11),  GAMA(12),  GAMA(13),  GAMA(14),  GAMA(15),
     3     GAMA(16),  GAMA(17),  GAMA(18),  GAMA(19),  GAMA(20),
     4     GAMA(21),  GAMA(22),  GAMA(23),  GAMA(24),  GAMA(25),
     5     GAMA(26)        / 6.29960524947437E-01, 2.51984209978975E-01,
     6 1.54790300415656E-01, 1.10713062416159E-01, 8.57309395527395E-02,
     7 6.97161316958684E-02, 5.86085671893714E-02, 5.04698873536311E-02,
     8 4.42600580689155E-02, 3.93720661543510E-02, 3.54283195924455E-02,
     9 3.21818857502098E-02, 2.94646240791158E-02, 2.71581677112934E-02,
     1 2.51768272973862E-02, 2.34570755306079E-02, 2.19508390134907E-02,
     2 2.06210828235646E-02, 1.94388240897881E-02, 1.83810633800683E-02,
     3 1.74293213231963E-02, 1.65685837786612E-02, 1.57865285987918E-02,
     4 1.50729501494096E-02, 1.44193250839955E-02, 1.38184805735342E-02/
C***FIRST EXECUTABLE STATEMENT  ASYJY
      TA = R1MACH(3)
      TOL = MAX(TA,1.0E-15)
      TB = R1MACH(5)
      JU = I1MACH(12)
      IF(FLGJY.EQ.1.0E0) GO TO 6
      JR = I1MACH(11)
      ELIM = -2.303E0*TB*(JU+JR)
      GO TO 7
    6 CONTINUE
      ELIM = -2.303E0*(TB*JU+3.0E0)
    7 CONTINUE
      FN = FNU
      IFLW = 0
      DO 170 JN=1,IN
        XX = X/FN
        WK(1) = 1.0E0 - XX*XX
        ABW2 = ABS(WK(1))
        WK(2) = SQRT(ABW2)
        WK(7) = FN**CON2
        IF (ABW2.GT.0.27750E0) GO TO 80
C
C     ASYMPTOTIC EXPANSION
C     CASES NEAR X=FN, ABS(1.-(X/FN)**2).LE.0.2775
C     COEFFICIENTS OF ASYMPTOTIC EXPANSION BY SERIES
C
C     ZETA AND TRUNCATION FOR A(ZETA) AND B(ZETA) SERIES
C
C     KMAX IS TRUNCATION INDEX FOR A(ZETA) AND B(ZETA) SERIES=MAX(2,SA)
C
        SA = 0.0E0
        IF (ABW2.EQ.0.0E0) GO TO 10
        SA = TOLS/LOG(ABW2)
   10   SB = SA
        DO 20 I=1,5
          AKM = MAX(SA,2.0E0)
          KMAX(I) = INT(AKM)
          SA = SA + SB
   20   CONTINUE
        KB = KMAX(5)
        KLAST = KB - 1
        SA = GAMA(KB)
        DO 30 K=1,KLAST
          KB = KB - 1
          SA = SA*WK(1) + GAMA(KB)
   30   CONTINUE
        Z = WK(1)*SA
        AZ = ABS(Z)
        RTZ = SQRT(AZ)
        WK(3) = CON1*AZ*RTZ
        WK(4) = WK(3)*FN
        WK(5) = RTZ*WK(7)
        WK(6) = -WK(5)*WK(5)
        IF(Z.LE.0.0E0) GO TO 35
        IF(WK(4).GT.ELIM) GO TO 75
        WK(6) = -WK(6)
   35   CONTINUE
        PHI = SQRT(SQRT(SA+SA+SA+SA))
C
C     B(ZETA) FOR S=0
C
        KB = KMAX(5)
        KLAST = KB - 1
        SB = BETA(KB,1)
        DO 40 K=1,KLAST
          KB = KB - 1
          SB = SB*WK(1) + BETA(KB,1)
   40   CONTINUE
        KSP1 = 1
        FN2 = FN*FN
        RFN2 = 1.0E0/FN2
        RDEN = 1.0E0
        ASUM = 1.0E0
        RELB = TOL*ABS(SB)
        BSUM = SB
        DO 60 KS=1,4
          KSP1 = KSP1 + 1
          RDEN = RDEN*RFN2
C
C     A(ZETA) AND B(ZETA) FOR S=1,2,3,4
C
          KSTEMP = 5 - KS
          KB = KMAX(KSTEMP)
          KLAST = KB - 1
          SA = ALFA(KB,KS)
          SB = BETA(KB,KSP1)
          DO 50 K=1,KLAST
            KB = KB - 1
            SA = SA*WK(1) + ALFA(KB,KS)
            SB = SB*WK(1) + BETA(KB,KSP1)
   50     CONTINUE
          TA = SA*RDEN
          TB = SB*RDEN
          ASUM = ASUM + TA
          BSUM = BSUM + TB
          IF (ABS(TA).LE.TOL .AND. ABS(TB).LE.RELB) GO TO 70
   60   CONTINUE
   70   CONTINUE
        BSUM = BSUM/(FN*WK(7))
        GO TO 160
C
   75   CONTINUE
        IFLW = 1
        RETURN
C
   80   CONTINUE
        UPOL(1) = 1.0E0
        TAU = 1.0E0/WK(2)
        T2 = 1.0E0/WK(1)
        IF (WK(1).GE.0.0E0) GO TO 90
C
C     CASES FOR (X/FN).GT.SQRT(1.2775)
C
        WK(3) = ABS(WK(2)-ATAN(WK(2)))
        WK(4) = WK(3)*FN
        RCZ = -CON1/WK(4)
        Z32 = 1.5E0*WK(3)
        RTZ = Z32**CON2
        WK(5) = RTZ*WK(7)
        WK(6) = -WK(5)*WK(5)
        GO TO 100
   90   CONTINUE
C
C     CASES FOR (X/FN).LT.SQRT(0.7225)
C
        WK(3) = ABS(LOG((1.0E0+WK(2))/XX)-WK(2))
        WK(4) = WK(3)*FN
        RCZ = CON1/WK(4)
        IF(WK(4).GT.ELIM) GO TO 75
        Z32 = 1.5E0*WK(3)
        RTZ = Z32**CON2
        WK(7) = FN**CON2
        WK(5) = RTZ*WK(7)
        WK(6) = WK(5)*WK(5)
  100   CONTINUE
        PHI = SQRT((RTZ+RTZ)*TAU)
        TB = 1.0E0
        ASUM = 1.0E0
        TFN = TAU/FN
        RDEN=1.0E0/FN
        RFN2=RDEN*RDEN
        RDEN=1.0E0
        UPOL(2) = (C(1)*T2+C(2))*TFN
        CRZ32 = CON548*RCZ
        BSUM = UPOL(2) + CRZ32
        RELB = TOL*ABS(BSUM)
        AP = TFN
        KS = 0
        KP1 = 2
        RZDEN = RCZ
        L = 2
        ISETA=0
        ISETB=0
        DO 140 LR=2,8,2
C
C     COMPUTE TWO U POLYNOMIALS FOR NEXT A(ZETA) AND B(ZETA)
C
          LRP1 = LR + 1
          DO 120 K=LR,LRP1
            KS = KS + 1
            KP1 = KP1 + 1
            L = L + 1
            S1 = C(L)
            DO 110 J=2,KP1
              L = L + 1
              S1 = S1*T2 + C(L)
  110       CONTINUE
            AP = AP*TFN
            UPOL(KP1) = AP*S1
            CR(KS) = BR(KS)*RZDEN
            RZDEN = RZDEN*RCZ
            DR(KS) = AR(KS)*RZDEN
  120     CONTINUE
          SUMA = UPOL(LRP1)
          SUMB = UPOL(LR+2) + UPOL(LRP1)*CRZ32
          JU = LRP1
          DO 130 JR=1,LR
            JU = JU - 1
            SUMA = SUMA + CR(JR)*UPOL(JU)
            SUMB = SUMB + DR(JR)*UPOL(JU)
  130     CONTINUE
          RDEN=RDEN*RFN2
          TB = -TB
          IF (WK(1).GT.0.0E0) TB = ABS(TB)
          IF (RDEN.LT.TOL) GO TO 131
          ASUM = ASUM + SUMA*TB
          BSUM = BSUM + SUMB*TB
          GO TO 140
  131     IF(ISETA.EQ.1) GO TO 132
          IF(ABS(SUMA).LT.TOL) ISETA=1
          ASUM=ASUM+SUMA*TB
  132     IF(ISETB.EQ.1) GO TO 133
          IF(ABS(SUMB).LT.RELB) ISETB=1
          BSUM=BSUM+SUMB*TB
  133     IF(ISETA.EQ.1 .AND. ISETB.EQ.1) GO TO 150
  140   CONTINUE
  150   TB = WK(5)
        IF (WK(1).GT.0.0E0) TB = -TB
        BSUM = BSUM/TB
C
  160   CONTINUE
        CALL FUNJY(WK(6), WK(5), WK(4), FI, DFI)
        TA=1.0E0/TOL
        TB=R1MACH(1)*TA*1.0E+3
        IF(ABS(FI).GT.TB) GO TO 165
        FI=FI*TA
        DFI=DFI*TA
        PHI=PHI*TOL
  165   CONTINUE
        Y(JN) = FLGJY*PHI*(FI*ASUM+DFI*BSUM)/WK(7)
        FN = FN - FLGJY
  170 CONTINUE
      RETURN
      END
      DOUBLE PRECISION FUNCTION ATNINT(XVALUE)
C
C DESCRIPTION:
C   
C   The function ATNINT calculates the value of the
C   inverse-tangent integral defined by
C
C       ATNINT(x) = integral 0 to x ( (arctan t)/t ) dt
C
C   The approximation uses Chebyshev series with the coefficients
C   given to an accuracy of 20D.
C
C
C ERROR RETURNS:
C
C   There are no error returns from this program.
C
C
C MACHINE-DEPENDENT CONSTANTS:
C
C   NTERMS - INTEGER - The no. of terms of the array ATNINTT.
C                      The recommended value is such that
C                          ATNINA(NTERMS) < EPS/100   
C
C   XLOW - DOUBLE PRECISION - A bound below which ATNINT(x) = x to machine
C                 precision. The recommended value is
C                     sqrt(EPSNEG/2).
C 
C   XUPPER - DOUBLE PRECISION - A bound on x, above which, to machine precision 
C                   ATNINT(x) = (pi/2)ln x
C                   The recommended value is 1/EPS.
C
C     For values of EPSNEG and EPS for various machine/compiler
C     combinations refer to the text file MACHCON.TXT
C
C     The machine-dependent constants are computed internally by
C     using the D1MACH subroutine.
C
C
C INTRINSIC FUNCTIONS USED:
C
C    ABS , LOG
C
C
C   OTHER MISCFUN SUBROUTINES USED:
C
C          CHEVAL ,  D1MACH
C
C
C AUTHOR: Dr. Allan J. MacLeod,
C         Dept. of Mathematics and Statistics,
C         University of Paisley,
C         High St.,
C         PAISLEY
C         SCOTLAND
C
C         (e-mail  macl_ms0@paisley.ac.uk )
C
C
C LATEST MODIFICATION:  23 January, 1996
C
C
C
      INTEGER IND,NTERMS
      DOUBLE PRECISION ATNINA(0:22),CHEVAL,HALF,ONE,ONEHUN,T,TWOBPI,
     &     X,XLOW,XUPPER,XVALUE,ZERO
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DATA ZERO,HALF,ONE/0.0 D 0 , 0.5 D 0 , 1.0 D 0/
      DATA ONEHUN/100.0 D 0/
      DATA TWOBPI/0.63661 97723 67581 34308 D 0/
      DATA ATNINA(0)/  1.91040 36129 62359 37512  D    0/
      DATA ATNINA(1)/ -0.41763 51437 65674 6940   D   -1/
      DATA ATNINA(2)/  0.27539 25507 86367 434    D   -2/
      DATA ATNINA(3)/ -0.25051 80952 62488 81     D   -3/
      DATA ATNINA(4)/  0.26669 81285 12117 1      D   -4/
      DATA ATNINA(5)/ -0.31189 05141 07001        D   -5/
      DATA ATNINA(6)/  0.38833 85313 2249         D   -6/
      DATA ATNINA(7)/ -0.50572 74584 964          D   -7/
      DATA ATNINA(8)/  0.68122 52829 49           D   -8/
      DATA ATNINA(9)/ -0.94212 56165 4            D   -9/
      DATA ATNINA(10)/ 0.13307 87881 6            D   -9/
      DATA ATNINA(11)/-0.19126 78075              D  -10/
      DATA ATNINA(12)/ 0.27891 2620               D  -11/
      DATA ATNINA(13)/-0.41174 820                D  -12/
      DATA ATNINA(14)/ 0.61429 87                 D  -13/
      DATA ATNINA(15)/-0.92492 9                  D  -14/
      DATA ATNINA(16)/ 0.14038 7                  D  -14/
      DATA ATNINA(17)/-0.21460                    D  -15/
      DATA ATNINA(18)/ 0.3301                     D  -16/
      DATA ATNINA(19)/-0.511                      D  -17/
      DATA ATNINA(20)/ 0.79                       D  -18/
      DATA ATNINA(21)/-0.12                       D  -18/
      DATA ATNINA(22)/ 0.2                        D  -19/
C
C   Compute the machine-dependent constants.
C
      T = D1MACH(4) / ONEHUN
      DO 10 NTERMS = 22 , 0 , -1
         IF ( ABS(ATNINA(NTERMS)) .GT. T ) GOTO 19
 10   CONTINUE
 19   T = D1MACH(3)
      XLOW = SQRT( T / ( ONE + ONE ) )
      XUPPER = ONE / T
C
C   Start calculation
C
      IND = 1
      X = XVALUE
      IF ( X .LT. ZERO ) THEN
         X = -X
         IND = -1
      ENDIF
C
C   Code for X < =  1.0
C
      IF ( X .LE. ONE ) THEN
         IF ( X .LT. XLOW ) THEN
            ATNINT = X
         ELSE
            T = X * X
            T =  ( T - HALF ) + ( T - HALF ) 
            ATNINT = X * CHEVAL( NTERMS , ATNINA , T ) 
         ENDIF
      ELSE
C
C   Code for X > 1.0
C
         IF ( X .GT. XUPPER ) THEN
            ATNINT = LOG( X ) / TWOBPI
         ELSE
            T = ONE / ( X * X ) 
            T =  ( T - HALF ) + ( T - HALF ) 
            ATNINT = LOG( X ) / TWOBPI + CHEVAL( NTERMS,ATNINA,T ) / X
         ENDIF
      ENDIF
      IF ( IND .LT. 0 ) ATNINT = - ATNINT
      RETURN
      END
      SUBROUTINE AUTOCR(X,N,IWRITE,XAUTCR,IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE
C              SAMPLE AUTOCORRELATION COEFFICIENT
C              OF THE DATA IN THE INPUT VECTOR X.
C              THE SAMPLE AUTOCORRELATION COEFFICIENT =  THE CORRELATION
C              BETWEEN X(I) AND X(I+1) OVER THE ENTIRE SAMPLE.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR OF
C                                (UNSORTED) OBSERVATIONS.
C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTOR X.
C     OUTPUT ARGUMENTS--XAUTCR = THE SINGLE PRECISION VALUE OF THE
C                                COMPUTED SAMPLE AUTOCORRELATION
C                                COEFFICIENT.
C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
C             SAMPLE AUTOCORRELATION COEFFICIENT.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--DSQRT.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JENKINS AND WATTS, SPECTRAL ANALYSIS AND
C                 ITS APPLICATIONS, 1968, PAGES 5, 182,
C                 FORMULA 5.3.33
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--82/7
C     ORIGINAL VERSION--JUNE      1972.
C     UPDATED         --SEPTEMBER 1975.
C     UPDATED         --NOVEMBER  1975.
C     UPDATED         --JUNE      1979.
C     UPDATED         --AUGUST    1981.
C     UPDATED         --MAY       1982.
C     UPDATED         --JULY      1993.CHANGE DEF. TO BJ, 182, 5.3.33
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DN
      DOUBLE PRECISION DX
      DOUBLE PRECISION DX1
      DOUBLE PRECISION DX2
      DOUBLE PRECISION DSUM
      DOUBLE PRECISION DMEAN
      DOUBLE PRECISION DDENOM
      DOUBLE PRECISION DSUM12
C
      DIMENSION X(*)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='AUTO'
      ISUBN2='CR  '
C
      IERROR='NO'
C
      DN=0.0D0
      DMEAN=0.0D0
      DSUM12=0.0D0
      DDENOM=0.0D0
C
      IF(IBUGA3.EQ.'OFF')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF AUTOCR--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)IBUGA3
   52 FORMAT('IBUGA3 = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)N
   53 FORMAT('N = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO55I=1,N
      WRITE(ICOUT,56)I,X(I)
   56 FORMAT('I,X(I) = ',I8,E15.7)
      CALL DPWRST('XXX','BUG ')
   55 CONTINUE
   90 CONTINUE
C
C               *******************************************
C               **  COMPUTE AUTOCORRELATION COEFFICIENT  **
C               *******************************************
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      AN=N
C
      IF(N.GE.1)GOTO119
      IERROR='YES'
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,111)
  111 FORMAT('***** ERROR IN AUTOCR--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,112)
  112 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,113)
  113 FORMAT('      IN THE VARIABLE FOR WHICH')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,114)
  114 FORMAT('      THE AUTOCORRELATION COEFFICIENT IS TO BE')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,115)
  115 FORMAT('      COMPUTED, MUST BE 1 OR LARGER.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,116)
  116 FORMAT('      SUCH WAS NOT THE CASE HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,117)N
  117 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8,
     1'.')
      CALL DPWRST('XXX','BUG ')
      GOTO9000
  119 CONTINUE
C
      IF(N.EQ.1)GOTO120
      GOTO129
  120 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,121)
  121 FORMAT('***** NON-FATAL DIAGNOSTIC IN AUTOCR--',
     1'THE SECOND INPUT ARGUMENT (N) HAS THE VALUE 1')
      CALL DPWRST('XXX','BUG ')
      XAUTCR=1.0
      GOTO9000
  129 CONTINUE
C
      HOLD=X(1)
      DO135I=2,N
      IF(X(I).NE.HOLD)GOTO139
  135 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,136)HOLD
  136 FORMAT('***** NON-FATAL DIAGNOSTIC IN AUTOCR--',
     1'THE FIRST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      XAUTCR=1.0
      GOTO9000
  139 CONTINUE
C
  190 CONTINUE
C
C               ************************************************
C               **  STEP 2--                                  **
C               **  COMPUTE THE AUTOCORRELATION COEFFICIENT.  **
C               ************************************************
C
CCCCC THE FOLLOWING SECTION WAS REWRITTEN JULY 1993
      DN=N
      DSUM=0.0D0
      DO200I=1,N
      DX=X(I)
      DSUM=DSUM+DX
  200 CONTINUE
      DMEAN=DSUM/DN
C
CCCCC THE FOLLOWING SECTION WAS ADDED  JULY 1993
      DSUM=0.0D0
      DO250I=1,N
      DX=X(I)
      DSUM=DSUM+(DX-DMEAN)**2
  250 CONTINUE
      DDENOM=DSUM
C
CCCCC THE FOLLOWING SECTION WAS REWRITTEN JULY 1993
      NM1=N-1
      DSUM12=0.0D0
      DO300I=1,NM1
      IP1=I+1
      DX1=X(I)
      DX2=X(IP1)
      DSUM12=DSUM12+(DX1-DMEAN)*(DX2-DMEAN)
  300 CONTINUE
      XAUTCR=1.0
      IF(DDENOM.GT.0.0D0)XAUTCR=DSUM12/DDENOM
C
C               *******************************
C               **  STEP 3--                 **
C               **  WRITE OUT A LINE         **
C               **  OF SUMMARY INFORMATION.  **
C               *******************************
C
      IF(IFEEDB.EQ.'OFF')GOTO890
      IF(IWRITE.EQ.'OFF')GOTO890
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,811)N,XAUTCR
  811 FORMAT('THE LAG-ONE AUTOCORRELATION COEFFICIENT OF THE ',
     1I8,' OBSERVATIONS = ',E15.7)
      CALL DPWRST('XXX','BUG ')
  890 CONTINUE
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'OFF')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF AUTOCR--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IBUGA3,IERROR
 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)N
 9013 FORMAT('N = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9014)DN,DMEAN,DDENOM,DSUM12
 9014 FORMAT('DN,DMEAN,DDENOM,DSUM12 = ',4D15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9015)XAUTCR
 9015 FORMAT('XAUTCR = ',E15.7)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE AUTOCV(X,N,IWRITE,XAUTCV,IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE
C              SAMPLE AUTOCOVARIANCE COEFFICIENT
C              OF THE DATA IN THE INPUT VECTOR X.
C              THE SAMPLE AUTOCOVARIANCE COEFFICIENT =  THE COVARIANCE
C              BETWEEN X(I) AND X(I+1) OVER THE ENTIRE SAMPLE.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR OF
C                                (UNSORTED) OBSERVATIONS.
C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTOR X.
C     OUTPUT ARGUMENTS--XAUTCV = THE SINGLE PRECISION VALUE OF THE
C                                COMPUTED SAMPLE AUTOCOVARIANCE
C                                COEFFICIENT.
C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
C             SAMPLE AUTOCOVARIANCE COEFFICIENT.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JENKINS AND WATTS, SPECTRAL ANALYSIS AND
C                 ITS APPLICATIONS, 1968, PAGES 5, 180,
C                 FORMULA 5.3.25.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--82/7
C     ORIGINAL VERSION--JUNE      1972.
C     UPDATED         --SEPTEMBER 1975.
C     UPDATED         --NOVEMBER  1975.
C     UPDATED         --JUNE      1979.
C     UPDATED         --AUGUST    1981.
C     UPDATED         --MAY       1982.
C     UPDATED         --JULY      1993.CHANGE DEF. TO BJ, 180, 5.3.25
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DN
      DOUBLE PRECISION DX
      DOUBLE PRECISION DX1
      DOUBLE PRECISION DX2
      DOUBLE PRECISION DSUM
CCCCC DOUBLE PRECISION DSUM1
CCCCC DOUBLE PRECISION DSUM2
      DOUBLE PRECISION DSUM12
      DOUBLE PRECISION DMEAN
C
      DIMENSION X(*)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='AUTO'
      ISUBN2='CV  '
C
      IERROR='NO'
C
      DN=0.0D0
      DMEAN=0.0D0
      DSUM12=0.0D0
C
      IF(IBUGA3.EQ.'OFF')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF AUTOCV--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)IBUGA3
   52 FORMAT('IBUGA3 = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)N
   53 FORMAT('N = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO55I=1,N
      WRITE(ICOUT,56)I,X(I)
   56 FORMAT('I,X(I) = ',I8,E15.7)
      CALL DPWRST('XXX','BUG ')
   55 CONTINUE
   90 CONTINUE
C
C               *******************************************
C               **  COMPUTE AUTOCOVARIANCE  COEFFICIENT  **
C               *******************************************
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      AN=N
C
      IF(N.GE.1)GOTO119
      IERROR='YES'
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,111)
  111 FORMAT('***** ERROR IN AUTOCV--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,112)
  112 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,113)
  113 FORMAT('      IN THE VARIABLE FOR WHICH')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,114)
  114 FORMAT('      THE AUTOCOVARIANCE COEFFICIENT IS TO BE')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,115)
  115 FORMAT('      COMPUTED, MUST BE 1 OR LARGER.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,116)
  116 FORMAT('      SUCH WAS NOT THE CASE HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,117)N
  117 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8,
     1'.')
      CALL DPWRST('XXX','BUG ')
      GOTO9000
  119 CONTINUE
C
      IF(N.EQ.1)GOTO120
      GOTO129
  120 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,121)
  121 FORMAT('***** NON-FATAL DIAGNOSTIC IN AUTOCV--',
     1'THE SECOND INPUT ARGUMENT (N) HAS THE VALUE 1')
      CALL DPWRST('XXX','BUG ')
      XAUTCV=0.0
      GOTO9000
  129 CONTINUE
C
      HOLD=X(1)
      DO135I=2,N
      IF(X(I).NE.HOLD)GOTO139
  135 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,136)HOLD
  136 FORMAT('***** NON-FATAL DIAGNOSTIC IN AUTOCV--',
     1'THE FIRST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      XAUTCV=0.0
      GOTO9000
  139 CONTINUE
C
  190 CONTINUE
C
C               ************************************************
C               **  STEP 2--                                  **
C               **  COMPUTE THE AUTOCOVARIANCE  COEFFICIENT.  **
C               ************************************************
C
CCCCC THE FOLLOWING SECTION WAS CHANGED JULY 1993
      DN=N
      DSUM=0.0D0
      DO200I=1,N
      DX=X(I)
      DSUM=DSUM+DX
  200 CONTINUE
      DMEAN=DSUM/DN
C
CCCCC THE FOLLOWING SECTION WAS CHANGED JULY 1993
      NM1=N-1
      DSUM12=0.0D0
      DO300I=1,NM1
      IP1=I+1
      DX1=X(I)
      DX2=X(IP1)
      DSUM12=DSUM12+(DX1-DMEAN)*(DX2-DMEAN)
  300 CONTINUE
      XAUTCV=DSUM12/DN
C
C               *******************************
C               **  STEP 3--                 **
C               **  WRITE OUT A LINE         **
C               **  OF SUMMARY INFORMATION.  **
C               *******************************
C
      IF(IFEEDB.EQ.'OFF')GOTO890
      IF(IWRITE.EQ.'OFF')GOTO890
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,811)N,XAUTCV
  811 FORMAT('THE LAG-ONE AUTOCOVARIANCE COEFFICIENT OF THE ',
     1I8,' OBSERVATIONS = ',E15.7)
      CALL DPWRST('XXX','BUG ')
  890 CONTINUE
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'OFF')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF AUTOCV--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IBUGA3,IERROR
 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)N
 9013 FORMAT('N = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9014)DN,DMEAN,DSUM12
 9014 FORMAT('DN,DMEAN,DSUM12 = ',3D15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9015)XAUTCV
 9015 FORMAT('XAUTCV = ',E15.7)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      REAL FUNCTION AJV(SNV, ITYPE, GAMMA, DELTA, XLAM, XI, IFAULT)
CSTART OF AS 100
C
C        ALGORITHM AS 100.1  APPL. STATIST. (1976) VOL.25, P.190
C
C        CONVERTS A STANDARD NORMAL VARIATE (SNV) TO A
C        JOHNSON VARIATE (AJV)
C
      REAL SNV, GAMMA, DELTA, XLAM, XI, V, W, ZERO, HALF, ONE,
     $  ZABS, ZEXP, ZSIGN
C
      DATA ZERO, HALF, ONE /0.0, 0.5, 1.0/
C
      ZABS(W) = ABS(W)
      ZEXP(W) = EXP(W)
      ZSIGN(W, V) = SIGN(W, V)
C
      AJV = ZERO
      IFAULT = 1
      IF (ITYPE .LT. 1 .OR. ITYPE .GT. 4) RETURN
      IFAULT = 0
      GOTO (10, 20, 30, 40), ITYPE
C
C        SL DISTRIBUTION
C
   10 AJV = XLAM * ZEXP((XLAM * SNV - GAMMA) / DELTA) + XI
      RETURN
C
C        SU DISTRIBUTION
C
   20 W = ZEXP((SNV - GAMMA) / DELTA)
      W = HALF * (W - ONE / W)
      AJV = XLAM * W + XI
      RETURN
C
C        SB DISTRIBUTION
C
   30 W = (SNV - GAMMA) / DELTA
      V = ZEXP(-ZABS(W))
      V = (ONE - V) / (ONE + V)
      AJV = HALF * XLAM * (ZSIGN(V, W) + ONE) + XI
      RETURN
C
C        NORMAL DISTRIBUTION
C
   40 AJV = (SNV - GAMMA) / DELTA
      RETURN
      END
      SUBROUTINE B2INK(X,NX,Y,NY,FCN,LDF,KX,KY,TX,TY,BCOEF,WORK,IFLAG)
C***BEGIN PROLOGUE  B2INK
C***DATE WRITTEN   25 MAY 1982
C***REVISION DATE  25 MAY 1982
C***CATEGORY NO.  E1A
C***KEYWORDS  INTERPOLATION, TWO-DIMENSIONS, GRIDDED DATA, SPLINES,
C             PIECEWISE POLYNOMIALS
C***AUTHOR  BOISVERT, RONALD, NBS
C             SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS
C             WASHINGTON, DC 20234
C***PURPOSE  B2INK DETERMINES A PIECEWISE POLYNOMIAL FUNCTION THAT
C            INTERPOLATES TWO-DIMENSIONAL GRIDDED DATA. USERS SPECIFY
C            THE POLYNOMIAL ORDER (DEGREE+1) OF THE INTERPOLANT AND
C            (OPTIONALLY) THE KNOT SEQUENCE.
C***DESCRIPTION
C
C   B2INK determines the parameters of a function that interpolates the
C   two-dimensional gridded data (X(i),Y(j),FCN(i,j)) for i=1,..,NX and
C   j=1,..,NY. The  interpolating  function  and  its  derivatives  may
C   subsequently be evaluated by the function B2VAL.
C
C   The interpolating  function  is  a  piecewise  polynomial  function
C   represented as a tensor product of one-dimensional  B-splines.  The
C   form of this function is
C
C                          NX   NY
C              S(x,y)  =  SUM  SUM  a   U (x) V (y)
C                         i=1  j=1   ij  i     j
C
C   where the functions U(i)  and  V(j)  are  one-dimensional  B-spline
C   basis functions. The coefficients a(i,j) are chosen so that
C
C         S(X(i),Y(j)) = FCN(i,j)   for i=1,..,NX and j=1,..,NY
C
C   Note that  for  each  fixed  value  of  y  S(x,y)  is  a  piecewise
C   polynomial function of x alone, and for each fixed value of x  S(x,
C   y) is a piecewise polynomial function of y alone. In one  dimension
C   a piecewise polynomial may  be  created  by  partitioning  a  given
C   interval into subintervals and defining a distinct polynomial piece
C   on each one. The points where adjacent subintervals meet are called
C   knots. Each of the functions U(i) and V(j)  above  is  a  piecewise
C   polynomial.
C
C   Users of B2INK choose the order (degree+1) of the polynomial pieces
C   used to define the piecewise polynomial in each  of  the  x  and  y
C   directions (KX and KY).  Users  also  may  define  their  own  knot
C   sequence in x and y separately (TX and TY).  If  IFLAG=0,  however,
C   B2INK will choose sequences of knots that  result  in  a  piecewise
C   polynomial interpolant with KX-2 continuous partial derivatives  in
C   x and KY-2 continuous partial derivatives in y. (KX knots are taken
C   near each endpoint, not-a-knot end conditions  are  used,  and  the
C   remaining knots are placed at data points  if  KX  is  even  or  at
C   midpoints between data points if KX is  odd.  The  y  direction  is
C   treated similarly.)
C
C   After a call to B2INK, all  information  necessary  to  define  the
C   interpolating function are contained in the parameters NX, NY,  KX,
C   KY, TX, TY, and BCOEF. These quantities should not be altered until
C   after the last call of the evaluation routine B2VAL.
C
C
C   I N P U T
C   ---------
C
C   X       Real 1D array (size NX)
C           Array of x abcissae. Must be strictly increasing.
C
C   NX      Integer scalar (.GE. 3)
C           Number of x abcissae.
C
C   Y       Real 1D array (size NY)
C           Array of y abcissae. Must be strictly increasing.
C
C   NY      Integer scalar (.GE. 3)
C           Number of y abcissae.
C
C   FCN     Real 2D array (size LDF by NY)
C           Array of function values to interpolate. FCN(I,J) should
C           contain the function value at the point (X(I),Y(J))
C
C   LDF     Integer scalar (.GE. NX)
C           The actual leading dimension of FCN used in the calling
C           calling program.
C
C   KX      Integer scalar (.GE. 2, .LT. NX)
C           The order of spline pieces in x.
C           (Order = polynomial degree + 1)
C
C   KY      Integer scalar (.GE. 2, .LT. NY)
C           The order of spline pieces in y.
C           (Order = polynomial degree + 1)
C
C
C   I N P U T   O R   O U T P U T
C   -----------------------------
C
C   TX      Real 1D array (size NX+KX)
C           The knots in the x direction for the spline interpolant.
C           If IFLAG=0 these are chosen by B2INK.
C           If IFLAG=1 these are specified by the user.
C                      (Must be non-decreasing.)
C
C   TY      Real 1D array (size NY+KY)
C           The knots in the y direction for the spline interpolant.
C           If IFLAG=0 these are chosen by B2INK.
C           If IFLAG=1 these are specified by the user.
C                      (Must be non-decreasing.)
C
C
C   O U T P U T
C   -----------
C
C   BCOEF   Real 2D array (size NX by NY)
C           Array of coefficients of the B-spline interpolant.
C           This may be the same array as FCN.
C
C
C   M I S C E L L A N E O U S
C   -------------------------
C
C   WORK    Real 1D array (size NX*NY + max( 2*KX*(NX+1),
C                                  2*KY*(NY+1) ))
C           Array of working storage.
C
C   IFLAG   Integer scalar.
C           On input:  0 == knot sequence chosen by B2INK
C                      1 == knot sequence chosen by user.
C           On output: 1 == successful execution
C                      2 == IFLAG out of range
C                      3 == NX out of range
C                      4 == KX out of range
C                      5 == X not strictly increasing
C                      6 == TX not non-decreasing
C                      7 == NY out of range
C                      8 == KY out of range
C                      9 == Y not strictly increasing
C                     10 == TY not non-decreasing
C
C***REFERENCES  CARL DE BOOR, A PRACTICAL GUIDE TO SPLINES,
C                 SPRINGER-VERLAG, NEW YORK, 1978.
C               CARL DE BOOR, EFFICIENT COMPUTER MANIPULATION OF TENSOR
C                 PRODUCTS, ACM TRANSACTIONS ON MATHEMATICAL SOFTWARE,
C                 VOL. 5 (1979), PP. 173-182.
C***ROUTINES CALLED  BTPCF,BKNOT
C***END PROLOGUE  B2INK
C
C  ------------
C  DECLARATIONS
C  ------------
C
C  PARAMETERS
C
      INTEGER
     *        NX, NY, LDF, KX, KY, IFLAG
      REAL
     *     X(NX), Y(NY), FCN(LDF,NY), TX(*), TY(*), BCOEF(NX,NY),
     *     WORK(*)
C
C  LOCAL VARIABLES
C
      INTEGER
     *        I, IW, NPK
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C
C  -----------------------
C  CHECK VALIDITY OF INPUT
C  -----------------------
C
C***FIRST EXECUTABLE STATEMENT
      IF ((IFLAG .LT. 0) .OR. (IFLAG .GT. 1))  GO TO 920
      IF (NX .LT. 3)  GO TO 930
      IF (NY .LT. 3)  GO TO 970
      IF ((KX .LT. 2) .OR. (KX .GE. NX))  GO TO 940
      IF ((KY .LT. 2) .OR. (KY .GE. NY))  GO TO 980
      DO 10 I=2,NX
         IF (X(I) .LE. X(I-1))  GO TO 950
   10 CONTINUE
      DO 20 I=2,NY
         IF (Y(I) .LE. Y(I-1))  GO TO 990
   20 CONTINUE
      IF (IFLAG .EQ. 0)  GO TO 50
         NPK = NX + KX
         DO 30 I=2,NPK
            IF (TX(I) .LT. TX(I-1))  GO TO 960
   30    CONTINUE
         NPK = NY + KY
         DO 40 I=2,NPK
            IF (TY(I) .LT. TY(I-1))  GO TO 1000
   40    CONTINUE
   50 CONTINUE
C
C  ------------
C  CHOOSE KNOTS
C  ------------
C
      IF (IFLAG .NE. 0)  GO TO 100
         CALL BKNOT(X,NX,KX,TX)
         CALL BKNOT(Y,NY,KY,TY)
  100 CONTINUE
C
C  -------------------------------
C  CONSTRUCT B-SPLINE COEFFICIENTS
C  -------------------------------
C
      IFLAG = 1
      IW = NX*NY + 1
      CALL BTPCF(X,NX,FCN,LDF,NY,TX,KX,WORK,WORK(IW))
      CALL BTPCF(Y,NY,WORK,NY,NX,TY,KY,BCOEF,WORK(IW))
      GO TO 9999
C
C  -----
C  EXITS
C  -----
C
  920 CONTINUE
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,921)IFLAG
      CALL DPWRST('XXX','BUG ')
  921 FORMAT('***** FROM B2INK -   IFLAG = ',I2,' IS OUT OF RANGE. **')
CCCCC*            35,2,1,1,IFLAG,I2,0,R1,R2)
      IFLAG = 2
      GO TO 9999
C
  930 CONTINUE
      IFLAG = 3
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,931)NX
      CALL DPWRST('XXX','BUG ')
  931 FORMAT('***** FROM B2INK -  NX = ',I4,' IS OUT OF RANGE. *****')
      GO TO 9999
C
  940 CONTINUE
      IFLAG = 4
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,941)KX
      CALL DPWRST('XXX','BUG ')
  941 FORMAT('***** FROM B2INK - KX = ',I4,' IS OUT OF RANGE. *****')
      GO TO 9999
C
  950 CONTINUE
      IFLAG = 5
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,951)
      CALL DPWRST('XXX','BUG ')
  951 FORMAT('***** FROM B2INK - X ARRAY MUST BE STRICTLY INCREASING.')
      GO TO 9999
C
  960 CONTINUE
      IFLAG = 6
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,961)
      CALL DPWRST('XXX','BUG ')
  961 FORMAT('***** FROM B2INK -   TX ARRAY MUST BE NON-DECREASING.')
      GO TO 9999
C
  970 CONTINUE
      IFLAG = 7
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,971)NY
      CALL DPWRST('XXX','BUG ')
  971 FORMAT('***** FROM B2INK - NY = ',I4,' IS OUT OF RANGE. ****')
      GO TO 9999
C
  980 CONTINUE
      IFLAG = 8
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,981)KY
      CALL DPWRST('XXX','BUG ')
  981 FORMAT('***** FROM B2INK - KY = ',I4,' IS OUT OF RANGE. *****')
      GO TO 9999
C
  990 CONTINUE
      IFLAG = 9
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,991)
      CALL DPWRST('XXX','BUG ')
  991 FORMAT('***** FROM B2INK - Y ARRAY MUST BE STRICTLY INCREASING.')
      GO TO 9999
C
 1000 CONTINUE
      IFLAG = 10
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1001)
      CALL DPWRST('XXX','BUG ')
 1001 FORMAT('***** FROM B2INK - TY ARRAY MUST BE NON-DECREASING. ***')
      GO TO 9999
C
 9999 CONTINUE
      RETURN
      END
      REAL FUNCTION B2VAL(XVAL,YVAL,IDX,IDY,TX,TY,NX,NY,
     *  KX,KY,BCOEF,WORK)
C***BEGIN PROLOGUE  B2VAL
C***DATE WRITTEN   25 MAY 1982
C***REVISION DATE  25 MAY 1982
C***CATEGORY NO.  E1A
C***KEYWORDS  INTERPOLATION, TWO-DIMENSIONS, GRIDDED DATA, SPLINES,
C             PIECEWISE POLYNOMIALS
C***AUTHOR  BOISVERT, RONALD, NBS
C             SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS
C             WASHINGTON, DC 20234
C***PURPOSE  B2VAL EVALUATES THE PIECEWISE POLYNOMIAL INTERPOLATING
C            FUNCTION CONSTRUCTED BY THE ROUTINE B2INK OR ONE OF ITS
C            PARTIAL DERIVATIVES.
C***DESCRIPTION
C
C   B2VAL evaluates the tensor product piecewise polynomial interpolant
C   constructed by the routine B2INK or one of its derivatives  at  the
C   point (XVAL,YVAL). To evaluate the interpolant itself, set IDX=IDY=
C   0, to evaluate the first partial with respect to x, set  IDX=1,IDY=
C   0, and so on.
C
C   B2VAL returns 0.0E0 if (XVAL,YVAL) is out of range. That is, if
C            XVAL.LT.TX(1) .OR. XVAL.GT.TX(NX+KX) .OR.
C            YVAL.LT.TY(1) .OR. YVAL.GT.TY(NY+NY)
C   If the knots  TX  and  TY  were  chosen  by  B2INK,  then  this  is
C   equivalent to
C            XVAL.LT.X(1) .OR. XVAL.GT.X(NX)+EPSX .OR.
C            YVAL.LT.Y(1) .OR. YVAL.GT.Y(NY)+EPSY
C   where EPSX = 0.1*(X(NX)-X(NX-1)) and EPSY = 0.1*(Y(NY)-Y(NY-1)).
C
C   The input quantities TX, TY, NX, NY, KX, KY, and  BCOEF  should  be
C   unchanged since the last call of B2INK.
C
C
C   I N P U T
C   ---------
C
C   XVAL    Real scalar
C           X coordinate of evaluation point.
C
C   YVAL    Real scalar
C           Y coordinate of evaluation point.
C
C   IDX     Integer scalar
C           X derivative of piecewise polynomial to evaluate.
C
C   IDY     Integer scalar
C           Y derivative of piecewise polynomial to evaluate.
C
C   TX      Real 1D array (size NX+KX)
C           Sequence of knots defining the piecewise polynomial in
C           the x direction.  (Same as in last call to B2INK.)
C
C   TY      Real 1D array (size NY+KY)
C           Sequence of knots defining the piecewise polynomial in
C           the y direction.  (Same as in last call to B2INK.)
C
C   NX      Integer scalar
C           The number of interpolation points in x.
C           (Same as in last call to B2INK.)
C
C   NY      Integer scalar
C           The number of interpolation points in y.
C           (Same as in last call to B2INK.)
C
C   KX      Integer scalar
C           Order of polynomial pieces in x.
C           (Same as in last call to B2INK.)
C
C   KY      Integer scalar
C           Order of polynomial pieces in y.
C           (Same as in last call to B2INK.)
C
C   BCOEF   Real 2D array (size NX by NY)
C           The B-spline coefficients computed by B2INK.
C
C   WORK    Real 1D array (size 3*max(KX,KY) + KY)
C           A working storage array.
C
C***REFERENCES  CARL DE BOOR, A PRACTICAL GUIDE TO SPLINES,
C                 SPRINGER-VERLAG, NEW YORK, 1978.
C***ROUTINES CALLED  INTRV,BVALU
C***END PROLOGUE  B2VAL
C
C  ------------
C  DECLARATIONS
C  ------------
C
C  PARAMETERS
C
      INTEGER
     *        IDX, IDY, NX, NY, KX, KY
      REAL
     *     XVAL, YVAL, TX(*), TY(*), BCOEF(NX,NY), WORK(*)
C
C  LOCAL VARIABLES
C
      INTEGER
     *        ILOY, INBVX, INBV, K, LEFTY, MFLAG, KCOL, IW
      REAL
     *     BVALU
C
      DATA ILOY /1/,  INBVX /1/
C     SAVE ILOY    ,  INBVX
C
C
C***FIRST EXECUTABLE STATEMENT
      B2VAL = 0.0E0
      CALL INTRV(TY,NY+KY,YVAL,ILOY,LEFTY,MFLAG)
      IF (MFLAG .NE. 0)  GO TO 100
         IW = KY + 1
         KCOL = LEFTY - KY
         DO 50 K=1,KY
            KCOL = KCOL + 1
            WORK(K) = BVALU(TX,BCOEF(1,KCOL),NX,KX,IDX,XVAL,INBVX,
     *                      WORK(IW))
   50    CONTINUE
         INBV = 1
         KCOL = LEFTY - KY + 1
         B2VAL = BVALU(TY(KCOL),WORK,KY,KY,IDY,YVAL,INBV,WORK(IW))
  100 CONTINUE
      RETURN
      END
      SUBROUTINE BACK25(X2,M,N,RIGHT2,B,IBUGA3)
C
C     PURPOSE--BACK SOLVE A TRIANGULARIZED SYSTEM
C     WHICH (IT IS ASSUMED) HAS BEEN TRIANGULARIZED
C     AND RESIDES IN THE UPPER TRIANGLE OF X2(.,.)
C     AND THE RESPONSE VECTOR HAS BEEN CARRIED ALONG
C     AND THE MODIFIED RESPONSE VECTOR NOW RESIDES IN
C     THE (N+1)ST COLUMN OF X
C     NOTE--A CALL TO BACK25 IS TYPICALLY
C           PRECEEDED BY A CALL TO TRIA25
C           WHICH WILL CARRY OUT THE
C           TRIANGULARIZATION OF THE MATRIX.
C     NOTE--THE DIMENSIONS OF X2 MUST BE THE SAME
C           IN THE CALLING ROUTINE AS IN THIS SUBROUTINE.
C           THEY HAVE BEEN SET HEREIN TO 25 BY 25,
C           AND HENCE THE 25 IN THE NAME OF THIS SUBROUTINE (BACK25).
C     NOTE--BACK25 IS IDENTICAL TO BACK50 AND BACKSO
C           EXCEPT FOR THE DIMENSIONS.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--82/7
C     ORIGINAL VERSION--FEBRUARY  1978.
C     UPDATED         --JULY      1981.
C     UPDATED         --AUGUST    1981.
C     UPDATED         --MAY       1982.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IBUGA3
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DIMENSION X2(25,25)
      DIMENSION RIGHT2(*)
      DIMENSION B(*)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='BACK'
      ISUBN2='25  '
C
      IF(IBUGA3.EQ.'OFF')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF BACK25--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)M,N,IBUGA3
   52 FORMAT('M,N,IBUGA3 = ',2I8,2X,A4)
      CALL DPWRST('XXX','BUG ')
      DO55I=1,M
      WRITE(ICOUT,56)I,(X2(I,J),J=1,N)
   56 FORMAT('I,X2(I,.)  = ',I8,10E10.3)
      CALL DPWRST('XXX','BUG ')
   55 CONTINUE
      DO60I=1,M
      WRITE(ICOUT,61)I,RIGHT2(I)
   61 FORMAT('I,RIGHT2(I)= ',I8,E10.3)
      CALL DPWRST('XXX','BUG ')
   60 CONTINUE
   90 CONTINUE
C
      I=M
  100 CONTINUE
      SUM=0.0
      IP1=I+1
      IF(IP1.GT.M)GOTO250
      DO200J=IP1,M
      SUM=SUM+B(J)*X2(I,J)
  200 CONTINUE
  250 CONTINUE
      DEL=RIGHT2(I)-SUM
      B(I)=DEL/X2(I,I)
      I=I-1
      IF(I.GE.1)GOTO100
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'OFF')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF BACK25--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)M,N,IBUGA3
 9012 FORMAT('M,N,IBUGA3 = ',2I8,2X,A4)
      CALL DPWRST('XXX','BUG ')
      DO9015I=1,M
      WRITE(ICOUT,9016)I,(X2(I,J),J=1,N)
 9016 FORMAT('I,X2(I,.)  = ',I8,10E10.3)
      CALL DPWRST('XXX','BUG ')
 9015 CONTINUE
      DO9020I=1,M
      WRITE(ICOUT,9021)I,RIGHT2(I),B(I)
 9021 FORMAT('I,RIGHT2(I),B(I) = ',I8,2E10.3)
      CALL DPWRST('XXX','BUG ')
 9020 CONTINUE
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE BACK50(X2,M,N,RIGHT2,B,IBUGA3)
C
C     PURPOSE--BACK SOLVE A TRIANGULARIZED SYSTEM
C     WHICH (IT IS ASSUMED) HAS BEEN TRIANGULARIZED
C     AND RESIDES IN THE UPPER TRIANGLE OF X2(.,.)
C     AND THE RESPONSE VECTOR HAS BEEN CARRIED ALONG
C     AND THE MODIFIED RESPONSE VECTOR NOW RESIDES IN
C     THE (N+1)ST COLUMN OF X
C     NOTE--A CALL TO BACK50 IS TYPICALLY
C           PRECEEDED BY A CALL TO TRIA50
C           WHICH WILL CARRY OUT THE
C           TRIANGULARIZATION OF THE MATRIX.
C     NOTE--THE DIMENSIONS OF X2 MUST BE THE SAME
C           IN THE CALLING ROUTINE AS IN THIS SUBROUTINE.
C           THEY HAVE BEEN SET HEREIN TO 50 BY 50,
C           AND HENCE THE 50 IN THE NAME OF THIS SUBROUTINE (BACK50).
C     NOTE--BACK50 IS IDENTICAL TO BACK25 AND BACKSO
C           EXCEPT FOR THE DIMENSIONS.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--82/7
C     ORIGINAL VERSION--FEBRUARY  1978.
C     UPDATED         --JULY      1981.
C     UPDATED         --AUGUST    1981.
C     UPDATED         --MAY       1982.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IBUGA3
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DIMENSION X2(50,50)
      DIMENSION RIGHT2(*)
      DIMENSION B(*)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='BACK'
      ISUBN2='50  '
C
      IF(IBUGA3.EQ.'OFF')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF BACK25--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)M,N,IBUGA3
   52 FORMAT('M,N,IBUGA3 = ',2I8,2X,A4)
      CALL DPWRST('XXX','BUG ')
      DO55I=1,M
      WRITE(ICOUT,56)I,(X2(I,J),J=1,N)
   56 FORMAT('I,X2(I,.)  = ',I8,10E10.3)
      CALL DPWRST('XXX','BUG ')
   55 CONTINUE
      DO60I=1,M
      WRITE(ICOUT,61)I,RIGHT2(I)
   61 FORMAT('I,RIGHT2(I)= ',I8,E10.3)
      CALL DPWRST('XXX','BUG ')
   60 CONTINUE
   90 CONTINUE
C
      I=M
  100 CONTINUE
      SUM=0.0
      IP1=I+1
      IF(IP1.GT.M)GOTO250
      DO200J=IP1,M
      SUM=SUM+B(J)*X2(I,J)
  200 CONTINUE
  250 CONTINUE
      DEL=RIGHT2(I)-SUM
      B(I)=DEL/X2(I,I)
      I=I-1
      IF(I.GE.1)GOTO100
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'OFF')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF BACK25--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)M,N,IBUGA3
 9012 FORMAT('M,N,IBUGA3 = ',2I8,2X,A4)
      CALL DPWRST('XXX','BUG ')
      DO9015I=1,M
      WRITE(ICOUT,9016)I,(X2(I,J),J=1,N)
 9016 FORMAT('I,X2(I,.)  = ',I8,10E10.3)
      CALL DPWRST('XXX','BUG ')
 9015 CONTINUE
      DO9020I=1,M
      WRITE(ICOUT,9021)I,RIGHT2(I),B(I)
 9021 FORMAT('I,RIGHT2(I),B(I) = ',I8,2E10.3)
      CALL DPWRST('XXX','BUG ')
 9020 CONTINUE
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE BACKLC(Z,AA,NN,B)
C BACKLC RECEIVES FROM ROUTINE BESLCF Z,AA, AND NN SUCH THAT BESLCR
C WANTS TO CALCULATE BESSEL FUNCTIONS J-SUB-(NN+AA)-OF-Z (AND LOWER
C ORDERS).  IT RETURNS NN AND B (=J-SUB-NN+A) WITH WHICH TO START THE 
C BACK-RECURSION.  THE METHOD IS DESCRIBED IN REFERENCES (3) AND (4)
C LISTED IN BESLCF. 
C
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      COMPLEX B,P,PLAST,POLD,PSAVE,TEMPC,Z,ZINV,ZDUMMY
C---------------------------------------------------------------------
C
C  MACHINE DEPENDENT CONSTANTS.
C  ---------------------------
C
C       EXPLANATION OF MACHINE-DEPENDENT CONSTANTS
C
C DYOUK WORKING ACCURACY OF THE COMPUTER.
C DYOUKI 1./DYOUK
C SQRDKI SQRT(DYOUKI)
C TOVER DYOUK/(SMALLEST POSITIVE MACHINE-REPRESENTABLE REAL NUMBER)
C
      SAVE ISAVE,DYOUK,DYOUKI,SQRDKI,TOVER,LOU
      DATA ISAVE /1/
C
C Definition of real and imaginary parts of complex number,
C standard Fortran and will work on Convex with -r8 -i8.
      REALP(ZDUMMY) = REAL(ZDUMMY)
      AIMAGP(ZDUMMY) = REAL((0,-1)*ZDUMMY)
C
      IF (ISAVE.GT.0) THEN
        ISAVE = 0
        DYOUK = R1MACH (4)
        DYOUKI = 1.0 / DYOUK
        SQRDKI = SQRT (DYOUKI)
        TOVER = DYOUK / R1MACH (1)
        LOU = I1MACH(2)
      ENDIF
C
C-----------------------------------------------------------------------
      A=AA
      ZINV=2./Z
      ZMAG=ABS(Z)
      MAGZ=ZMAG-A
      NB=NN
      NB1=NB+1
      N=MAGZ+1
      NSTART=N+1
      PLAST = (1.0, 0.0)
      P=ZINV*(REAL(N)+A)
      TEST=DYOUKI
      M=0 
      IF(NSTART.GT.NB) GO TO 6
C CALCULATE P*S UNTIL N=NB, AND CHECK FOR POSSIBLE OVERFLOW.
C Set C here to avoid Univac FTN compiler warning that
C arises because it does not know that NSTART cannot exceed NB.
      C = 0.0
      DO 5 N=NSTART,NB
      POLD=PLAST
      PLAST=P
      P=(REAL(N)+A)*PLAST*ZINV-POLD
      C=MAX(ABS(REALP(P)),ABS(AIMAGP(P)))
      IF(C.GT.TOVER) GO TO 7
    5 CONTINUE
      N=NB
      TEST=SQRDKI*C 
      C=1./C
      TEST=TEST*SQRT(ABS((P*C)*(PLAST*C)))
      TEST=MAX(TEST,DYOUKI)
C CALCULATE P*S UNTIL THE SIGNIFICANCE TEST ABOVE IS PASSED.
    6 N=N+1
      POLD=PLAST
      PLAST=P
      P=(REAL(N)+A)*PLAST*ZINV-POLD
      C=MAX(ABS(REALP(P)),ABS(AIMAGP(P)))
      IF(C.LT.TEST) GO TO 6
      IF(M.EQ.1) GO TO 12
C CALCULATE STRICT VARIANT OF SIGNIFICANCE TEST, AND
C CALCULATE P*S UNTIL THIS TEST IS PASSED.
      M=1 
      E=ABS(P)/ABS(PLAST)
      D=(REAL(N+1)+A)/ZMAG
      IF(E+1./E.GT.2.*D) E=D+SQRT(D*D-1.)
      E=E-1./E
      IF(E.GE.(TEST/C)**2) GO TO 12
      TEST=TEST/SQRT(E)
      GO TO 6
    7 NSTART=N+1
C TO AVOID OVERFLOW, NORMALIZE P*S BY DIVIDING BY TOVER.
C CALCULATE P*S UNTIL UNNORMALIZED P WOULD OVERFLOW.
      P=CMPLX(REALP(P)/TOVER,AIMAGP(P)/TOVER)
      PLAST=CMPLX(REALP(PLAST)/TOVER,AIMAGP(PLAST)/TOVER)
      PSAVE=P
      TEMPC=PLAST
    8 N=N+1
      POLD=PLAST
      PLAST=P
      P=(REAL(N)+A)*PLAST*ZINV-POLD
      IF(ABS(REALP(P))+ABS(AIMAGP(P)).LE.DYOUKI) GO TO 8
C CALCULATE BACKWARD TEST, AND FIND NCALC, THE HIGHEST N
C SUCH THAT THE TEST IS PASSED.
      C=(REAL(N)+A)/ZMAG
      D=ABS(PLAST/POLD)
      E=(REALP(PLAST)**2+AIMAGP(PLAST)**2)*(REALP(POLD)**2+ 
     1  AIMAGP(POLD)**2)
      IF(D+1./D.GT.2.*C) D=C+SQRT(C*C-1.)
      TEST=E*(DYOUK*(1.-D**(-2)))**2
      P=PLAST*CMPLX(TOVER,0.) 
      N=N-1
      NEND=MIN(N,NB1)
      DO 9 NCALC=NSTART,NEND
      POLD=TEMPC
      TEMPC=PSAVE
      PSAVE=(REAL(N)+A)*TEMPC*ZINV-POLD 
      POLD=PSAVE*TEMPC
      IF(REALP(POLD)**2+AIMAGP(POLD)**2.GE.TEST) GO TO 10
    9 CONTINUE
      NCALC=NEND+1
   10 IF (NCALC .LE. NB) THEN
        WRITE (ICOUT,11) Z
        CALL DPWRST('XXX','BUG')
        WRITE (ICOUT,13) A, NCALC
        CALL DPWRST('XXX','BUG')
      ENDIF
   11 FORMAT('***** WARNING FROM BACKLC--- FOR Z = ', 2(1PE22.14))
   13 FORMAT('      AND A = ',F14.12,' BJ(N) FOR N GREATER THAN ',I5,
     1       ' HAS LOW ACCURACY DUE TO UNDERFLOW')
      C=TOVER
   12 P=1./CMPLX(REALP(P)/C,AIMAGP(P)/C)
      B=   CMPLX(REALP(P)/C,AIMAGP(P)/C)
      NN=N
      RETURN
      END 
      SUBROUTINE BAKSLV(NR,N,A,X,B)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C PURPOSE
C -------
C SOLVE  AX=B  WHERE A IS UPPER TRIANGULAR MATRIX.
C NOTE THAT A IS INPUT AS A LOWER TRIANGULAR MATRIX AND
C THAT THIS ROUTINE TAKES ITS TRANSPOSE IMPLICITLY.
C
C PARAMETERS
C ----------
C NR           --> ROW DIMENSION OF MATRIX
C N            --> DIMENSION OF PROBLEM
C A(N,N)       --> LOWER TRIANGULAR MATRIX (PRESERVED)
C X(N)        <--  SOLUTION VECTOR
C B(N)         --> RIGHT-HAND SIDE VECTOR
C
C NOTE
C ----
C IF B IS NO LONGER REQUIRED BY CALLING ROUTINE,
C THEN VECTORS B AND X MAY SHARE THE SAME STORAGE.
C
      DIMENSION A(NR,1),X(N),B(N)
C
C SOLVE (L-TRANSPOSE)X=B. (BACK SOLVE)
C
      I=N
      X(I)=B(I)/A(I,I)
      IF(N.EQ.1) RETURN
   30 IP1=I
      I=I-1
      SUM=0.
      DO 40 J=IP1,N
        SUM=SUM+A(J,I)*X(J)
   40 CONTINUE
      X(I)=(B(I)-SUM)/A(I,I)
      IF(I.GT.1) GO TO 30
      RETURN
      END
      SUBROUTINE BALANC(NM,N,A,LOW,IGH,SCALE)
C***BEGIN PROLOGUE  BALANC
C***DATE WRITTEN   760101   (YYMMDD)
C***REVISION DATE  830518   (YYMMDD)
C***CATEGORY NO.  D4C1A
C***KEYWORDS  EIGENVALUES,EIGENVECTORS,EISPACK
C***AUTHOR  SMITH, B. T., ET AL.
C***PURPOSE  Balances a general real matrix and isolates eigenvalue
C            whenever possible.
C***DESCRIPTION
C
C     This subroutine is a translation of the ALGOL procedure BALANCE,
C     NUM. MATH. 13, 293-304(1969) by Parlett and Reinsch.
C     HANDBOOk FOR AUTO. COMP., Vol.II-LINEAR ALGEBRA, 315-326(1971).
C
C     This subroutine balances a REAL matrix and isolates
C     eigenvalues whenever possible.
C
C     On INPUT
C
C        NM must be set to the row dimension of two-dimensional
C          array parameters as declared in the calling program
C          dimension statement.
C
C        N is the order of the matrix.
C
C        A contains the input matrix to be balanced.
C
C     On OUTPUT
C
C        A contains the balanced matrix.
C
C        LOW and IGH are two integers such that A(I,J)
C          is equal to zero if
C           (1) I is greater than J and
C           (2) J=1,...,LOW-1 or I=IGH+1,...,N.
C
C        SCALE contains information determining the
C           permutations and scaling factors used.
C
C     Suppose that the principal submatrix in rows LOW through IGH
C     has been balanced, that P(J) denotes the index interchanged
C     with J during the permutation step, and that the elements
C     of the diagonal matrix used are denoted by D(I,J).  Then
C        SCALE(J) = P(J),    for J = 1,...,LOW-1
C                 = D(J,J),      J = LOW,...,IGH
C                 = P(J)         J = IGH+1,...,N.
C     The order in which the interchanges are made is N to IGH+1,
C     then 1 TO LOW-1.
C
C     Note that 1 is returned for IGH if IGH is zero formally.
C
C     The ALGOL procedure EXC contained in BALANCE appears in
C     BALANC  in line.  (Note that the ALGOL roles of identifiers
C     K,L have been reversed.)
C
C     Questions and comments should be directed to B. S. Garbow,
C     Applied Mathematics Division, ARGONNE NATIONAL LABORATORY
C     ------------------------------------------------------------------
C***REFERENCES  B. T. SMITH, J. M. BOYLE, J. J. DONGARRA, B. S. GARBOW,
C                 Y. IKEBE, V. C. KLEMA, C. B. MOLER, *MATRIX EIGEN-
C                 SYSTEM ROUTINES - EISPACK GUIDE*, SPRINGER-VERLAG,
C                 1976.
C***ROUTINES CALLED  (NONE)
C***END PROLOGUE  BALANC
C
      INTEGER I,J,K,L,M,N,JJ,NM,IGH,LOW,IEXC
      REAL A(NM,N),SCALE(N)
      REAL C,F,G,R,S,B2,RADIX
      LOGICAL NOCONV
C
C***FIRST EXECUTABLE STATEMENT  BALANC
      RADIX = 16
C
      B2 = RADIX * RADIX
      K = 1
      L = N
      GO TO 100
C     .......... IN-LINE PROCEDURE FOR ROW AND
C                COLUMN EXCHANGE ..........
   20 SCALE(M) = J
      IF (J .EQ. M) GO TO 50
C
      DO 30 I = 1, L
         F = A(I,J)
         A(I,J) = A(I,M)
         A(I,M) = F
   30 CONTINUE
C
      DO 40 I = K, N
         F = A(J,I)
         A(J,I) = A(M,I)
         A(M,I) = F
   40 CONTINUE
C
   50 GO TO (80,130), IEXC
C     .......... SEARCH FOR ROWS ISOLATING AN EIGENVALUE
C                AND PUSH THEM DOWN ..........
   80 IF (L .EQ. 1) GO TO 280
      L = L - 1
C     .......... FOR J=L STEP -1 UNTIL 1 DO -- ..........
  100 DO 120 JJ = 1, L
         J = L + 1 - JJ
C
         DO 110 I = 1, L
            IF (I .EQ. J) GO TO 110
            IF (A(J,I) .NE. 0.0E0) GO TO 120
  110    CONTINUE
C
         M = L
         IEXC = 1
         GO TO 20
  120 CONTINUE
C
      GO TO 140
C     .......... SEARCH FOR COLUMNS ISOLATING AN EIGENVALUE
C                AND PUSH THEM LEFT ..........
  130 K = K + 1
C
  140 DO 170 J = K, L
C
         DO 150 I = K, L
            IF (I .EQ. J) GO TO 150
            IF (A(I,J) .NE. 0.0E0) GO TO 170
  150    CONTINUE
C
         M = K
         IEXC = 2
         GO TO 20
  170 CONTINUE
C     .......... NOW BALANCE THE SUBMATRIX IN ROWS K TO L ..........
      DO 180 I = K, L
  180 SCALE(I) = 1.0E0
C     .......... ITERATIVE LOOP FOR NORM REDUCTION ..........
  190 NOCONV = .FALSE.
C
      DO 270 I = K, L
         C = 0.0E0
         R = 0.0E0
C
         DO 200 J = K, L
            IF (J .EQ. I) GO TO 200
            C = C + ABS(A(J,I))
            R = R + ABS(A(I,J))
  200    CONTINUE
C     .......... GUARD AGAINST ZERO C OR R DUE TO UNDERFLOW ..........
         IF (C .EQ. 0.0E0 .OR. R .EQ. 0.0E0) GO TO 270
         G = R / RADIX
         F = 1.0E0
         S = C + R
  210    IF (C .GE. G) GO TO 220
         F = F * RADIX
         C = C * B2
         GO TO 210
  220    G = R * RADIX
  230    IF (C .LT. G) GO TO 240
         F = F / RADIX
         C = C / B2
         GO TO 230
C     .......... NOW BALANCE ..........
  240    IF ((C + R) / F .GE. 0.95E0 * S) GO TO 270
         G = 1.0E0 / F
         SCALE(I) = SCALE(I) * F
         NOCONV = .TRUE.
C
         DO 250 J = K, N
  250    A(I,J) = A(I,J) * G
C
         DO 260 J = 1, L
  260    A(J,I) = A(J,I) * F
C
  270 CONTINUE
C
      IF (NOCONV) GO TO 190
C
  280 LOW = K
      IGH = L
      RETURN
      END
      SUBROUTINE BALBAK(NM,N,LOW,IGH,SCALE,M,Z)
C***BEGIN PROLOGUE  BALBAK
C***DATE WRITTEN   760101   (YYMMDD)
C***REVISION DATE  830518   (YYMMDD)
C***CATEGORY NO.  D4C4
C***KEYWORDS  EIGENVALUES,EIGENVECTORS,EISPACK
C***AUTHOR  SMITH, B. T., ET AL.
C***PURPOSE  Forms eigenvectors of real general matrix from
C            eigenvectors of matrix output from BALANC.
C***DESCRIPTION
C
C     This subroutine is a translation of the ALGOL procedure BALBAK,
C     NUM. MATH. 13, 293-304(1969) by Parlett and Reinsch.
C     HANDBOOK FOR AUTO. COMP., Vol.II-LINEAR ALGEBRA, 315-326(1971).
C
C     This subroutine forms the eigenvectors of a REAL GENERAL
C     matrix by back transforming those of the corresponding
C     balanced matrix determined by  BALANC.
C
C     On INPUT
C
C        NM must be set to the row dimension of two-dimensional
C          array parameters as declared in the calling program
C          dimension statement.
C
C        N is the order of the matrix.
C
C        LOW and IGH are integers determined by  BALANC.
C
C        SCALE contains information determining the permutations
C          and scaling factors used by  BALANC.
C
C        M is the number of columns of Z to be back transformed.
C
C        Z contains the real and imaginary parts of the eigen-
C          vectors to be back transformed in its first M columns.
C
C     On OUTPUT
C
C        Z contains the real and imaginary parts of the
C          transformed eigenvectors in its first M columns.
C
C     Questions and comments should be directed to B. S. Garbow,
C     Applied Mathematics Division, ARGONNE NATIONAL LABORATORY
C     ------------------------------------------------------------------
C***REFERENCES  B. T. SMITH, J. M. BOYLE, J. J. DONGARRA, B. S. GARBOW,
C                 Y. IKEBE, V. C. KLEMA, C. B. MOLER, *MATRIX EIGEN-
C                 SYSTEM ROUTINES - EISPACK GUIDE*, SPRINGER-VERLAG,
C                 1976.
C***ROUTINES CALLED  (NONE)
C***END PROLOGUE  BALBAK
C
      INTEGER I,J,K,M,N,II,NM,IGH,LOW
      REAL SCALE(N),Z(NM,M)
      REAL S
C
C***FIRST EXECUTABLE STATEMENT  BALBAK
      IF (M .EQ. 0) GO TO 200
      IF (IGH .EQ. LOW) GO TO 120
C
      DO 110 I = LOW, IGH
         S = SCALE(I)
C     .......... LEFT HAND EIGENVECTORS ARE BACK TRANSFORMED
C                IF THE FOREGOING STATEMENT IS REPLACED BY
C                S=1.0E0/SCALE(I). ..........
         DO 100 J = 1, M
  100    Z(I,J) = Z(I,J) * S
C
  110 CONTINUE
C     ......... FOR I=LOW-1 STEP -1 UNTIL 1,
C               IGH+1 STEP 1 UNTIL N DO -- ..........
  120 DO 140 II = 1, N
         I = II
         IF (I .GE. LOW .AND. I .LE. IGH) GO TO 140
         IF (I .LT. LOW) I = LOW - II
         K = SCALE(I)
         IF (K .EQ. I) GO TO 140
C
         DO 130 J = 1, M
            S = Z(I,J)
            Z(I,J) = Z(K,J)
            Z(K,J) = S
  130    CONTINUE
C
  140 CONTINUE
C
  200 RETURN
      END
      SUBROUTINE BASRUL( NDIM, A, B, WIDTH, FUNCTN, W, LENRUL, G,
     &     CENTER, Z, RGNERT, BASEST )
*
*     For application of basic integration rule
*
      EXTERNAL FUNCTN
      INTEGER I, LENRUL, NDIM
      DOUBLE PRECISION 
     &     A(NDIM), B(NDIM), WIDTH(NDIM), FUNCTN, W(LENRUL,4), 
     &     G(NDIM,LENRUL), CENTER(NDIM), Z(NDIM), RGNERT, BASEST
      DOUBLE PRECISION 
     &     FULSUM, FSYMSM, RGNCMP, RGNVAL, RGNVOL, RGNCPT, RGNERR
*
*     Compute Volume and Center of Subregion
*
      RGNVOL = 1
      DO 100 I = 1,NDIM
         RGNVOL = 2*RGNVOL*WIDTH(I)
         CENTER(I) = A(I) + WIDTH(I)
  100 CONTINUE
      BASEST = 0
      RGNERT = 0
*
*     Compute basic rule and error
*
 10   RGNVAL = 0
      RGNERR = 0
      RGNCMP = 0
      RGNCPT = 0
      DO 200 I = 1,LENRUL
         FSYMSM = FULSUM(NDIM, CENTER, WIDTH, Z, G(1,I), FUNCTN)
*     Basic Rule
         RGNVAL = RGNVAL + W(I,1)*FSYMSM
*     First comparison rule
         RGNERR = RGNERR + W(I,2)*FSYMSM
*     Second comparison rule
         RGNCMP = RGNCMP + W(I,3)*FSYMSM
*     Third Comparison rule
         RGNCPT = RGNCPT + W(I,4)*FSYMSM
  200 CONTINUE
*
*     Error estimation
*
      RGNERR = SQRT(RGNCMP**2 + RGNERR**2)
      RGNCMP = SQRT(RGNCPT**2 + RGNCMP**2)
      IF ( 4*RGNERR .LT. RGNCMP ) RGNERR = RGNERR/2
      IF ( 2*RGNERR .GT. RGNCMP ) RGNERR = MAX( RGNERR, RGNCMP )
      RGNERT = RGNERT +  RGNVOL*RGNERR
      BASEST = BASEST +  RGNVOL*RGNVAL
*
*     When subregion has more than one piece, determine next piece and
*      loop back to apply basic rule.
*
      DO 300 I = 1,NDIM
         CENTER(I) = CENTER(I) + 2*WIDTH(I)
         IF ( CENTER(I) .LT. B(I) ) GO TO 10
         CENTER(I) = A(I) + WIDTH(I)
  300 CONTINUE
C
      RETURN
      END
      SUBROUTINE BBNCDF(X,V,W,N,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE AT THE SINGLE PRECISION VALUE X
C              FOR THE BETA-BINOMIAL DISTRIBUTION
C              WITH SINGLE PRECISION PARAMETERS V AND W
C              AND INTEGER 'NUMBER OF BERNOULLI TRIALS'
C              PARAMETER = N.
C              IF V AND W ARE INTEGERS, THIS BECOMES THE NEGATIVE
C              HYPERGEOMETRIC DISTRIBUTION.
C              THIS DISTRIBUTION IS DEFINED FOR ALL
C              DISCRETE INTEGER X BETWEEN 0 (INCLUSIVELY)
C              AND N (INCLUSIVELY).
C              THIS DISTRIBUTION HAS THE PROBABILITY FUNCTION
C              F(X) = B(N-X+V,X+B)/[(N+1)*B(N-X+1,X+1)*B(V,W)
C              WHERE B(A,B) IS THE BETA FUNCTION.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE
C                                AT WHICH THE CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE INTEGRAL-VALUED,
C                                AND BETWEEN 0.0 (INCLUSIVELY)
C                                AND N (INCLUSIVELY).
C                     --V      = THE SINGLE PRECISION VALUE
C                                OF THE FIRST SHAPE PARAMETER.
C                     --W      = THE SINGLE PRECISION VALUE
C                                OF THE SECOND SHAPE PARAMETER.
C                     --N      = THE INTEGER VALUE
C                                OF THE 'NUMBER OF BERNOULLI TRIALS'
C                                PARAMETER.
C                                N SHOULD BE A POSITIVE INTEGER.
C     OUTPUT ARGUMENTS--CDF    = THE SINGLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION
C             FUNCTION VALUE CDF
C             FOR THE BINOMIAL DISTRIBUTION
C             WITH 'BERNOULLI PROBABILITY' PARAMETER = P
C             AND 'NUMBER OF BERNOULLI TRIALS' PARAMETER = N.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE INTEGRAL-VALUED,
C                   AND BETWEEN 0.0 (INCLUSIVELY)
C                   AND N (INCLUSIVELY).
C                 --P SHOULD BE BETWEEN 0.0 (EXCLUSIVELY)
C                   AND 1.0 (EXCLUSIVELY).
C                 --N SHOULD BE A POSITIVE INTEGER.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--DSQRT, DATAN.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--HASTINGS AND PEACOCK, STATISTICAL
C                 DISTRIBUTIONS--2ND ED., CHAPTER 5
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--96/2
C     ORIGINAL VERSION--FEBRUARY  1996.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX, DV, DW, DN, DCDF
      DOUBLE PRECISION DTERM1, DTERM2, DTERM3, DTERM4
      DOUBLE PRECISION DLBETA
      DOUBLE PRECISION DSUM1, DSUM2
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      CDF=0.0
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      AN=N
      IF(V.LE.0.0)THEN
        WRITE(ICOUT,11)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)V
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9999
      ENDIF
      IF(W.LE.0.0)THEN
        WRITE(ICOUT,12)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)V
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9999
      ENDIF
      IF(N.LE.0)THEN
        WRITE(ICOUT,25)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9999
      ENDIF
      INTX=X+0.0001
      FINTX=INTX
      DEL=X-FINTX
      IF(DEL.LT.0.0)DEL=-DEL
      IF(DEL.GT.0.001)THEN
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,6)INT(FINTX)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
      ENDIF
      IF(FINTX.LT.0.0 .OR. FINTX.GT.AN)THEN
        WRITE(ICOUT,4)N
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
C
    4 FORMAT('***** FATAL ERROR--THE FIRST INPUT ',
     1'ARGUMENT TO THE BBNCDF SUBROUTINE IS OUTSIDE THE USUAL ',
     1'(0,N) = (0,',I8,') INTERVAL')
    5 FORMAT('***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ',
     1'ARGUMENT TO THE BBNCDF SUBROUTINE IS NON-INTEGRAL *****')
    6 FORMAT('      IT HAS BEEN SET TO ',I8)
   11 FORMAT('***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE ',
     1' BBNCDF SUBROUTINE IS NON-POSITIVE')
   12 FORMAT('***** FATAL ERROR--THE THIRD INPUT ARGUMENT TO THE ',
     1' BBNCDF SUBROUTINE IS NON-POSITIVE')
   25 FORMAT('***** FATAL ERROR--THE FOURTH INPUT ARGUMENT TO THE ',
     1' BBNCDF SUBROUTINE IS NON-POSITIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
C
      DV=DBLE(V)
      DW=DBLE(W)
      DN=DBLE(N)
      DSUM1=0.0D0
      DSUM2=0.0D0
C
      DMEAN=DN*DV/(DV+DW)
      ICUT=INT(DMEAN)+1
C
C  SUM TERMS UP TO AND INCLUDING MEAN
C
      DO1000I=0,MIN(ICUT,INTX),1
        DX=DBLE(I)
        DTERM1=DLOG(DN+1.0D0)
        DTERM2=DLBETA(DN-DX+DV,DX+DW)
        DTERM3=DLBETA(DN-DX+1.0D0,DX+1.0D0)
        DTERM4=DLBETA(DV,DW)
        DCDF=DEXP(DTERM2-DTERM1-DTERM3-DTERM4)
        DSUM1=DSUM1+DCDF
 1000 CONTINUE
C
C  SUM TERMS FROM X DOWN TO MEAN MEAN
C
      IF(INTX.GT.ICUT)THEN
        DO2000I=INTX,ICUT+1,-1
          DX=DBLE(I)
          DTERM1=DLOG(DN+1.0D0)
          DTERM2=DLBETA(DN-DX+DV,DX+DW)
          DTERM3=DLBETA(DN-DX+1.0D0,DX+1.0D0)
          DTERM4=DLBETA(DV,DW)
          DCDF=DEXP(DTERM2-DTERM1-DTERM3-DTERM4)
          DSUM2=DSUM2+DCDF
 2000   CONTINUE
      ENDIF
      DCDF=DSUM1+DSUM2
      CDF=REAL(DCDF)
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE BBNL(MEW, THETA, RL, MRL, LM, RNL)
C
C        ALGORITHM AS 189.3 APPL. STATIST. (1983) VOL.32, NO.2
C
C        SUBROUTINE FOR CALCULATION OF THE BETA BINOMIAL LOG
C        LIKELIHOOD
C
      DOUBLE PRECISION MEW, THETA, RNL, A
      INTEGER RL(MRL,3), LM(3)
C
      RNL = 0.0D0
      MLM = LM(3)
      DO 5 I = 1,MLM
        A = DBLE(I-1)*THETA
        IF(I.LE.LM(1))RNL = RNL + DBLE(RL(I,1))*DLOG(MEW+A)
        IF(I.LE.LM(2))RNL = RNL + DBLE(RL(I,2))*DLOG(1.0D0-MEW+A)
        RNL = RNL - DBLE(RL(I,3))*DLOG(1.0D0+A)
    5 CONTINUE
      RETURN
      END
      SUBROUTINE BBNME(N, IX, IN, W, P, INF, MEW, THETA)
C
C        ALGORITHM AS 189.1 APPL. STATIST. (1983) VOL.32, NO.2
C
C        SUBROUTINE TO ESTIMATE MEW AND THETA OF THE BETA BINOMIAL
C        DISTRIBUTION BY THE METHOD OF MOMENTS
C
      DOUBLE PRECISION W(N), P(N), INF, MEW, THETA, D1, D2, R, S
      DOUBLE PRECISION TP, WT
      INTEGER IX(N), IN(N)
      LOGICAL J
C
      J = .FALSE.
      DO 5 I = 1,N
        W(I) = DBLE(IN(I))
        P(I) = DBLE(IX(I))/W(I)
    5 CONTINUE
   10 WT = 0.0D0
      TP = 0.0D0
      DO 15 I = 1,N
        WT = WT+W(I)
        TP = TP+W(I)*P(I)
   15 CONTINUE
      TP = TP/WT
      S = 0.0D0
      D1 = 0.0D0
      D2 = 0.0D0
      DO 20 I = 1,N
        R = P(I)-TP
        S = S+W(I)*R*R
        R = W(I)*(1.0D0-W(I)/WT)
        D1 = D1+R/DBLE(IN(I))
        D2 = D2+R
   20 CONTINUE
      S = DBLE(N-1)*S/DBLE(N)
      R = TP*(1.0D0-TP)
      IF(R.EQ.0.0D0) GOTO 30
      R = (S-R*D1)/(R*(D2-D1))
      IF(R.LT.0.0) R = 0.0D0
      IF(J) GOTO 30
      DO 25 I = 1,N
   25 W(I) = W(I)/(1.0D0+R*(W(I)-1.0D0))
      J = .TRUE.
      GOTO 10
   30 MEW = TP
      IF(R.GE.1.0D0) GOTO 35
      THETA = R/(1.0D0-R)
      IF(THETA.LE.INF) RETURN
   35 THETA = INF
      RETURN
      END
      SUBROUTINE BBNML(N,IX,IN,W,P,RL,MRL,ITER,CCRIT,MEW,THETA, 
     *  SEM, SETH, RNL, IFAULT)
C UKC NETLIB DISTRIBUTION COPYRIGHT 1990 RSS
C
C      
C        ALGORITHM AS189 APPL. STATIST. (1983) VOL.32, NO.2
C      
C        SUBROUTINE FOR CALCULATING THE MAXIMUM LIKELIHOOD ESTIMATES
C        OF THE PARAMETERS OF THE BETA BINOMIAL DISTRIBUTION
C      
      DOUBLE PRECISION W(N), P(N), CCRIT, MEW, THETA, SEM, SETH
      DOUBLE PRECISION RNL, INF, DUM 
      DOUBLE PRECISION  FD(2), SD(3), TD(4), UB(2), DEL, EPS
      DOUBLE PRECISION A, B, C, D, E, F
      INTEGER IX(N), IN(N), RL(MRL,3), LM(3), RD1(2,2), RD2(2,3), 
     *  RD3(2,4)
      LOGICAL MC
      PARAMETER (INF = 1.0D6)
      DATA
     *  RD1(1,1), RD1(2,1), RD1(1,2), RD1(2,2)/1,-1,1,1/,
     *  RD2(1,1), RD2(2,1), RD2(1,2), RD2(2,2), 
     *  RD2(1,3), RD2(2,3)/-1,-1,-1,1,-1,-1/,
     *  RD3(1,1), RD3(2,1), RD3(1,2), RD3(2,2), RD3(1,3), 
     *  RD3(2,3), RD3(1,4), RD3(2,4)/2,-2,2,2,2,-2,2,2/
C
      I = ITER
      ITER = 0
      MC = .TRUE.
      UB(1) = 0.01D0
      UB(2) = 0.01D0
C
C        SET THE ARRAYS RL AND LM
C
      CALL BBNSET(N, IX, IN, RL, MRL, LM, IFAULT)
      IF(IFAULT.NE.0) RETURN
      SEM = -1.0D0
      SETH = -1.0D0
      NND = 0
C
C        CALCULATION OF INITIAL ESTIMATES (BY MOMENTS)
C
      CALL BBNME(N, IX, IN, W, P, INF, MEW, THETA)
      IF(THETA.EQ.INF) GOTO 50
C
C        NEWTON-RAPHSON ITERATION ON FIRST DERIVATIVES
C
    5 IF(ITER.LE.I) GOTO 10
      IFAULT = 7
      GOTO 60
C
C        CALCULATE FIRST DERIVATIVES OF LOG LIKELIHOOD
C
   10 CALL GDER(MEW, THETA, RL, MRL, LM, 2, RD1, FD)
C
C        CALCULATE SECOND DERIVATIVES OF LOG_LIKELIHOOD
C
      CALL GDER(MEW, THETA, RL, MRL, LM, 3, RD2, SD)
C
C        CALCULATE THIRD DERIVATIVES OF LOG LIKELIHOOD
C
      CALL GDER(MEW, THETA, RL, MRL, LM, 4, RD3, TD)
C
C        CALCULATE INCREMENTS
C
      DUM = SD(1)*SD(3) - SD(2)*SD(2)
      IF(SD(1).LT.0.0D0.AND.DUM.GT.0.0D0) GOTO 15
C
C        NON NEGATIVE DEFINITE MATRIX
C
      NND = NND+1
C
C        SD(1) IS ALWAYS NEGATIVE SO A GRADIENT STEP IS MADE ON MEW
C
      A = MEW - FD(1)/SD(1)
      B = THETA
      IF(FD(2).NE.0.0D0) B = B + SIGN(UB(2),FD(2))
      IF(A.LE.0.0D0) A = 0.0001D0
      IF(A.GE.1.0D0) A = 0.9999D0
      IF(B.LT.0.0D0) B = 0.0D0
      IF(B.GT.INF) B = INF
      CALL BBNL(MEW, THETA, RL, MRL, LM, C)
      CALL BBNL(A, B, RL, MRL, LM, D)
      IF(NND.GT.10.OR.C.GE.D) GOTO 40
      ITER = ITER+1
      MEW = A
      THETA = B
      GOTO 5
   15 DEL = (FD(2)*SD(2) - FD(1)*SD(3))/DUM
      EPS = (FD(1)*SD(2) - FD(2)*SD(1))/DUM
C
C        CHECK LIPSCHITZ CONDITION SATISFIED
C
      A = SD(2)*TD(2) - TD(1)*SD(3)
      B = SD(2)*TD(3) - TD(2)*SD(3)
      C = TD(1)*SD(2) - TD(2)*SD(1)
      D = SD(2)*TD(2) - SD(1)*TD(3)
      E = SD(2)*TD(4) - TD(3)*SD(3)
      F = TD(3)*SD(2) - TD(4)*SD(1)
      A = DEL*A + EPS*B
      C = DEL*C + EPS*D
      E = DEL*B + EPS*E
      F = DEL*D + EPS*F
      DUM = (A*A + C*C + E*E + F*F)/(DUM*DUM)
      IF(DUM.GE.1.0D0) GOTO 20
      IF(ABS(DEL).LE.CCRIT.AND.ABS(EPS).LE.CCRIT) MC = .FALSE.
      GOTO 45
C
C        FAILURE OF LIPSCHITZ CONDITION. A STEP IN THE DIRECTION OF THE
C        GRADIENT IS MADE.
C
   20 A = FD(1)*FD(1)
      B = FD(2)*FD(2)
      C = A*SD(1) + 2.0D0*SD(2)*FD(1)*FD(2) + B*SD(3)
      IF(C.NE.0.0D0) GOTO 25
      DEL = 0.0D0
      IF(FD(1).NE.0.0D0) DEL = SIGN(UB(1),FD(1))
      EPS = 0.0D0
      IF(FD(2).NE.0.0D0) EPS = SIGN(UB(2),FD(2))
      GOTO 30
   25 C = -(A+B)/C
      DEL = C*FD(1)
      EPS = C*FD(2)
      IF(ABS(DEL).GT.UB(1)) DEL = SIGN(UB(1),DEL)
      UB(1) = 2.0D0*DABS(DEL)
      IF(DABS(EPS).GT.UB(2)) EPS = SIGN(UB(2),EPS)
      UB(2) = 2.0D0*ABS(EPS)
   30 CALL BBNL(MEW, THETA, RL, MRL, LM, C)
   35 A = MEW + DEL
      B = THETA + EPS
      IF(A.LE.0.0D0) A = 0.0001D0
      IF(A.GE.1.0D0) A = 0.9999D0
      DEL = A - MEW
      IF(B.LT.0.0D0) B = 0.0D0
      IF(B.GT.INF) B = INF
      EPS = B - THETA
      CALL BBNL(A, B, RL, MRL, LM, D)
C
C        CHECK TO SEE IF GRADIENT STEP HAS INCREASED LOG LIKELIHOOD
C
      IF(D.GT.C) GOTO 45
      DEL = DEL/2.0D0
      EPS = EPS/2.0D0
      IF(DABS(DEL).GT.CCRIT.OR.DABS(EPS).GT.CCRIT) GOTO 35
   40 IFAULT = 8
      GOTO 60
   45 ITER = ITER + 1
      A = MEW + DEL
      B = THETA + EPS
      IF(A.GT.0.0D0.AND.A.LT.1.0D0.AND.B.GE.0.0D0.AND.B.LE.INF) GOTO 55
      IF(A.LE.0.0D0) MEW = 0.0D0
      IF(A.GE.1.0D0) MEW = 1.0D0
      IF(B.LT.0.0D0) THETA = 0.0D0
      IF(B.GT.INF) THETA = INF
   50 IFAULT = 6
      GOTO 60
   55 MEW = A
      THETA = B
      IF(MC) GOTO 5
C
C        CALCULATE LOG LIKELIHOOD AND S.E.S
C
      IF(SD(1).LT.0.0D0) SEM = DSQRT(-1.0D0/SD(1))
      IF(SD(3).LT.0.0D0) SETH = DSQRT(-1.0D0/SD(3))
   60 CALL BBNL(MEW, THETA, RL, MRL, LM, RNL)
      RETURN
      END
      SUBROUTINE BBNPDF(X,V,W,N,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE AT THE SINGLE PRECISION VALUE X
C              FOR THE BETA-BINOMIAL DISTRIBUTION
C              WITH SINGLE PRECISION PARAMETERS V AND W
C              AND INTEGER 'NUMBER OF BERNOULLI TRIALS'
C              PARAMETER = N.
C              IF V AND W ARE INTEGERS, THIS BECOMES THE NEGATIVE
C              HYPERGEOMETRIC DISTRIBUTION.
C              THIS DISTRIBUTION IS DEFINED FOR ALL
C              DISCRETE INTEGER X BETWEEN 0 (INCLUSIVELY)
C              AND N (INCLUSIVELY).
C              THIS DISTRIBUTION HAS THE PROBABILITY FUNCTION
C              F(X) = B(N-X+V,X+B)/[(N+1)*B(N-X+1,X+1)*B(V,W)
C              WHERE B(A,B) IS THE BETA FUNCTION.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE
C                                AT WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE INTEGRAL-VALUED,
C                                AND BETWEEN 0.0 (INCLUSIVELY)
C                                AND N (INCLUSIVELY).
C                     --V      = THE SINGLE PRECISION VALUE
C                                OF THE FIRST SHAPE PARAMETER.
C                     --W      = THE SINGLE PRECISION VALUE
C                                OF THE SECOND SHAPE PARAMETER.
C                     --N      = THE INTEGER VALUE
C                                OF THE 'NUMBER OF BERNOULLI TRIALS'
C                                PARAMETER.
C                                N SHOULD BE A POSITIVE INTEGER.
C     OUTPUT ARGUMENTS--PDF    = THE SINGLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE PDF
C             FOR THE BETA-BINOMIAL DISTRIBUTION
C             WITH 'BERNOULLI PROBABILITY' PARAMETER = P
C             AND 'NUMBER OF BERNOULLI TRIALS' PARAMETER = N.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE INTEGRAL-VALUED,
C                   AND BETWEEN 0.0 (INCLUSIVELY)
C                   AND N (INCLUSIVELY).
C                 --P SHOULD BE BETWEEN 0.0 (EXCLUSIVELY)
C                   AND 1.0 (EXCLUSIVELY).
C                 --N SHOULD BE A POSITIVE INTEGER.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--DSQRT, DATAN.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--HASTINGS AND PEACOCK, STATISTICAL
C                 DISTRIBUTIONS--2ND ED., CHAPTER 5
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--96/2
C     ORIGINAL VERSION--FEBRUARY  1996.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX, DV, DW, DN, DPDF
      DOUBLE PRECISION DTERM1, DTERM2, DTERM3, DTERM4
      DOUBLE PRECISION DLBETA, DBINOM
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      PDF=0.0
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      AN=N
      IF(V.LE.0.0)THEN
        WRITE(ICOUT,11)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)V
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ENDIF
      IF(W.LE.0.0)THEN
        WRITE(ICOUT,12)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)V
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ENDIF
      IF(N.LE.0)THEN
        WRITE(ICOUT,25)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ENDIF
      INTX=X+0.0001
      FINTX=INTX
      DEL=X-FINTX
      IF(DEL.LT.0.0)DEL=-DEL
      IF(DEL.GT.0.001)THEN
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,6)INT(FINTX)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
      ENDIF
      IF(FINTX.LT.0.0 .OR. FINTX.GT.AN)THEN
        WRITE(ICOUT,4)N
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
C
    4 FORMAT('***** FATAL ERROR--THE FIRST INPUT ',
     1'ARGUMENT TO THE BBNPDF SUBROUTINE IS OUTSIDE THE USUAL ',
     1'(0,N) = (0,',I8,') INTERVAL')
    5 FORMAT('***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ',
     1'ARGUMENT TO THE BBNPDF SUBROUTINE IS NON-INTEGRAL *****')
    6 FORMAT('      IT HAS BEEN SET TO ',I8)
   11 FORMAT('***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE ',
     1' BBNPDF SUBROUTINE IS NON-POSITIVE')
   12 FORMAT('***** FATAL ERROR--THE THIRD INPUT ARGUMENT TO THE ',
     1' BBNPDF SUBROUTINE IS NON-POSITIVE')
   25 FORMAT('***** FATAL ERROR--THE FOURTH INPUT ARGUMENT TO THE ',
     1' BBNPDF SUBROUTINE IS NON-POSITIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
C
      DX=DBLE(FINTX)
      DV=DBLE(V)
      DW=DBLE(W)
      DN=DBLE(N)
C
      DTERM1=DLOG(DN+1.0D0)
      DTERM2=DLBETA(DN-DX+DV,DX+DW)
      DTERM3=DLBETA(DN-DX+1.0D0,DX+1.0D0)
      DTERM4=DLBETA(DV,DW)
      DPDF=DTERM2-DTERM1-DTERM3-DTERM4
      IF(DPDF.LE.-80.D0)THEN
        PDF=0.0
      ELSEIF(DPDF.GT.80.D0)THEN
        WRITE(ICOUT,101)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
      ELSE
        DPDF=DEXP(DPDF)
        PDF=SNGL(DPDF)
      ENDIF
  101 FORMAT('****** FATAL ERROR--OVERFLOW IN BBNPDF ROUTINE.')
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE BBNPPF(P,V,W,N,PPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE AT THE SINGLE PRECISION VALUE P
C              FOR THE BETA-BINOMIAL DISTRIBUTION
C              WITH SINGLE PRECISION PARAMETERS V AND W
C              AND INTEGER 'NUMBER OF BERNOULLI TRIALS'
C              PARAMETER = N.
C              IF V AND W ARE INTEGERS, THIS BECOMES THE NEGATIVE
C              HYPERGEOMETRIC DISTRIBUTION.
C              THIS DISTRIBUTION IS DEFINED FOR ALL
C              DISCRETE INTEGER X BETWEEN 0 (INCLUSIVELY)
C              AND N (INCLUSIVELY).
C              THIS DISTRIBUTION HAS THE PROBABILITY FUNCTION
C              F(X) = B(N-X+V,X+B)/[(N+1)*B(N-X+1,X+1)*B(V,W)
C              WHERE B(A,B) IS THE BETA FUNCTION.
C     INPUT  ARGUMENTS--P      = THE SINGLE PRECISION VALUE
C                                (BETWEEN 0.0 (INCLUSIVELY)
C                                AND 1.0 (INCLUSIVELY))
C                                AT WHICH THE PERCENT POINT
C                                FUNCTION IS TO BE EVALUATED.
C                     --V      = THE SINGLE PRECISION VALUE
C                                OF THE FIRST SHAPE PARAMETER.
C                     --W      = THE SINGLE PRECISION VALUE
C                                OF THE SECOND SHAPE PARAMETER.
C                     --N      = THE INTEGER VALUE
C                                OF THE 'NUMBER OF BERNOULLI TRIALS'
C                                PARAMETER.
C                                N SHOULD BE A POSITIVE INTEGER.
C     OUTPUT ARGUMENTS--PPF    = THE SINGLE PRECISION PERCENT
C                                POINT FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PERCENT POINT  .
C             FUNCTION VALUE PPF
C             FOR THE BETA-BINOMIAL DISTRIBUTION
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--N SHOULD BE A POSITIVE INTEGER.
C                 --P SHOULD BE BETWEEN 0.0 (INCLUSIVELY)
C                   AND 1.0 (INCLUSIVELY).
C     OTHER DATAPAC   SUBROUTINES NEEDED--BBNCDF
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION AND DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     COMMENT--NOTE THAT EVEN THOUGH THE OUTPUT
C              FROM THIS DISCRETE DISTRIBUTION
C              PERCENT POINT FUNCTION
C              SUBROUTINE MUST NECESSARILY BE A
C              DISCRETE INTEGER VALUE,
C              THE OUTPUT VARIABLE PPF IS SINGLE
C              PRECISION IN MODE.
C              PPF HAS BEEN SPECIFIED AS SINGLE
C              PRECISION SO AS TO CONFORM WITH THE DATAPAC
C              CONVENTION THAT ALL OUTPUT VARIABLES FROM ALL
C              DATAPAC SUBROUTINES ARE SINGLE PRECISION.
C              THIS CONVENTION IS BASED ON THE BELIEF THAT
C              1) A MIXTURE OF MODES (FLOATING POINT
C              VERSUS INTEGER) IS INCONSISTENT AND
C              AN UNNECESSARY COMPLICATION
C              IN A DATA ANALYSIS; AND
C              2) FLOATING POINT MACHINE ARITHMETIC
C              (AS OPPOSED TO INTEGER ARITHMETIC)
C              IS THE MORE NATURAL MODE FOR DOING
C              DATA ANALYSIS.
C     REFERENCES--HASTINGS AND PEACOCK, STATISTICAL
C                 DISTRIBUTIONS--2ND. ED., 1994, CHAPTER 5
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--96/2
C     ORIGINAL VERSION--FEBRUARY  1996.
C     UPDATED         --MAY       1996. TEST FOR LOWER BOUND
C     UPDATED         --MARCH     2004. MODIFY THE ALGORITHM
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX, DV, DW, DN, DCDF
      DOUBLE PRECISION DTERM1, DTERM2, DTERM3, DTERM4
      DOUBLE PRECISION DLBETA
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DP
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(P.LT.0.0.OR.P.GT.1.0)THEN
        WRITE(ICOUT,1)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)P
        CALL DPWRST('XXX','BUG ')
        PPF=0.0
        GOTO9999
      ENDIF
      IF(V.LE.0.0)THEN
        WRITE(ICOUT,11)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)V
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ENDIF
      IF(W.LE.0.0)THEN
        WRITE(ICOUT,12)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)V
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ENDIF
      IF(N.LE.0)THEN
        WRITE(ICOUT,25)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ENDIF
    1 FORMAT('***** FATAL ERROR--THE FIRST INPUT ARGUMENT TO THE ',
     1' BBNPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL')
   11 FORMAT('***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE ',
     1' BBNPPF SUBROUTINE IS NON-POSITIVE')
   12 FORMAT('***** FATAL ERROR--THE THIRD INPUT ARGUMENT TO THE ',
     1' BBNPPF SUBROUTINE IS NON-POSITIVE')
   25 FORMAT('***** FATAL ERROR--THE FOURTH INPUT ARGUMENT TO THE ',
     1' BBNPPF SUBROUTINE IS NON-POSITIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
C
      AN=N
      PPF=0.0
C
C     TREAT CERTAIN SPECIAL CASES IMMEDIATELY--
C     1) P = 0.0
C     2) P = 1.0
C
      IF(P.EQ.0.0)THEN
        PPF=0.0
        GOTO9999
      ENDIF
C
      IF(P.EQ.1.0)THEN
        PPF=REAL(N)
        GOTO9999
      ENDIF
C
C     COMPUTE THE BBNCDF, TERMINATE WHEN CDF IS GREATER THAN OR
C     EQUAL TO P.  COMPARISON PEFORMED ON LOG SCALE.
C
      DP=DBLE(P)
      DN=DBLE(N)
      DV=DBLE(V)
      DW=DBLE(W)
      DSUM1=0.0D0
      DO1000I=0,N
        DX=DBLE(I)
        DTERM1=DLOG(DN+1.0D0)
        DTERM2=DLBETA(DN-DX+DV,DX+DW)
        DTERM3=DLBETA(DN-DX+1.0D0,DX+1.0D0)
        DTERM4=DLBETA(DV,DW)
        DCDF=DEXP(DTERM2-DTERM1-DTERM3-DTERM4)
        DSUM1=DSUM1+DCDF
        IF(DSUM1.GE.DP)THEN
          PPF=REAL(I)
          GOTO9999
        ENDIF
 1000 CONTINUE
      PPF=REAL(N)
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE BBNRAN(ALPHA,BETA,NPAR,N,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE BETA-BINOMIAL DISTRIBUTION
C              WITH SINGLE PRECISION 'BERNOULLI PROBABILITY'
C              PARAMETER = P FOLLOWING A BETA DISTRIBUTION WITH
C              SHAPE PARAMETERS ALPHA AND BETA,
C              AND INTEGER 'NUMBER OF BERNOULLI TRIALS'
C              PARAMETER = NPAR.
C              THIS DISTRIBUTION IS DEFINED FOR ALL
C              DISCRETE INTEGER X BETWEEN 0 (INCLUSIVELY)
C              AND NPAR (INCLUSIVELY).
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --ALPHA  = THE SINGLE PRECISION VALUE
C                                OF THE FIRST SHAPE PARAMETER OF THE
C                                BETA DISTRIBUTION.
C                                ALPHA > 0.
C                     --BETA   = THE SINGLE PRECISION VALUE
C                                OF THE SECOND SHAPE PARAMETER OF THE
C                                BETA DISTRIBUTION.
C                                BETA > 0.
C                     --NPAR   = THE INTEGER VALUE
C                                OF THE 'NUMBER OF BERNOULLI TRIALS'
C                                PARAMETER.
C                                NPAR SHOULD BE A POSITIVE INTEGER.
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST N)
C                                INTO WHICH THE GENERATED
C                                RANDOM SAMPLE WILL BE PLACED.
C     OUTPUT--A RANDOM SAMPLE OF SIZE N
C             FROM THE BETA-BINOMIAL DISTRIBUTION.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C                 --ALPHA, BETA > 0
C                 --NPAR SHOULD BE A POSITIVE INTEGER.
C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN, GEORAN.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     COMMENT--NOTE THAT EVEN THOUGH THE OUTPUT
C              FROM THIS DISCRETE RANDOM NUMBER
C              GENERATOR MUST NECESSARILY BE A
C              SEQUENCE OF ***INTEGER*** VALUES,
C              THE OUTPUT VECTOR X IS SINGLE
C              PRECISION IN MODE.
C              X HAS BEEN SPECIFIED AS SINGLE
C              PRECISION SO AS TO CONFORM WITH THE DATAPAC
C              CONVENTION THAT ALL OUTPUT VECTORS FROM ALL
C              DATAPAC SUBROUTINES ARE SINGLE PRECISION.
C              THIS CONVENTION IS BASED ON THE BELIEF THAT
C              1) A MIXTURE OF MODES (FLOATING POINT
C              VERSUS INTEGER) IS INCONSISTENT AND
C              AN UNNECESSARY COMPLICATION
C              IN A DATA ANALYSIS; AND
C              2) FLOATING POINT MACHINE ARITHMETIC
C              (AS OPPOSED TO INTEGER ARITHMETIC)
C              IS THE MORE NATURAL MODE FOR DOING
C              DATA ANALYSIS.
C     REFERENCES--JOHNSON AND KOTZ, DISCRETE
C                 DISTRIBUTIONS, 1969, PAGES 50-86.
C               --HASTINGS AND PEACOCK, STATISTICAL
C                 DISTRIBUTIONS--A HANDBOOK FOR
C                 STUDENTS AND PRACTITIONERS, 1975,
C                 PAGE 41.
C               --FELLER, AN INTRODUCTION TO PROBABILITY
C                 THEORY AND ITS APPLICATIONS, VOLUME 1,
C                 EDITION 2, 1957, PAGES 135-142.
C               --NATIONAL BUREAU OF STANDARDS APPLIED MATHEMATICS
C                 SERIES 55, 1964, PAGE 929.
C               --KENDALL AND STUART, THE ADVANCED THEORY OF
C                 STATISTICS, VOLUME 1, EDITION 2, 1963, PAGES 120-125.
C               --MOOD AND GRABLE, INTRODUCTION TO THE THEORY
C                 OF STATISTICS, EDITION 2, 1963, PAGES 64-69.
C               --TOCHER, THE ART OF SIMULATION,
C                 1963, PAGES 39-40.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--2001/12
C     ORIGINAL VERSION--DECEMBER  2001.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
C
      DIMENSION U(2)
      DIMENSION G(2)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)THEN
        WRITE(ICOUT, 5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
      IF(ALPHA.LE.0.0)THEN
        WRITE(ICOUT,11)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ALPHA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
      IF(BETA.LE.0.0)THEN
        WRITE(ICOUT,12)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)BETA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
      IF(NPAR.LT.1)THEN
        WRITE(ICOUT,25)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)NPAR
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
    5 FORMAT('***** FATAL ERROR--NUMBER OF BETA-BINOMIAL RANDOM ',
     1'NUMBERS REQUESTED < 1')
   11 FORMAT('***** FATAL ERROR--THE ALPHA SHAPE PARAMETER ARGUMENT',
     1' TO THE BBNRAN SUBROUTINE IS <= 0')
   12 FORMAT('***** FATAL ERROR--THE BETA SHAPE PARAMETER ARGUMENT',
     1' TO THE BBNRAN SUBROUTINE IS <= 0')
   25 FORMAT('***** FATAL ERROR--THE NUMBER OF TRIALS ARGUMENT TO THE',
     1' BBNRAN SUBROUTINE IS NON-POSITIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
C
C     FIRST, GENERATE N BETA RANDOM NUMBERS.
C
      CALL BETRAN(N,ALPHA,BETA,ISEED,X)
C
C     CHECK ON THE MAGNITUDE OF P,
C     AND BRANCH TO THE FASTER
C     GENERATION METHOD ACCORDINGLY.
C
      DO100I=1,N
C
      P=X(I)
C
      IF(P.LT.0.1)THEN
C
C       IF P IS SMALL, GENERATE N BINOMIAL NUMBERS
C       USING THE FACT THAT THE WAITING TIME FOR 1 SUCCESS IN
C       BERNOULLI TRIALS HAS A GEOMETRIC DISTRIBUTION.
C
        ISUM=0
        J=1
  550   CONTINUE
        CALL GEORAN(1,P,ISEED,G)
        IG=G(1)+0.5
        ISUM=ISUM+IG+1
        IF(ISUM.GT.NPAR)GOTO650
        J=J+1
        GOTO550
  650   CONTINUE
        X(I)=J-1
      ELSE
C
C       IF P IS MODERATE OR LARGE,
C       GENERATE N BINOMIAL RANDOM NUMBERS
C       USING THE REJECTION METHOD.
C
        ISUM=0
        DO200J=1,NPAR
          CALL UNIRAN(1,ISEED,U)
          IF(U(1).LE.P)ISUM=ISUM+1
  200   CONTINUE
        X(I)=ISUM
      ENDIF
C
  100 CONTINUE
C
 9000 CONTINUE
      RETURN
C
      END
      SUBROUTINE BBNSET(N, IX, IN, RL, MRL, LM, IFAULT)
C
C        ALGORITHM AS 189.2 APPL. STATIST. (1983) VOL.32, NO.2
C
C        SUBROUTINE FOR SETTING UP ARRAY FOR CALCULATION OF
C        THE BETA BINOMIAL LOG LIKELIHOOD AND ITS DERIVATIVES
C
      INTEGER IX(N), IN(N), RL(MRL,3), LM(3)
C
C     TEST ADMISSIBILITY OF DATA
C
      IF(N.GT.1) GOTO 5
      IFAULT = 1
      RETURN
    5 DO 10 I = 1,N
        IF(IX(I).GT.0) GOTO 15
   10 CONTINUE
      IFAULT = 2
      RETURN
   15 DO 20 I = 1,N
        IF(IX(I).LT.IN(I)) GOTO 25
   20 CONTINUE
      IFAULT = 3
      RETURN
C
C        FORM MATRIX OF COUNTS
C
   25 IFAULT = 4
      DO 30 I = 1,3
        LM(I) = 0
        DO 30 J = 1,MRL
          RL(J,I) = 0
   30 CONTINUE
      DO 65 I = 1,N
        JJ = IX(I)
        MAR = 1
        GOTO 45
   35   JJ = IN(I)-IX(I)
        MAR = 2
        GOTO 45
   40   JJ = IN(I)
        MAR = 3
   45   IF(JJ) 50,60,55
   50   IFAULT = 5
        RETURN
   55   IF(JJ.GT.MRL) RETURN
        IF(JJ.GT.LM(MAR)) LM(MAR) = JJ
        RL(JJ,MAR) = RL(JJ,MAR)+1
   60   GOTO(35,40,65) MAR
   65 CONTINUE
      IFAULT = 0
C
C        EVALUATE NUMBER OF CALLS TO DIFFERENT TERMS OF LIKELIHOOD
C        FUNCTION
C
      DO 75 I = 1,3
        JJ = LM(I)-1
        IF(JJ.LE.0) GOTO 75
        K = JJ
        DO 70 J = 1,JJ
          RL(K,I) = RL(K,I)+RL(K+1,I)
          K = K-1
   70   CONTINUE
   75 CONTINUE
      RETURN
      END
      SUBROUTINE BEICDF(X,S1SQ,S2SQ,NU,IBEIDF,DCDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE BESSEL I-FUNCTION
C              DISTRIBUTION WITH SHAPE PARAMETERS S1SQ, S2SQ, AND
C              NU.  THE CUMULATIVE DISTRIBUTION IS COMPUTED BY
C              NUMERICALLY INTEGRATING THE PDF FUNCTION.
C     INPUT  ARGUMENTS--X       = THE SINGLE PRECISION VALUE AT
C                                 WHICH THE CUMULATIVE DISTRIBUTION
C                                 FUNCTION IS TO BE EVALUATED.
C                     --S1SQ    = THE FIRST SHAPE PARAMETER
C                     --S2SQ    = THE SECOND SHAPE PARAMETER
C                     --NU      = THE THIRD SHAPE PARAMETER
C     OUTPUT ARGUMENTS--CDF     = THE SINGLE PRECISION CUMULATIVE
C                                 DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION CUMULATIVE DISTRIBUTION
C             FUNCTION VALUE FOR THE BESSEL I-FUNCTION
C             DISTRIBUTION WITH SHAPE PARAMETERS S1SQ,
C             S2SQ, AND NU.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--DQAGI.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, (1994), "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME 1", SECOND EDITION,
C                 WILEY, PP. 50-52.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004.8
C     ORIGINAL VERSION--AUGUST    2004.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IBEIDF
C
      INTEGER LIMIT
      INTEGER LENW
      PARAMETER(LIMIT=100)
      PARAMETER(LENW=4*LIMIT)
      INTEGER INF
      INTEGER NEVAL
      INTEGER IER
      INTEGER LAST
      INTEGER IWORK(LIMIT)
      DOUBLE PRECISION S1SQ
      DOUBLE PRECISION S2SQ
      DOUBLE PRECISION NU
      DOUBLE PRECISION EPSABS
      DOUBLE PRECISION EPSREL
      DOUBLE PRECISION RESULT
      DOUBLE PRECISION DCDF
      DOUBLE PRECISION DEPS
      DOUBLE PRECISION DLOW
      DOUBLE PRECISION DUPP
      DOUBLE PRECISION X
      DOUBLE PRECISION DX
      DOUBLE PRECISION DB
      DOUBLE PRECISION DC
      DOUBLE PRECISION DM
      DOUBLE PRECISION ABSERR
      DOUBLE PRECISION WORK(LENW)
C
      DOUBLE PRECISION BEIFUN
      EXTERNAL BEIFUN
C
      DOUBLE PRECISION DS1SQ
      DOUBLE PRECISION DS2SQ
      DOUBLE PRECISION DNU
      CHARACTER*4 IBEID2
      COMMON/BEICOM/DS1SQ,DS2SQ,DNU,IBEID2
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,AKMBPC,AKMCPW,AKMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----DATA STATEMENTS-------------------------------------------------
C
C-----START POINT-----------------------------------------------------
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      IF(IBEIDF.EQ.'1')THEN
        DB=4.0D0*S1SQ*S2SQ/(S1SQ - S2SQ)
        DC=(S1SQ + S2SQ)/(S1SQ - S2SQ)
        DM=2.0D0*NU + 1.0D0
      ELSE
        DB=S1SQ
        DC=S2SQ
        DM=NU
      ENDIF
C
      IF(DABS(DC).LE.1.0D0)THEN
        WRITE(ICOUT,9)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,10)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,11)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,12)S1SQ
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,13)S2SQ
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,14)DC
        CALL DPWRST('XXX','WRIT')
        CDF=0.0D0
        GOTO9000
      ENDIF
    9 FORMAT('***** ERROR: ABSOLUTE VALUE OF 1 - C**2 <= 1 ',
     1       'IN BEICDF ROUTINE.')
   10 FORMAT('      C = (S1**2 + S2**2)/(S1**2 - S2**2) WHERE ',
     1       'S1**2 AND S2**2')
   11 FORMAT('      ARE THE FIRST AND SECOND SHAPE PARAMETERS, ',
     1       'RESPECTIVELY.')
   12 FORMAT('      VALUE OF S1**2 IS: ',G15.7)
   13 FORMAT('      VALUE OF S2**2 IS: ',G15.7)
   14 FORMAT('      VALUE OF C IS:     ',G15.7)
      IF(DC.GT.0.0D0 .AND. X.LE.0.0D0)THEN
        WRITE(ICOUT,24)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,25)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,48)X
        CALL DPWRST('XXX','WRIT')
        CDF=0.0D0
        GOTO9000
      ENDIF
   24 FORMAT('***** ERROR: VALUE OF THE INPUT ARGUMENT ',
     1       'IN BEICDF ROUTINE IS NON-POSITIVE')
   25 FORMAT('      FOR THE CASE WHERE S1**2 > S2**2 (THESE ARE THE ',
     1       'FIRST AND SECOND SHAPE PARAMETERS).')
      IF(DC.LT.0.0D0 .AND. X.GE.0.0D0)THEN
        WRITE(ICOUT,34)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,35)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,48)X
        CALL DPWRST('XXX','WRIT')
        CDF=0.0D0
        GOTO9000
      ENDIF
   34 FORMAT('***** ERROR: VALUE OF THE INPUT ARGUMENT ',
     1       'IN BEICDF ROUTINE IS NON-NEGATIVE')
   35 FORMAT('      FOR THE CASE WHERE S1**2 < S2**2 (THESE ARE THE ',
     1       'FIRST AND SECOND SHAPE PARAMETERS).')
      IF(S1SQ.LE.0.0D0)THEN
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,48)S1SQ
        CALL DPWRST('XXX','WRIT')
        CDF=0.0D0
        GOTO9000
      ENDIF
    5 FORMAT('***** ERROR: VALUE OF FIRST SHAPE PARAMETER (SIGMA1**2)',
     1       ' IN BEICDF ROUTINE IS NON-POSITIVE.')
      IF(S2SQ.LE.0.0D0)THEN
        WRITE(ICOUT,6)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,48)S2SQ
        CALL DPWRST('XXX','WRIT')
        CDF=0.0D0
        GOTO9000
      ENDIF
    6 FORMAT('***** ERROR: VALUE OF SECOND SHAPE PARAMETER ',
     1       '(SIGMA2**2) IN BEICDF ROUTINE IS NON-POSITIVE.')
      IF(IBEIDF.EQ.'1')THEN
        IF(NU.LE.-0.25D0)THEN
          WRITE(ICOUT,7)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,48)NU
          CALL DPWRST('XXX','WRIT')
          CDF=0.0D0
          GOTO9000
        ENDIF
      ELSE
        IF(DM.LE.0.5D0)THEN
          WRITE(ICOUT,8)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,48)DM
          CALL DPWRST('XXX','WRIT')
          CDF=0.0D0
          GOTO9000
        ENDIF
      ENDIF
    7 FORMAT('***** ERROR: VALUE OF THIRD SHAPE PARAMETER (NU) IN ',
     1       'BEICDF ROUTINE IS < -0.25.')
    8 FORMAT('***** ERROR: VALUE OF THIRD SHAPE PARAMETER (M) IN ',
     1       'BEICDF ROUTINE IS <= 0.5.')
C
   48 FORMAT('      VALUE OF ARGUMENT IS: ',G15.7)
C
C
C               ************************************
C               **  STEP 1--                      **
C               **  COMPUTE THE DENSITY FUNCTION  **
C               ************************************
C
      EPSABS=0.0D0
      EPSREL=1.0D-7
      IER=0
      IKEY=3
      DEPS=1.0D-12
C
      DS1SQ=S1SQ
      DS2SQ=S2SQ
      DNU=NU
      IBEID2=IBEIDF
      DCDF=0.0D0
C
      IF(DC.GT.0.0D0)THEN
        IF(X.LE.DEPS)THEN
          DCDF=0.0D0
          GOTO9000
        ENDIF
        DLOW=DEPS
        DUPP=X
      ELSE
        IF(DABS(X).LE.DEPS)THEN
          DCDF=1.0D0
          GOTO9000
        ENDIF
        DLOW=X
        DUPP=-DEPS
      ENDIF
C
      CALL DQAG(BEIFUN,DLOW,DUPP,EPSABS,EPSREL,IKEY,DCDF,ABSERR,NEVAL,
     1          IER,LIMIT,LENW,LAST,IWORK,WORK)
C
      IF(DC.LT.0.0D0)THEN
        DCDF=1.0D0 - DCDF
      ENDIF
C
      IF(IER.EQ.1)THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,111)
  111   FORMAT('***** ERROR FROM BEICDF--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,113)
  113   FORMAT('      MAXIMUM NUMBER OF SUBDIVISIONS EXCEEDED.')
        CALL DPWRST('XXX','BUG ')
      ELSEIF(IER.EQ.2)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,121)
  121   FORMAT('***** ERROR FROM BEICDF--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,123)
  123   FORMAT('      ROUNDOFF ERROR PREVENTS REQUESTED TOLERANCE ',
     1         'FROM BEING ACHIEVED.')
        CALL DPWRST('XXX','BUG ')
      ELSEIF(IER.EQ.3)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,131)
  131   FORMAT('***** ERROR FROM BEICDF--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,133)
  133   FORMAT('      BAD INTEGRAND BEHAVIOUR DETECTED.')
        CALL DPWRST('XXX','BUG ')
      ELSEIF(IER.EQ.4)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,141)
  141   FORMAT('***** ERROR FROM BEICDF--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,143)
  143   FORMAT('      INTEGRATION DID NOT CONVERGE.')
        CALL DPWRST('XXX','BUG ')
      ELSEIF(IER.EQ.5)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,151)
  151   FORMAT('***** ERROR FROM BEICDF--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,153)
  153   FORMAT('      THE INTEGRATION IS PROBABLY DIVERGENT.')
        CALL DPWRST('XXX','BUG ')
      ELSEIF(IER.EQ.6)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,161)
  161   FORMAT('***** ERROR FROM BEICDF--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,163)
  163   FORMAT('      INVALID INPUT TO THE INTEGRATION ROUTINE.')
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      DOUBLE PRECISION FUNCTION BEIFUN(DX)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE BESSEL I-FUNCTION
C              DISTRIBUTION WITH SHAPE PARAMETERS S1SQ, S2SQ, AND NU.
C              THIS DISTRIBUTION IS DEFINED FOR POSITIVE X
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C
C                 BEIPDF(X,S1AQ,S2SQ,ANU) =
C                        K*X**M*EXP(-C*X/B)*PI*I(X/B,M)      X > 0
C              WITH
C                 B = 4*S1SQ**2*S2SQ**2/(S1SQ**2 - S2SQ**2)
C                 C = (S1SQ**2 + S2SQ**2/(S1SQ**2 - S2SQ**2)
C                 M = 2*NU + 1
C              AND
C                 K = |1 - C**2|**(M+0.5)/[SQRT(PI)*2**M*b**(M+1)*
C                     GAMMA(M+0.5)]
C                 I(Z,N) IS THE MODIFIED BESSEL FUNCTION OF THE
C                        FIRST KIND
C                 GAMMA IS THE GAMMA FUNCTION
C
C              THE BEIPDF ROUTINE IS CALLED TO COMPUTE THE
C              PROBABILITY DENSITY.  DEFINE AS FUNCTION TO BE USED FOR
C              INTEGRATION CODE CALLED BY BEICDF.  THIS ROUTINE USES
C              DOUBLE PRECISION ARITHMETIC.
C     INPUT  ARGUMENTS--DX      = THE DOUBLE PRECISION VALUE AT
C                                 WHICH THE PROBABILITY DENSITY
C                                 FUNCTION IS TO BE EVALUATED.
C     OUTPUT ARGUMENTS--BEIFUN  = THE DOUBLE PRECISION PROBABILITY
C                                 DENSITY FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE PDF FOR THE BESSEL I-FUNCTION
C             DISTRIBUTION WITH SHAPE PARAMETERS S1SQ, S2SQ, AND NU.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--BEIPDF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, (1994), "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME 1", SECOND EDITION,
C                 WILEY, PP. 50-53.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004.8
C     ORIGINAL VERSION--AUGUST    2004.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DTERM
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DS1SQ
      DOUBLE PRECISION DS2SQ
      DOUBLE PRECISION DNU
      CHARACTER*4 IBEID2
      COMMON/BEICOM/DS1SQ,DS2SQ,DNU,IBEID2
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----DATA STATEMENTS-------------------------------------------------
C
C-----START POINT-----------------------------------------------------
C
C               ************************************
C               **  STEP 1--                      **
C               **  COMPUTE THE DENSITY FUNCTION  **
C               ************************************
C
CCCCC CALL BEIPD2(DX,DS1SQ,DS2SQ,DNU,DTERM)
      CALL BEIPDF(DX,DS1SQ,DS2SQ,DNU,IBEID2,DTERM)
      BEIFUN=DTERM
C
 9000 CONTINUE
      RETURN
      END
      DOUBLE PRECISION FUNCTION BEIFU2(DX)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE BESSEL I-FUNCTION
C              DISTRIBUTION WITH SHAPE PARAMETERS S1SQ, S2SQ, AND
C              NU.  THIS DISTRIBUTION IS DEFINED FOR POSITIVE X
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C
C                 BEIPDF(X,S1AQ,S2SQ,ANU) =
C                        K*X**M*EXP(-C*X/B)*PI*I(X/B,M)      X > 0
C              WITH
C                 B = 4*S1SQ**2*S2SQ**2/(S1SQ**2 - S2SQ**2)
C                 C = (S1SQ**2 + S2SQ**2)/(S1SQ**2 - S2SQ**2)
C                 M = 2*NU + 1
C              AND
C                 K = |1 - C**2|**(M+0.5)/[SQRT(PI)*2**M*b**(M+1)*
C                     GAMMA(M+0.5)]
C                 I(Z,N) IS THE MODIFIED BESSEL FUNCTION OF THE
C                        FIRST KIND
C                 GAMMA IS THE GAMMA FUNCTION
C
C              THE BEICDF ROUTINE IS CALLED TO COMPUTE THE
C              CUMULATIVE DISTRIBUTION.
C              DEFINE AS FUNCTION TO BE USED FOR INTEGRATION
C              CODE CALLED BY BEICDF.  THIS ROUTINE USES
C              DOUBLE PRECISION ARITHMETIC.
C     INPUT  ARGUMENTS--DX      = THE DOUBLE PRECISION VALUE AT
C                                 WHICH THE PROBABILITY DENSITY
C                                 FUNCTION IS TO BE EVALUATED.
C     OUTPUT ARGUMENTS--BEIFU2  = THE DOUBLE PRECISION PROBABILITY
C                                 DENSITY FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE PDF FOR THE GENERALIZED INVERSE
C             GAUSSIAN DISTRIBUTION WITH SHAPE PARAMETERS S1SQ, S2SQ,
C             AND NU.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--BEICDF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, (1994), "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME 1", SECOND EDITION,
C                 WILEY, PP. 50-53.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004.8
C     ORIGINAL VERSION--AUGUST    2004.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DCDF
C
      DOUBLE PRECISION DP
      COMMON/BE2COM/DP
C
      DOUBLE PRECISION DS1SQ
      DOUBLE PRECISION DS2SQ
      DOUBLE PRECISION DNU
      CHARACTER*4 IBEID2
      COMMON/BEICOM/DS1SQ,DS2SQ,DNU,IBEID2
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----DATA STATEMENTS-------------------------------------------------
C
C-----START POINT-----------------------------------------------------
C
C               ************************************
C               **  STEP 1--                      **
C               **  COMPUTE THE CDF     FUNCTION  **
C               ************************************
C
      CALL BEICDF(DX,DS1SQ,DS2SQ,DNU,IBEID2,DCDF)
      BEIFU2=DP - DCDF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE BEIPDF(X,S1SQ,S2SQ,NU,IBEIDF,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE BESSEL I-FUNCTION
C              DISTRIBUTION.  IT HAS SHAPE PARAMETERS
C              SIGMA1, SIGMA2, AND NU.  THIS DISTRIBUTION IS DEFINED
C              FOR POSITIVE X AND HAS THE PROBABILITY DENSITY FUNCTION
C
C                 BEIPDF(X,S1AQ,S2SQ,NU) =
C                        K*X**M*EXP(-C*X/B)*PI*I(X/B,M)      X > 0
C              WITH
C                 B = 4*S1SQ**2*S2SQ**2/(S1SQ**2 - S2SQ**2)
C                 C = (S1SQ**2 + S2SQ**2)/(S1SQ**2 - S2SQ**2)
C                 M = 2*NU + 1
C              AND
C                 K = |1 - C**2|**(M+0.5)/[SQRT(PI)*2**M*b**(M+1)*
C                     GAMMA(M+0.5)]
C                 I(Z,N) IS THE MODIFIED BESSEL FUNCTION OF THE
C                        FIRST KIND
C                 GAMMA IS THE GAMMA FUNCTION
C
C     NOTE--ARGUMENTS TO THIS ROUTINE ARE IN DOUBLE PRECISION.
C     INPUT  ARGUMENTS--X       = THE DOUBLE PRECISION VALUE AT
C                                 WHICH THE PROBABILITY DENSITY
C                                 FUNCTION IS TO BE EVALUATED.
C                                 X SHOULD BE POSITIVE
C                     --S1SQ    = THE FIRST SHAPE PARAMETER
C                     --S2SQ    = THE SECOND SHAPE PARAMETER
C                     --NU      = THE THIRD SHAPE PARAMETER
C     OUTPUT ARGUMENTS--PDF     = THE DOUBLE PRECISION PROBABILITY
C                                 DENSITY FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION PROBABILITY DENSITY FUNCTION
C             VALUE PDF FOR THE BESSEL-I DISTRIBUTION
C             WITH SHAPE PARAMETERS = S1SQ, S2SQ, AND NU.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--DBESI.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--DEXP, DLOG.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISNAN, "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME I", SECOND EDITION,
C                 WILEY, 1994, PP. 50-53.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004.8
C     ORIGINAL VERSION--AUGUST    2004.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IBEIDF
C
      DOUBLE PRECISION X
      DOUBLE PRECISION NU
      DOUBLE PRECISION S1SQ
      DOUBLE PRECISION S2SQ
      DOUBLE PRECISION PDF
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
      DOUBLE PRECISION DTERM4
      DOUBLE PRECISION DTERM5
      DOUBLE PRECISION DC1
      DOUBLE PRECISION DC2
      DOUBLE PRECISION DC
      DOUBLE PRECISION DB
      DOUBLE PRECISION DM
      DOUBLE PRECISION DPI
CCCCC DOUBLE PRECISION DGAMMA
CCCCC EXTERNAL DGAMMA
      DOUBLE PRECISION DLNGAM
      EXTERNAL DLNGAM
C
      DOUBLE PRECISION DTEMP1(10)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----DATA STATEMENTS-------------------------------------------------
C
      DATA DPI / 3.14159265358979D+00/
C
C-----START POINT-----------------------------------------------------
C
C               *****************************************
C               **  STEP 1--                           **
C               **  CHECK FOR VALID PARAMETERS         **
C               *****************************************
C
      IF(IBEIDF.EQ.'1')THEN
        DB=4.0D0*S1SQ*S2SQ/(S1SQ - S2SQ)
        DC=(S1SQ + S2SQ)/(S1SQ - S2SQ)
        DM=2.0D0*NU + 1.0D0
      ELSE
        DB=S1SQ
        DC=S2SQ
        DM=NU
      ENDIF
C
      IF(DABS(DC).LE.1.0D0)THEN
        WRITE(ICOUT,9)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,10)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,11)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,12)S1SQ
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,13)S2SQ
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,14)DC
        CALL DPWRST('XXX','WRIT')
        PDF=0.0D0
        GOTO9000
      ENDIF
    9 FORMAT('***** ERROR: ABSOLUTE VALUE OF 1 - C**2 <= 1 ',
     1       'IN BEIPDF ROUTINE.')
   10 FORMAT('      C = (S1**2 + S2**2)/(S1**2 - S2**2) WHERE ',
     1       'S1**2 AND S2**2')
   11 FORMAT('      ARE THE FIRST AND SECOND SHAPE PARAMETERS, ',
     1       'RESPECTIVELY.')
   12 FORMAT('      VALUE OF S1**2 IS: ',G15.7)
   13 FORMAT('      VALUE OF S2**2 IS: ',G15.7)
   14 FORMAT('      VALUE OF C IS:     ',G15.7)
      IF(DC.GT.0.0D0 .AND. X.LE.0.0D0)THEN
        WRITE(ICOUT,24)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,25)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,48)X
        CALL DPWRST('XXX','WRIT')
        PDF=0.0D0
        GOTO9000
      ENDIF
   24 FORMAT('***** ERROR: VALUE OF THE INPUT ARGUMENT ',
     1       'IN BEIPDF ROUTINE IS NON-POSITIVE')
   25 FORMAT('      FOR THE CASE WHERE S1**2 > S2**2 (THESE ARE THE ',
     1       'FIRST AND SECOND SHAPE PARAMETERS).')
      IF(DC.LT.0.0D0 .AND. X.GE.0.0D0)THEN
        WRITE(ICOUT,34)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,35)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,48)X
        CALL DPWRST('XXX','WRIT')
        PDF=0.0D0
        GOTO9000
      ENDIF
   34 FORMAT('***** ERROR: VALUE OF THE INPUT ARGUMENT ',
     1       'IN BEIPDF ROUTINE IS NON-NEGATIVE')
   35 FORMAT('      FOR THE CASE WHERE S1**2 < S2**2 (THESE ARE THE ',
     1       'FIRST AND SECOND SHAPE PARAMETERS).')
      IF(S1SQ.LE.0.0D0)THEN
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,48)S1SQ
        CALL DPWRST('XXX','WRIT')
        PDF=0.0D0
        GOTO9000
      ENDIF
    5 FORMAT('***** ERROR: VALUE OF FIRST SHAPE PARAMETER (SIGMA1**2)',
     1       ' IN BEIPDF ROUTINE IS NON-POSITIVE.')
      IF(S2SQ.LE.0.0D0)THEN
        WRITE(ICOUT,6)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,48)S2SQ
        CALL DPWRST('XXX','WRIT')
        PDF=0.0D0
        GOTO9000
      ENDIF
    6 FORMAT('***** ERROR: VALUE OF SECOND SHAPE PARAMETER ',
     1       '(SIGMA2**2) IN BEIPDF ROUTINE IS NON-POSITIVE.')
      IF(IBEIDF.EQ.'1')THEN
        IF(NU.LE.-0.25D0)THEN
          WRITE(ICOUT,7)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,48)NU
          CALL DPWRST('XXX','WRIT')
          CDF=0.0D0
          GOTO9000
        ENDIF
      ELSE
        IF(DM.LE.0.5D0)THEN
          WRITE(ICOUT,8)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,48)DM
          CALL DPWRST('XXX','WRIT')
          CDF=0.0D0
          GOTO9000
        ENDIF
      ENDIF
    7 FORMAT('***** ERROR: VALUE OF THIRD SHAPE PARAMETER (NU) IN ',
     1       'BEIPDF ROUTINE IS < -0.25.')
    8 FORMAT('***** ERROR: VALUE OF THIRD SHAPE PARAMETER (M) IN ',
     1       'BEIPDF ROUTINE IS <= 0.5.')
C
   48 FORMAT('      VALUE OF ARGUMENT IS: ',G15.7)
C
C               *****************************************
C               **  STEP 2--                           **
C               **  COMPUTE THE DENSITY FUNCTION.  FOR **
C               **  BETTER NUMERICAL STABILITY, DO THE **
C               **  FOLLOWING:                         **
C               **  1) COMPUTE LOGARIGHMS.             **
C               **  2) COMPUTE THE SCALED VERSION OF   **
C               **     THE BESSEL FUNCTION (ADDS A     **
C               **     EXP(-X) TERM, SO DIVIDE RESULT  **
C               **     BY EXP(-X)                      **
C               *****************************************
C
C
C  COMPUTE BESSEL FUNCTION FIRST.  IF THIS IS 0, SET PDF TO
C  0 AND RETURN.
C
      IARG1=1
      ISCALE=1
      CALL DBESI(DABS(X/DB),DM,ISCALE,IARG1,DTEMP1,NZERO)
      DTERM3=DTEMP1(IARG1)
      IF(DTERM3.LE.0.0D0)THEN
        PDF=0.0D0
        GOTO9000
      ENDIF
      DTERM3=DLOG(DTERM3)
C
      DC1=(DM+0.5D0)*DLOG(DABS(1.0D0-DC**2)) + 0.5D0*DLOG(DPI)
      DC2=DM*DLOG(2.0D0) + (DM+1.0D0)*DLOG(DB) + DLNGAM(DM+0.5D0)
      DTERM1=DC1 - DC2
CCCCC DC1=DABS(1.0D0-DC**2)**(DM+0.5D0)
CCCCC DC2=DSQRT(DPI)*(2.0D0**DM)*(DB**(DM+1.0D0))*DGAMMA(DM+0.5D0)
CCCCC DTERM1=DLOG(DC1/DC2)
      DTERM2=DM*DLOG(X)
      DTERM4=-DC*X/DB
C
      DTERM5=DTERM1+DTERM2+DTERM4+DTERM3
      PDF=DEXP(DTERM5)
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE BEIPPF(P,S1SQ,S2SQ,NU,IBEIDF,PPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE BESSEL I-FUNCTION
C              DISTRIBUTION.  IT HAS SHAPE PARAMETERS S1SQ, S2SQ,
C              AND NU.  THIS DISTRIBUTION IS DEFINED FOR POSITIVE
C              X AND HAS THE PROBABILITY DENSITY FUNCTION
C
C                 BEIPDF(X,S1AQ,S2SQ,NU) =
C                        K*X**M*EXP(-C*X/B)*PI*I(X/B,M)      X > 0
C              WITH
C                 B = 4*S1SQ**2*S2SQ**2/(S1SQ**2 - S2SQ**2)
C                 C = (S1SQ**2 + S2SQ**2)/(S1SQ**2 - S2SQ**2)
C                 M = 2*NU + 1
C              AND
C                 K = |1 - C**2|**(M+0.5)/[SQRT(PI)*2**M*b**(M+1)*
C                     GAMMA(M+0.5)]
C                 I(Z,N) IS THE MODIFIED BESSEL FUNCTION OF THE
C                        FIRST KIND
C                 GAMMA IS THE GAMMA FUNCTION
C
C              THE PERCENT POINT FUNCTION IS COMPUTED BY NUMERICALLY
C              INVERTING THE BESSEL I-FUNCTION CUMULATIVE
C              DISTRIBUTION FUNCTION (WHICH IN TURN IS COMPUTED BY
C              NUMERICAL INTEGRATION OF THE PROBABILITYT DENSITY.
C
C     INPUT  ARGUMENTS--P       = THE DOUBLE PRECISION VALUE AT
C                                 WHICH THE PERCENT POINT
C                                 FUNCTION IS TO BE EVALUATED.
C                                 0 < P < 1
C                     --S1SQ    = THE FIRST SHAPE PARAMETER
C                     --S2SQ    = THE THIRD SHAPE PARAMETER
C                     --NU      = THE THIRD SHAPE PARAMETER
C     OUTPUT ARGUMENTS--PPF     = THE SINGLE PRECISION PERCENT POINT
C                                 FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PERCENT POINT FUNCTION
C             VALUE PPF FOR THE BESSEL I-FUNCTION
C             DISTRIBUTION WITH SHAPE PARAMETERS = S1SQ, S2SQ, NU.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--DFZERO.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, (1994), "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME 1", SECOND EDITION,
C                 WILEY, PP. 50-53.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004.8
C     ORIGINAL VERSION--AUGUST    2004.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IBEIDF
C
      DOUBLE PRECISION P
      DOUBLE PRECISION PTEMP
      DOUBLE PRECISION S1SQ
      DOUBLE PRECISION S2SQ
      DOUBLE PRECISION NU
      DOUBLE PRECISION PPF
      DOUBLE PRECISION DMEAN
      DOUBLE PRECISION DSD
      DOUBLE PRECISION DM
      DOUBLE PRECISION DB
      DOUBLE PRECISION DC
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
C
      DOUBLE PRECISION DTEMP1(10)
C
      DOUBLE PRECISION XUP
      DOUBLE PRECISION XUP2
      DOUBLE PRECISION XLOW
      DOUBLE PRECISION RE
      DOUBLE PRECISION AE
C
      DOUBLE PRECISION BEIFU2
      EXTERNAL BEIFU2
C
      DOUBLE PRECISION DP
      COMMON/BE2COM/DP
C
      DOUBLE PRECISION DS1SQ
      DOUBLE PRECISION DS2SQ
      DOUBLE PRECISION DANU
      CHARACTER*4 IBEID2
      COMMON/BEICOM/DS1SQ,DS2SQ,DANU,IBEID2
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C               *****************************************
C               **  STEP 1--                           **
C               **  CHECK FOR VALID PARAMETERS         **
C               *****************************************
C
      IF(P.LE.0.0D0 .OR. P.GE.1.0D0)THEN
        WRITE(ICOUT,3)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,4)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,48)P
        CALL DPWRST('XXX','WRIT')
        PPF=0.0D0
        GOTO9000
      ENDIF
    3 FORMAT('***** ERROR: VALUE OF INPUT ARGUMENT (P) IN ',
     1       'BEIPPF ROUTINE')
    4 FORMAT('      IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL.')
C
      IF(IBEIDF.EQ.'1')THEN
        DB=4.0D0*S1SQ*S2SQ/(S1SQ - S2SQ)
        DC=(S1SQ + S2SQ)/(S1SQ - S2SQ)
        DM=2.0D0*NU + 1.0D0
      ELSE
        DB=S1SQ
        DC=S2SQ
        DM=NU
      ENDIF
C
      IF(DABS(DC).LE.1.0D0)THEN
        WRITE(ICOUT,9)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,10)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,11)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,12)S1SQ
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,13)S2SQ
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,14)DC
        CALL DPWRST('XXX','WRIT')
        PPF=0.0D0
        GOTO9000
      ENDIF
    9 FORMAT('***** ERROR: ABSOLUTE VALUE OF 1 - C**2 <= 1 ',
     1       'IN BEIPPF ROUTINE.')
   10 FORMAT('      C = (S1**2 + S2**2)/(S1**2 - S2**2) WHERE ',
     1       'S1**2 AND S2**2')
   11 FORMAT('      ARE THE FIRST AND SECOND SHAPE PARAMETERS, ',
     1       'RESPECTIVELY.')
   12 FORMAT('      VALUE OF S1**2 IS: ',G15.7)
   13 FORMAT('      VALUE OF S2**2 IS: ',G15.7)
   14 FORMAT('      VALUE OF C IS:     ',G15.7)
      IF(S1SQ.LE.0.0D0)THEN
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,48)S1SQ
        CALL DPWRST('XXX','WRIT')
        PPF=0.0D0
        GOTO9000
      ENDIF
    5 FORMAT('***** ERROR: VALUE OF FIRST SHAPE PARAMETER (SIGMA1**2)',
     1       ' IN BEIPPF ROUTINE IS NON-POSITIVE.')
      IF(S2SQ.LE.0.0D0)THEN
        WRITE(ICOUT,6)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,48)S2SQ
        CALL DPWRST('XXX','WRIT')
        PPF=0.0D0
        GOTO9000
      ENDIF
    6 FORMAT('***** ERROR: VALUE OF SECOND SHAPE PARAMETER ',
     1       '(SIGMA2**2) IN BEIPPF ROUTINE IS NON-POSITIVE.')
      IF(IBEIDF.EQ.'1')THEN
        IF(NU.LE.-0.25D0)THEN
          WRITE(ICOUT,7)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,48)NU
          CALL DPWRST('XXX','WRIT')
          CDF=0.0D0
          GOTO9000
        ENDIF
      ELSE
        IF(DM.LE.0.5D0)THEN
          WRITE(ICOUT,8)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,48)DM
          CALL DPWRST('XXX','WRIT')
          CDF=0.0D0
          GOTO9000
        ENDIF
      ENDIF
    7 FORMAT('***** ERROR: VALUE OF THIRD SHAPE PARAMETER (NU) IN ',
     1       'BEICDF ROUTINE IS < -0.25.')
    8 FORMAT('***** ERROR: VALUE OF THIRD SHAPE PARAMETER (M) IN ',
     1       'BEICDF ROUTINE IS <= 0.5.')
   48 FORMAT('      VALUE OF ARGUMENT IS: ',G15.7)
C
C               *****************************************
C               **  STEP 2--                           **
C               **  COMPUTE THE PERCENT POINT FUNCTION.**
C               *****************************************
C
C  STEP 1: FIND BRACKETING INTERVAL.  LOWER BOUND IS ZERO.  START
C          WITH UPPER BOUND = MEAN:
C             MEAN=(2*M+1)*B*C/(C**2-1)
C          INCREMENT IN INTERVALS OF 1 STANDARD DEVIATION:
C             VARIANCE=2*M+1)*B**2*(C**2+1)/(C2-1)**2
C                      K(ANU)(SQRT(S2SQ*S1SQ))
C
      XLOW=1.0D-12
      CALL BEICDF(XLOW,S1SQ,S2SQ,NU,IBEIDF,PTEMP)
      IF(P.LE.PTEMP)THEN
        PPF=XLOW
        GOTO9000
      ENDIF
C
      DMEAN=(2.0D0*DM+1.0D0)*DB*DC/(DC**2-1.0D0)
      DSD=(2.0D0*DM+1.0D0)*DB*(DC**2+1.0D0)/(DC**2-1.0D0)**2
      IF(DSD.GE.0.0D0)DSD=DSQRT(DSD)
C
      MAXIT=1000
      NIT=0
C
      XUP2=DMEAN
  200 CONTINUE
        IF(NIT.GT.MAXIT)THEN
          PPF=0.0D0
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,131)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,133)
          CALL DPWRST('XXX','BUG ')
          GOTO9000
        ENDIF
        CALL BEICDF(XUP2,S1SQ,S2SQ,NU,IBEIDF,PTEMP)
        IF(PTEMP.GT.P)THEN
          XUP=XUP2
        ELSE
          XLOW=XUP2
          XUP2=XUP2 + DSD
          NIT=NIT+1
          GOTO200
        ENDIF
C
  300 CONTINUE
      AE=1.D-7
      RE=1.D-7
      DS1SQ=S1SQ
      DS2SQ=S2SQ
      DANU=NU
      DP=P
      CALL DFZERO(BEIFU2,XLOW,XUP,XUP,RE,AE,IFLAG)
C
      PPF=XLOW
C
      IF(IFLAG.EQ.2)THEN
C
C  NOTE: SUPPRESS THIS MESSAGE FOR NOW.
CCCCC   WRITE(ICOUT,999)
  999   FORMAT(1X)
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   WRITE(ICOUT,111)
CC111   FORMAT('***** WARNING FROM BEIPPF--')
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   WRITE(ICOUT,113)
CC113   FORMAT('      PPF VALUE MAY NOT BE COMPUTED TO DESIRED ',
CCCCC1         'TOLERANCE.')
CCCCC   CALL DPWRST('XXX','BUG ')
      ELSEIF(IFLAG.EQ.3)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,121)
  121   FORMAT('***** WARNING FROM BEIPPF--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,123)
  123   FORMAT('      PPF VALUE MAY BE NEAR A SINGULAR POINT.')
        CALL DPWRST('XXX','BUG ')
      ELSEIF(IFLAG.EQ.4)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,131)
  131   FORMAT('***** ERROR FROM BEIPPF--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,133)
  133   FORMAT('      APPROPRIATE BRACKETING INTERVAL NOT FOUND.')
        CALL DPWRST('XXX','BUG ')
      ELSEIF(IFLAG.EQ.5)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,141)
  141   FORMAT('***** WARNING FROM BEIPPF--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,143)
  143   FORMAT('      MAXIMUM ITERATIONS EXCEEDED.')
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE BEIRAN(N,S1SQ,S2SQ,NU,IBEIDF,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE BESSEL I-FUNCTION DISTRIBUTION WITH SHAPE
C              PARAMETERS S1SQ, S2SQ, AND NU.  THIS DISTRIBUTION IS
C              DEFINED FOR POSITIVE X AND HAS THE PROBABILITY DENSITY
C              FUNCTION
C
C                 BEIPDF(X,S1AQ,S2SQ,NU) =
C                        K*X**M*EXP(-C*X/B)*PI*I(X/B,M)      X > 0
C              WITH
C                 B = 4*S1SQ**2*S2SQ**2/(S1SQ**2 - S2SQ**2)
C                 C = (S1SQ**2 + S2SQ**2/(S1SQ**2 - S2SQ**2)
C                 M = 2*NU + 1
C              AND
C                 K = |1 - C**2|**(M+0.5)/[SQRT(PI)*2**M*b**(M+1)*
C                     GAMMA(M+0.5)]
C                 I(Z,N) IS THE MODIFIED BESSEL FUNCTION OF THE
C                        FIRST KIND
C                 GAMMA IS THE GAMMA FUNCTION
C
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --S1SQ   = THE FIRST SHAPE PARAMETER
C                     --S2SQ   = THE SECOND SHAPE PARAMETER
C                     --NU     = THE THIRD SHAPE PARAMETER
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST N)
C                                INTO WHICH THE GENERATED
C                                RANDOM SAMPLE WILL BE PLACED.
C     OUTPUT--A RANDOM SAMPLE OF SIZE N FROM THE BESSEL I-FUNCTION
C             DISTRIBUTION WITH SHAPE PARAMETERS S1SQ, S2SQ, AND NU.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--CHIRAN.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISNAN, "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME I", SECOND EDITION,
C                 WILEY, 1994, PP. 50-53.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004.8
C     ORIGINAL VERSION--AUGUST    2004.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IBEIDF
C
      DIMENSION X(*)
CCCCC DIMENSION Y(2)
      DOUBLE PRECISION DPPF
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----DATA STATEMENTS-------------------------------------------------
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)THEN
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,6)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
C
    5 FORMAT('***** ERROR--FOR THE BESSEL I-FUNCTION DISTRIBUTION, ',
     1       'THE REQUESTED')
    6 FORMAT('      NUMBER OF RANDOM NUMBERS WAS NON-POSITIVE.')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,'.')
C
      IF(IBEIDF.EQ.'1')THEN
        DB=4.0D0*S1SQ*S2SQ/(S1SQ - S2SQ)
        DC=(S1SQ + S2SQ)/(S1SQ - S2SQ)
        DM=2.0D0*NU + 1.0D0
      ELSE
        DB=S1SQ
        DC=S2SQ
        DM=NU
      ENDIF
C
      IF(ABS(DC).LE.1.0)THEN
        WRITE(ICOUT,9)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,10)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,11)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,12)S1SQ
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,13)S2SQ
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,14)DC
        CALL DPWRST('XXX','WRIT')
        GOTO9999
      ENDIF
    9 FORMAT('***** ERROR: ABSOLUTE VALUE OF 1 - C**2 <= 1 ',
     1       'IN BEIRAN ROUTINE.')
   10 FORMAT('      C = (S1**2 + S2**2)/(S1**2 - S2**2) WHERE ',
     1       'S1**2 AND S2**2')
   11 FORMAT('      ARE THE FIRST AND SECOND SHAPE PARAMETERS, ',
     1       'RESPECTIVELY.')
   12 FORMAT('      VALUE OF S1**2 IS: ',G15.7)
   13 FORMAT('      VALUE OF S2**2 IS: ',G15.7)
   14 FORMAT('      VALUE OF C IS:     ',G15.7)
      IF(S1SQ.LE.0.0)THEN
        WRITE(ICOUT,15)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,48)S1SQ
        CALL DPWRST('XXX','WRIT')
        GOTO9999
      ENDIF
   15 FORMAT('***** ERROR: VALUE OF FIRST SHAPE PARAMETER (SIGMA1**2)',
     1       ' IN BEIRAN ROUTINE IS NON-POSITIVE.')
      IF(S2SQ.LE.0.0)THEN
        WRITE(ICOUT,16)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,48)S2SQ
        CALL DPWRST('XXX','WRIT')
        GOTO9999
      ENDIF
   16 FORMAT('***** ERROR: VALUE OF SECOND SHAPE PARAMETER ',
     1       '(SIGMA2**2) IN BEIRAN ROUTINE IS NON-POSITIVE.')
      IF(IBEIDF.EQ.'1')THEN
        IF(NU.LE.-0.25D0)THEN
          WRITE(ICOUT,17)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,48)NU
          CALL DPWRST('XXX','WRIT')
          CDF=0.0D0
          GOTO9999
        ENDIF
      ELSE
        IF(DM.LE.0.5D0)THEN
          WRITE(ICOUT,18)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,48)DM
          CALL DPWRST('XXX','WRIT')
          CDF=0.0D0
          GOTO9999
        ENDIF
      ENDIF
   17 FORMAT('***** ERROR: VALUE OF THIRD SHAPE PARAMETER (NU) IN ',
     1       'BEIANF ROUTINE IS < -0.25.')
   18 FORMAT('***** ERROR: VALUE OF THIRD SHAPE PARAMETER (M) IN ',
     1       'BEIRAN ROUTINE IS <= 0.5.')
C
   48 FORMAT('      VALUE OF ARGUMENT IS: ',G15.7)
C
C     BESSEL I-FUNCTION IS DISTRIBUTION OF
C         S1SQ*X1 + S2SQ*X2
C     WHERE X1 AND X2 ARE CHI-SQUARE RANDOM NUMBERS WITH DEGREES
C     OF FREEDOM PARAMETERS NU.
C
C     NOTE: ABOVE ALGORITHM DOES NOT SEEM TO CORRESPOND TO
C           BESSEL I-FUNCTION PDF, SO FOR NOW USE PERCENT POINT
C           FUNCTION.
C
      CALL UNIRAN(N,ISEED,X)
CCCCC NTEMP=2
      DO100I=1,N
CCCCC   CALL CHSRAN(NTEMP,NU,ISEED,Y)
CCCCC   X(I)=S1SQ*Y(1) + S2SQ*Y(2)
        PTEMP=X(I)
        CALL BEIPPF(DBLE(PTEMP),DBLE(S1SQ),DBLE(S2SQ),DBLE(NU),
     1              IBEIDF,DPPF)
        X(I)=REAL(DPPF)
  100 CONTINUE
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE BERNOB(N,BN)
C
C       ======================================
C       Purpose: Compute Bernoulli number Bn
C       Input :  n --- Serial number
C       Output:  BN(n) --- Bn
C       ======================================
C
        IMPLICIT DOUBLE PRECISION (A-H,O-Z)
        DIMENSION BN(0:N)
C
      REAL CPUMIN, CPUMAX
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
        TPI=6.283185307179586D0 
        BN(0)=1.0D0
        BN(1)=-0.5D0
        BN(2)=1.0D0/6.0D0
        DO1I=3,N
        BN(I)=0.0D0
 1      CONTINUE
        IF(N.LE.3)RETURN
        R1=(2.0D0/TPI)**2
        IFLAG=0
        DO 20 M=4,N,2
           IF(IFLAG.EQ.1)THEN
             BN(M)=DBLE(CPUMAX)
             GOTO20
           ENDIF
           R1=-R1*(M-1)*M/(TPI*TPI)
           R2=1.0D0
           DO 10 K=2,10000
              S=(1.0D0/K)**M
              R2=R2+S
              IF (S.LT.1.0D-15) GOTO 29
10         CONTINUE
29         CONTINUE
           BN(M)=R1*R2
           IF(BN(M).GE.DBLE(CPUMAX))THEN
             WRITE(ICOUT,90)M
             CALL DPWRST('XXX','BUG')
 90          FORMAT('***** ERROR: BN OVERFLOWS AT N = ',I8)
             IFLAG=1
           ENDIF
 20     CONTINUE
        RETURN
        END
      SUBROUTINE BERNPN(X,N,BN)
C
C       ======================================
C       Purpose: Compute Bernoulli polynomial of order n for X
C       Input :  n --- Order of Bernoulli polynomial
C                x --- value at which to compute the polynomial
C       Output:  BN--- computed value
C       ======================================
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      DIMENSION DTEMP(200)
C
      REAL CPUMIN, CPUMAX
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      IF(N.EQ.0)THEN
        BN=0.D0
      ELSEIF(N.EQ.1)THEN
        BN=-0.5D0+X
      ELSE
        TERM1=X
        TERM2=DBLE(N-1)
        IF(X.EQ.0.0D0 .AND. N-1.EQ.0)THEN
          TERM3=1.0D0
        ELSE
          TERM3=X**(N-1)
        ENDIF
        SUM=TERM3*(X-REAL(N)/2.0D0)
        DO100I=1,N/2
          CALL BERNOB(2*I,DTEMP)
          TERM4=DTEMP(2*I+1)
          TERM5=DBINOM(N,2*I)
          SUM=SUM + TERM4*TERM5*TERM6
          IF(X.EQ.0.0D0 .AND. N-1.EQ.0)THEN
            TERM6=1.0D0
          ELSE
            TERM6=X**(N-2*I)
          ENDIF
  100   CONTINUE
        BN=SUM
      ENDIF
C
      RETURN
      END
      SUBROUTINE BESI (X, ALPHA, KODE, N, Y, NZ)
C***BEGIN PROLOGUE  BESI
C***PURPOSE  Compute an N member sequence of I Bessel functions
C            I/SUB(ALPHA+K-1)/(X), K=1,...,N or scaled Bessel functions
C            EXP(-X)*I/SUB(ALPHA+K-1)/(X), K=1,...,N for non-negative
C            ALPHA and X.
C***LIBRARY   SLATEC
C***CATEGORY  C10B3
C***TYPE      SINGLE PRECISION (BESI-S, DBESI-D)
C***KEYWORDS  I BESSEL FUNCTION, SPECIAL FUNCTIONS
C***AUTHOR  Amos, D. E., (SNLA)
C           Daniel, S. L., (SNLA)
C***DESCRIPTION
C
C     Abstract
C         BESI computes an N member sequence of I Bessel functions
C         I/sub(ALPHA+K-1)/(X), K=1,...,N or scaled Bessel functions
C         EXP(-X)*I/sub(ALPHA+K-1)/(X), K=1,...,N for non-negative ALPHA
C         and X.  A combination of the power series, the asymptotic
C         expansion for X to infinity, and the uniform asymptotic
C         expansion for NU to infinity are applied over subdivisions of
C         the (NU,X) plane.  For values not covered by one of these
C         formulae, the order is incremented by an integer so that one
C         of these formulae apply.  Backward recursion is used to reduce
C         orders by integer values.  The asymptotic expansion for X to
C         infinity is used only when the entire sequence (specifically
C         the last member) lies within the region covered by the
C         expansion.  Leading terms of these expansions are used to test
C         for over or underflow where appropriate.  If a sequence is
C         requested and the last member would underflow, the result is
C         set to zero and the next lower order tried, etc., until a
C         member comes on scale or all are set to zero.  An overflow
C         cannot occur with scaling.
C
C     Description of Arguments
C
C         Input
C           X      - X .GE. 0.0E0
C           ALPHA  - order of first member of the sequence,
C                    ALPHA .GE. 0.0E0
C           KODE   - a parameter to indicate the scaling option
C                    KODE=1 returns
C                           Y(K)=        I/sub(ALPHA+K-1)/(X),
C                                K=1,...,N
C                    KODE=2 returns
C                           Y(K)=EXP(-X)*I/sub(ALPHA+K-1)/(X),
C                                K=1,...,N
C           N      - number of members in the sequence, N .GE. 1
C
C         Output
C           Y      - a vector whose first N components contain
C                    values for I/sub(ALPHA+K-1)/(X) or scaled
C                    values for EXP(-X)*I/sub(ALPHA+K-1)/(X),
C                    K=1,...,N depending on KODE
C           NZ     - number of components of Y set to zero due to
C                    underflow,
C                    NZ=0   , normal return, computation completed
C                    NZ .NE. 0, last NZ components of Y set to zero,
C                             Y(K)=0.0E0, K=N-NZ+1,...,N.
C
C     Error Conditions
C         Improper input arguments - a fatal error
C         Overflow with KODE=1 - a fatal error
C         Underflow - a non-fatal error (NZ .NE. 0)
C
C***REFERENCES  D. E. Amos, S. L. Daniel and M. K. Weston, CDC 6600
C                 subroutines IBESS and JBESS for Bessel functions
C                 I(NU,X) and J(NU,X), X .GE. 0, NU .GE. 0, ACM
C                 Transactions on Mathematical Software 3, (1977),
C                 pp. 76-92.
C               F. W. J. Olver, Tables of Bessel Functions of Moderate
C                 or Large Orders, NPL Mathematical Tables 6, Her
C                 Majesty's Stationery Office, London, 1962.
C***ROUTINES CALLED  ALNGAM, ASYIK, I1MACH, R1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   750101  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  BESI
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C
      INTEGER I, IALP, IN, INLIM, IS, I1, K, KK, KM, KODE, KT,
     1 N, NN, NS, NZ
      REAL AIN, AK, AKM, ALPHA, ANS, AP, ARG, ATOL, TOLLN, DFN,
     1 DTM, DX, EARG, ELIM, ETX, FLGIK,FN, FNF, FNI,FNP1,FNU,GLN,RA,
     2 RTTPI, S, SX, SXO2, S1, S2, T, TA, TB, TEMP, TFN, TM, TOL,
     3 TRX, T2, X, XO2, XO2L, Y, Z
      DOUBLE PRECISION DLNGAM
      DIMENSION Y(*), TEMP(3)
      SAVE RTTPI, INLIM
      DATA RTTPI           / 3.98942280401433E-01/
      DATA INLIM           /          80         /
C***FIRST EXECUTABLE STATEMENT  BESI
      NZ = 0
      KT = 1
C     I1MACH(15) REPLACES I1MACH(12) IN A DOUBLE PRECISION CODE
C     I1MACH(14) REPLACES I1MACH(11) IN A DOUBLE PRECISION CODE
      RA = R1MACH(3)
      TOL = MAX(RA,1.0E-15)
      I1 = -I1MACH(12)
      GLN = R1MACH(5)
      ELIM = 2.303E0*(I1*GLN-3.0E0)
C     TOLLN = -LN(TOL)
      I1 = I1MACH(11)+1
      TOLLN = 2.303E0*GLN*I1
      TOLLN = MIN(TOLLN,34.5388E0)
      IF (N-1) 590, 10, 20
   10 KT = 2
   20 NN = N
      IF (KODE.LT.1 .OR. KODE.GT.2) GO TO 570
      IF (X) 600, 30, 80
   30 IF (ALPHA) 580, 40, 50
   40 Y(1) = 1.0E0
      IF (N.EQ.1) RETURN
      I1 = 2
      GO TO 60
   50 I1 = 1
   60 DO 70 I=I1,N
        Y(I) = 0.0E0
   70 CONTINUE
      RETURN
   80 CONTINUE
      IF (ALPHA.LT.0.0E0) GO TO 580
C
      IALP = INT(ALPHA)
      FNI = IALP + N - 1
      FNF = ALPHA - IALP
      DFN = FNI + FNF
      FNU = DFN
      IN = 0
      XO2 = X*0.5E0
      SXO2 = XO2*XO2
      ETX = KODE - 1
      SX = ETX*X
C
C     DECISION TREE FOR REGION WHERE SERIES, ASYMPTOTIC EXPANSION FOR X
C     TO INFINITY AND ASYMPTOTIC EXPANSION FOR NU TO INFINITY ARE
C     APPLIED.
C
      IF (SXO2.LE.(FNU+1.0E0)) GO TO 90
      IF (X.LE.12.0E0) GO TO 110
      FN = 0.55E0*FNU*FNU
      FN = MAX(17.0E0,FN)
      IF (X.GE.FN) GO TO 430
      ANS = MAX(36.0E0-FNU,0.0E0)
      NS = INT(ANS)
      FNI = FNI + NS
      DFN = FNI + FNF
      FN = DFN
      IS = KT
      KM = N - 1 + NS
      IF (KM.GT.0) IS = 3
      GO TO 120
   90 FN = FNU
      FNP1 = FN + 1.0E0
      XO2L = LOG(XO2)
      IS = KT
      IF (X.LE.0.5E0) GO TO 230
      NS = 0
  100 FNI = FNI + NS
      DFN = FNI + FNF
      FN = DFN
      FNP1 = FN + 1.0E0
      IS = KT
      IF (N-1+NS.GT.0) IS = 3
      GO TO 230
  110 XO2L = LOG(XO2)
      NS = INT(SXO2-FNU)
      GO TO 100
  120 CONTINUE
C
C     OVERFLOW TEST ON UNIFORM ASYMPTOTIC EXPANSION
C
      IF (KODE.EQ.2) GO TO 130
      IF (ALPHA.LT.1.0E0) GO TO 150
      Z = X/ALPHA
      RA = SQRT(1.0E0+Z*Z)
      GLN = LOG((1.0E0+RA)/Z)
      T = RA*(1.0E0-ETX) + ETX/(Z+RA)
      ARG = ALPHA*(T-GLN)
      IF (ARG.GT.ELIM) GO TO 610
      IF (KM.EQ.0) GO TO 140
  130 CONTINUE
C
C     UNDERFLOW TEST ON UNIFORM ASYMPTOTIC EXPANSION
C
      Z = X/FN
      RA = SQRT(1.0E0+Z*Z)
      GLN = LOG((1.0E0+RA)/Z)
      T = RA*(1.0E0-ETX) + ETX/(Z+RA)
      ARG = FN*(T-GLN)
  140 IF (ARG.LT.(-ELIM)) GO TO 280
      GO TO 190
  150 IF (X.GT.ELIM) GO TO 610
      GO TO 130
C
C     UNIFORM ASYMPTOTIC EXPANSION FOR NU TO INFINITY
C
  160 IF (KM.NE.0) GO TO 170
      Y(1) = TEMP(3)
      RETURN
  170 TEMP(1) = TEMP(3)
      IN = NS
      KT = 1
      I1 = 0
  180 CONTINUE
      IS = 2
      FNI = FNI - 1.0E0
      DFN = FNI + FNF
      FN = DFN
      IF(I1.EQ.2) GO TO 350
      Z = X/FN
      RA = SQRT(1.0E0+Z*Z)
      GLN = LOG((1.0E0+RA)/Z)
      T = RA*(1.0E0-ETX) + ETX/(Z+RA)
      ARG = FN*(T-GLN)
  190 CONTINUE
      I1 = ABS(3-IS)
      I1 = MAX(I1,1)
      FLGIK = 1.0E0
      CALL ASYIK(X,FN,KODE,FLGIK,RA,ARG,I1,TEMP(IS))
      GO TO (180, 350, 510), IS
C
C     SERIES FOR (X/2)**2.LE.NU+1
C
  230 CONTINUE
      GLN = REAL(DLNGAM(DBLE(FNP1)))
      ARG = FN*XO2L - GLN - SX
      IF (ARG.LT.(-ELIM)) GO TO 300
      EARG = EXP(ARG)
  240 CONTINUE
      S = 1.0E0
      IF (X.LT.TOL) GO TO 260
      AK = 3.0E0
      T2 = 1.0E0
      T = 1.0E0
      S1 = FN
      DO 250 K=1,17
        S2 = T2 + S1
        T = T*SXO2/S2
        S = S + T
        IF (ABS(T).LT.TOL) GO TO 260
        T2 = T2 + AK
        AK = AK + 2.0E0
        S1 = S1 + FN
  250 CONTINUE
  260 CONTINUE
      TEMP(IS) = S*EARG
      GO TO (270, 350, 500), IS
  270 EARG = EARG*FN/XO2
      FNI = FNI - 1.0E0
      DFN = FNI + FNF
      FN = DFN
      IS = 2
      GO TO 240
C
C     SET UNDERFLOW VALUE AND UPDATE PARAMETERS
C
  280 Y(NN) = 0.0E0
      NN = NN - 1
      FNI = FNI - 1.0E0
      DFN = FNI + FNF
      FN = DFN
      IF (NN-1) 340, 290, 130
  290 KT = 2
      IS = 2
      GO TO 130
  300 Y(NN) = 0.0E0
      NN = NN - 1
      FNP1 = FN
      FNI = FNI - 1.0E0
      DFN = FNI + FNF
      FN = DFN
      IF (NN-1) 340, 310, 320
  310 KT = 2
      IS = 2
  320 IF (SXO2.LE.FNP1) GO TO 330
      GO TO 130
  330 ARG = ARG - XO2L + LOG(FNP1)
      IF (ARG.LT.(-ELIM)) GO TO 300
      GO TO 230
  340 NZ = N - NN
      RETURN
C
C     BACKWARD RECURSION SECTION
C
  350 CONTINUE
      NZ = N - NN
  360 CONTINUE
      IF(KT.EQ.2) GO TO 420
      S1 = TEMP(1)
      S2 = TEMP(2)
      TRX = 2.0E0/X
      DTM = FNI
      TM = (DTM+FNF)*TRX
      IF (IN.EQ.0) GO TO 390
C     BACKWARD RECUR TO INDEX ALPHA+NN-1
      DO 380 I=1,IN
        S = S2
        S2 = TM*S2 + S1
        S1 = S
        DTM = DTM - 1.0E0
        TM = (DTM+FNF)*TRX
  380 CONTINUE
      Y(NN) = S1
      IF (NN.EQ.1) RETURN
      Y(NN-1) = S2
      IF (NN.EQ.2) RETURN
      GO TO 400
  390 CONTINUE
C     BACKWARD RECUR FROM INDEX ALPHA+NN-1 TO ALPHA
      Y(NN) = S1
      Y(NN-1) = S2
      IF (NN.EQ.2) RETURN
  400 K = NN + 1
      DO 410 I=3,NN
        K = K - 1
        Y(K-2) = TM*Y(K-1) + Y(K)
        DTM = DTM - 1.0E0
        TM = (DTM+FNF)*TRX
  410 CONTINUE
      RETURN
  420 Y(1) = TEMP(2)
      RETURN
C
C     ASYMPTOTIC EXPANSION FOR X TO INFINITY
C
  430 CONTINUE
      EARG = RTTPI/SQRT(X)
      IF (KODE.EQ.2) GO TO 440
      IF (X.GT.ELIM) GO TO 610
      EARG = EARG*EXP(X)
  440 ETX = 8.0E0*X
      IS = KT
      IN = 0
      FN = FNU
  450 DX = FNI + FNI
      TM = 0.0E0
      IF (FNI.EQ.0.0E0 .AND. ABS(FNF).LT.TOL) GO TO 460
      TM = 4.0E0*FNF*(FNI+FNI+FNF)
  460 CONTINUE
      DTM = DX*DX
      S1 = ETX
      TRX = DTM - 1.0E0
      DX = -(TRX+TM)/ETX
      T = DX
      S = 1.0E0 + DX
      ATOL = TOL*ABS(S)
      S2 = 1.0E0
      AK = 8.0E0
      DO 470 K=1,25
        S1 = S1 + ETX
        S2 = S2 + AK
        DX = DTM - S2
        AP = DX + TM
        T = -T*AP/S1
        S = S + T
        IF (ABS(T).LE.ATOL) GO TO 480
        AK = AK + 8.0E0
  470 CONTINUE
  480 TEMP(IS) = S*EARG
      IF(IS.EQ.2) GO TO 360
      IS = 2
      FNI = FNI - 1.0E0
      DFN = FNI + FNF
      FN = DFN
      GO TO 450
C
C     BACKWARD RECURSION WITH NORMALIZATION BY
C     ASYMPTOTIC EXPANSION FOR NU TO INFINITY OR POWER SERIES.
C
  500 CONTINUE
C     COMPUTATION OF LAST ORDER FOR SERIES NORMALIZATION
      AKM = MAX(3.0E0-FN,0.0E0)
      KM = INT(AKM)
      TFN = FN + KM
      TA = (GLN+TFN-0.9189385332E0-0.0833333333E0/TFN)/(TFN+0.5E0)
      TA = XO2L - TA
      TB = -(1.0E0-1.0E0/TFN)/TFN
      AIN = TOLLN/(-TA+SQRT(TA*TA-TOLLN*TB)) + 1.5E0
      IN = INT(AIN)
      IN = IN + KM
      GO TO 520
  510 CONTINUE
C     COMPUTATION OF LAST ORDER FOR ASYMPTOTIC EXPANSION NORMALIZATION
      T = 1.0E0/(FN*RA)
      AIN = TOLLN/(GLN+SQRT(GLN*GLN+T*TOLLN)) + 1.5E0
      IN = INT(AIN)
      IF (IN.GT.INLIM) GO TO 160
  520 CONTINUE
      TRX = 2.0E0/X
      DTM = FNI + IN
      TM = (DTM+FNF)*TRX
      TA = 0.0E0
      TB = TOL
      KK = 1
  530 CONTINUE
C
C     BACKWARD RECUR UNINDEXED
C
      DO 540 I=1,IN
        S = TB
        TB = TM*TB + TA
        TA = S
        DTM = DTM - 1.0E0
        TM = (DTM+FNF)*TRX
  540 CONTINUE
C     NORMALIZATION
      IF (KK.NE.1) GO TO 550
      TA = (TA/TB)*TEMP(3)
      TB = TEMP(3)
      KK = 2
      IN = NS
      IF (NS.NE.0) GO TO 530
  550 Y(NN) = TB
      NZ = N - NN
      IF (NN.EQ.1) RETURN
      TB = TM*TB + TA
      K = NN - 1
      Y(K) = TB
      IF (NN.EQ.2) RETURN
      DTM = DTM - 1.0E0
      TM = (DTM+FNF)*TRX
      KM = K - 1
C
C     BACKWARD RECUR INDEXED
C
      DO 560 I=1,KM
        Y(K-1) = TM*Y(K) + Y(K+1)
        DTM = DTM - 1.0E0
        TM = (DTM+FNF)*TRX
        K = K - 1
  560 CONTINUE
      RETURN
C
C
C
  570 CONTINUE
      WRITE(ICOUT,571)
  571 FORMAT('***** ERORR FROM BESI, KODE IS NOT 1 OR 2. ***')
      CALL DPWRST('XXX','BUG ')
      RETURN
  580 CONTINUE
      WRITE(ICOUT,581)
  581 FORMAT('***** ERORR FROM BESI, THE ORDER ALPHA IS NEGATIVE. ***')
      CALL DPWRST('XXX','BUG ')
      RETURN
  590 CONTINUE
      WRITE(ICOUT,591)
  591 FORMAT('***** ERORR FROM BESI, N IS LESS THAN ONE.. ***')
      CALL DPWRST('XXX','BUG ')
      RETURN
  600 CONTINUE
      WRITE(ICOUT,601)
  601 FORMAT('***** ERORR FROM BESI, X IS LESS THAN ZERO.. ***')
      CALL DPWRST('XXX','BUG ')
      RETURN
  610 CONTINUE
      WRITE(ICOUT,611)
  611 FORMAT('**** ERORR FROM BESI, OVERFLOW BECAUSE X IS TOO BIG.. *')
      CALL DPWRST('XXX','BUG ')
      RETURN
      END
      FUNCTION BESI0 (X)
C***BEGIN PROLOGUE  BESI0
C***PURPOSE  Compute the hyperbolic Bessel function of the first kind
C            of order zero.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C10B1
C***TYPE      SINGLE PRECISION (BESI0-S, DBESI0-D)
C***KEYWORDS  FIRST KIND, FNLIB, HYPERBOLIC BESSEL FUNCTION,
C             MODIFIED BESSEL FUNCTION, ORDER ZERO, SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C BESI0(X) computes the modified (hyperbolic) Bessel function
C of the first kind of order zero and real argument X.
C
C Series for BI0        on the interval  0.          to  9.00000D+00
C                                        with weighted error   2.46E-18
C                                         log weighted error  17.61
C                               significant figures required  17.90
C                                    decimal places required  18.15
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  BESI0E, CSEVL, INITS, R1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770401  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C***END PROLOGUE  BESI0
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DIMENSION BI0CS(12)
      LOGICAL FIRST
      SAVE BI0CS, NTI0, XSML, XMAX, FIRST
      DATA BI0CS( 1) /   -.0766054725 2839144951E0 /
      DATA BI0CS( 2) /   1.9273379539 93808270E0 /
      DATA BI0CS( 3) /    .2282644586 920301339E0 /
      DATA BI0CS( 4) /    .0130489146 6707290428E0 /
      DATA BI0CS( 5) /    .0004344270 9008164874E0 /
      DATA BI0CS( 6) /    .0000094226 5768600193E0 /
      DATA BI0CS( 7) /    .0000001434 0062895106E0 /
      DATA BI0CS( 8) /    .0000000016 1384906966E0 /
      DATA BI0CS( 9) /    .0000000000 1396650044E0 /
      DATA BI0CS(10) /    .0000000000 0009579451E0 /
      DATA BI0CS(11) /    .0000000000 0000053339E0 /
      DATA BI0CS(12) /    .0000000000 0000000245E0 /
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  BESI0
      IF (FIRST) THEN
         NTI0 = INITS (BI0CS, 12, 0.1*R1MACH(3))
         XSML = SQRT (4.5*R1MACH(3))
         XMAX = LOG (R1MACH(2))
      ENDIF
      FIRST = .FALSE.
C
      Y = ABS(X)
      IF (Y.GT.3.0) GO TO 20
C
      BESI0 = 1.0
      IF (Y.GT.XSML) BESI0 = 2.75 + CSEVL (Y*Y/4.5-1.0, BI0CS, NTI0)
      RETURN
C
 20   CONTINUE
      IF (Y.GT.XMAX) THEN
        WRITE(ICOUT,1)
        CALL DPWRST('XXX','BUG ')
        BESI0 = 0.0
        RETURN
      ENDIF
    1 FORMAT('***** ERORR FROM BESI0, OVERFLOW BECAUSE THE ',
     1       'ABSOLUTE VALUE OF X IS TOO BIG.  ****')
C
      BESI0 = EXP(Y) * BESI0E(X)
C
      RETURN
      END
      FUNCTION BESI0E (X)
C***BEGIN PROLOGUE  BESI0E
C***PURPOSE  Compute the exponentially scaled modified (hyperbolic)
C            Bessel function of the first kind of order zero.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C10B1
C***TYPE      SINGLE PRECISION (BESI0E-S, DBSI0E-D)
C***KEYWORDS  EXPONENTIALLY SCALED, FIRST KIND, FNLIB,
C             HYPERBOLIC BESSEL FUNCTION, MODIFIED BESSEL FUNCTION,
C             ORDER ZERO, SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C BESI0E(X) calculates the exponentially scaled modified (hyperbolic)
C Bessel function of the first kind of order zero for real argument X;
C i.e., EXP(-ABS(X))*I0(X).
C
C
C Series for BI0        on the interval  0.          to  9.00000D+00
C                                        with weighted error   2.46E-18
C                                         log weighted error  17.61
C                               significant figures required  17.90
C                                    decimal places required  18.15
C
C
C Series for AI0        on the interval  1.25000D-01 to  3.33333D-01
C                                        with weighted error   7.87E-17
C                                         log weighted error  16.10
C                               significant figures required  14.69
C                                    decimal places required  16.76
C
C
C Series for AI02       on the interval  0.          to  1.25000D-01
C                                        with weighted error   3.79E-17
C                                         log weighted error  16.42
C                               significant figures required  14.86
C                                    decimal places required  17.09
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  CSEVL, INITS, R1MACH
C***REVISION HISTORY  (YYMMDD)
C   770701  DATE WRITTEN
C   890313  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C***END PROLOGUE  BESI0E
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DIMENSION BI0CS(12), AI0CS(21), AI02CS(22)
      LOGICAL FIRST
      SAVE BI0CS, AI0CS, AI02CS, NTI0, NTAI0, NTAI02, XSML, FIRST
      DATA BI0CS( 1) /   -.0766054725 2839144951E0 /
      DATA BI0CS( 2) /   1.9273379539 93808270E0 /
      DATA BI0CS( 3) /    .2282644586 920301339E0 /
      DATA BI0CS( 4) /    .0130489146 6707290428E0 /
      DATA BI0CS( 5) /    .0004344270 9008164874E0 /
      DATA BI0CS( 6) /    .0000094226 5768600193E0 /
      DATA BI0CS( 7) /    .0000001434 0062895106E0 /
      DATA BI0CS( 8) /    .0000000016 1384906966E0 /
      DATA BI0CS( 9) /    .0000000000 1396650044E0 /
      DATA BI0CS(10) /    .0000000000 0009579451E0 /
      DATA BI0CS(11) /    .0000000000 0000053339E0 /
      DATA BI0CS(12) /    .0000000000 0000000245E0 /
      DATA AI0CS( 1) /    .0757599449 4023796E0 /
      DATA AI0CS( 2) /    .0075913808 1082334E0 /
      DATA AI0CS( 3) /    .0004153131 3389237E0 /
      DATA AI0CS( 4) /    .0000107007 6463439E0 /
      DATA AI0CS( 5) /   -.0000079011 7997921E0 /
      DATA AI0CS( 6) /   -.0000007826 1435014E0 /
      DATA AI0CS( 7) /    .0000002783 8499429E0 /
      DATA AI0CS( 8) /    .0000000082 5247260E0 /
      DATA AI0CS( 9) /   -.0000000120 4463945E0 /
      DATA AI0CS(10) /    .0000000015 5964859E0 /
      DATA AI0CS(11) /    .0000000002 2925563E0 /
      DATA AI0CS(12) /   -.0000000001 1916228E0 /
      DATA AI0CS(13) /    .0000000000 1757854E0 /
      DATA AI0CS(14) /    .0000000000 0112822E0 /
      DATA AI0CS(15) /   -.0000000000 0114684E0 /
      DATA AI0CS(16) /    .0000000000 0027155E0 /
      DATA AI0CS(17) /   -.0000000000 0002415E0 /
      DATA AI0CS(18) /   -.0000000000 0000608E0 /
      DATA AI0CS(19) /    .0000000000 0000314E0 /
      DATA AI0CS(20) /   -.0000000000 0000071E0 /
      DATA AI0CS(21) /    .0000000000 0000007E0 /
      DATA AI02CS( 1) /    .0544904110 1410882E0 /
      DATA AI02CS( 2) /    .0033691164 7825569E0 /
      DATA AI02CS( 3) /    .0000688975 8346918E0 /
      DATA AI02CS( 4) /    .0000028913 7052082E0 /
      DATA AI02CS( 5) /    .0000002048 9185893E0 /
      DATA AI02CS( 6) /    .0000000226 6668991E0 /
      DATA AI02CS( 7) /    .0000000033 9623203E0 /
      DATA AI02CS( 8) /    .0000000004 9406022E0 /
      DATA AI02CS( 9) /    .0000000000 1188914E0 /
      DATA AI02CS(10) /   -.0000000000 3149915E0 /
      DATA AI02CS(11) /   -.0000000000 1321580E0 /
      DATA AI02CS(12) /   -.0000000000 0179419E0 /
      DATA AI02CS(13) /    .0000000000 0071801E0 /
      DATA AI02CS(14) /    .0000000000 0038529E0 /
      DATA AI02CS(15) /    .0000000000 0001539E0 /
      DATA AI02CS(16) /   -.0000000000 0004151E0 /
      DATA AI02CS(17) /   -.0000000000 0000954E0 /
      DATA AI02CS(18) /    .0000000000 0000382E0 /
      DATA AI02CS(19) /    .0000000000 0000176E0 /
      DATA AI02CS(20) /   -.0000000000 0000034E0 /
      DATA AI02CS(21) /   -.0000000000 0000027E0 /
      DATA AI02CS(22) /    .0000000000 0000003E0 /
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  BESI0E
      IF (FIRST) THEN
         NTI0 = INITS (BI0CS, 12, 0.1*R1MACH(3))
         NTAI0 = INITS (AI0CS, 21, 0.1*R1MACH(3))
         NTAI02 = INITS (AI02CS, 22, 0.1*R1MACH(3))
         XSML = SQRT (4.5*R1MACH(3))
      ENDIF
      FIRST = .FALSE.
C
      Y = ABS(X)
      IF (Y.GT.3.0) GO TO 20
C
      BESI0E = 1.0 - X
      IF (Y.GT.XSML) BESI0E = EXP(-Y) * ( 2.75 +
     1  CSEVL (Y*Y/4.5-1.0, BI0CS, NTI0) )
      RETURN
C
 20   IF (Y.LE.8.) BESI0E = (.375 + CSEVL ((48./Y-11.)/5., AI0CS, NTAI0)
     1  ) / SQRT(Y)
      IF (Y.GT.8.) BESI0E = (.375 + CSEVL (16./Y-1., AI02CS, NTAI02))
     1  / SQRT(Y)
C
      RETURN
      END
      FUNCTION BESI1 (X)
C***BEGIN PROLOGUE  BESI1
C***PURPOSE  Compute the modified (hyperbolic) Bessel function of the
C            first kind of order one.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C10B1
C***TYPE      SINGLE PRECISION (BESI1-S, DBESI1-D)
C***KEYWORDS  FIRST KIND, FNLIB, HYPERBOLIC BESSEL FUNCTION,
C             MODIFIED BESSEL FUNCTION, ORDER ONE, SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C BESI1(X) calculates the modified (hyperbolic) Bessel function
C of the first kind of order one for real argument X.
C
C Series for BI1        on the interval  0.          to  9.00000D+00
C                                        with weighted error   2.40E-17
C                                         log weighted error  16.62
C                               significant figures required  16.23
C                                    decimal places required  17.14
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  BESI1E, CSEVL, INITS, R1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770401  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C***END PROLOGUE  BESI1
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DIMENSION BI1CS(11)
      LOGICAL FIRST
      SAVE BI1CS, NTI1, XMIN, XSML, XMAX, FIRST
      DATA BI1CS( 1) /   -.0019717132 61099859E0 /
      DATA BI1CS( 2) /    .4073488766 7546481E0 /
      DATA BI1CS( 3) /    .0348389942 99959456E0 /
      DATA BI1CS( 4) /    .0015453945 56300123E0 /
      DATA BI1CS( 5) /    .0000418885 21098377E0 /
      DATA BI1CS( 6) /    .0000007649 02676483E0 /
      DATA BI1CS( 7) /    .0000000100 42493924E0 /
      DATA BI1CS( 8) /    .0000000000 99322077E0 /
      DATA BI1CS( 9) /    .0000000000 00766380E0 /
      DATA BI1CS(10) /    .0000000000 00004741E0 /
      DATA BI1CS(11) /    .0000000000 00000024E0 /
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  BESI1
      IF (FIRST) THEN
         NTI1 = INITS (BI1CS, 11, 0.1*R1MACH(3))
         XMIN = 2.0*R1MACH(1)
         XSML = SQRT (4.5*R1MACH(3))
         XMAX = LOG (R1MACH(2))
      ENDIF
      FIRST = .FALSE.
C
      Y = ABS(X)
      IF (Y.GT.3.0) GO TO 20
C
      BESI1 = 0.0
      IF (Y.EQ.0.0)  RETURN
C
      IF (Y .LE. XMIN) THEN
        WRITE(ICOUT,2)
        CALL DPWRST('XXX','BUG ')
      ENDIF
    2 FORMAT('***** WARNING FROM BESI1, UNDERFLOW BECAUSE THE ',
     1       'ABSOLUTE VALUE OF X IS SO SMALL.  ****')
      IF (Y.GT.XMIN)BESI1 = 0.5*X
      IF (Y.GT.XSML)BESI1 = X * (.875 + CSEVL(Y*Y/4.5-1., BI1CS, NTI1))
      RETURN
C
 20   CONTINUE
      IF (Y.GT.XMAX) THEN
        WRITE(ICOUT,1)
        CALL DPWRST('XXX','BUG ')
        BESI1 = 0.0
        RETURN
      ENDIF
    1 FORMAT('***** ERORR FROM BESI1, OVERFLOW BECAUSE THE ',
     1       'ABSOLUTE VALUE OF X IS TOO BIG.  ****')
C
      BESI1 = EXP(Y) * BESI1E(X)
C
      RETURN
      END
      FUNCTION BESI1E (X)
C***BEGIN PROLOGUE  BESI1E
C***PURPOSE  Compute the exponentially scaled modified (hyperbolic)
C            Bessel function of the first kind of order one.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C10B1
C***TYPE      SINGLE PRECISION (BESI1E-S, DBSI1E-D)
C***KEYWORDS  EXPONENTIALLY SCALED, FIRST KIND, FNLIB,
C             HYPERBOLIC BESSEL FUNCTION, MODIFIED BESSEL FUNCTION,
C             ORDER ONE, SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C BESI1E(X) calculates the exponentially scaled modified (hyperbolic)
C Bessel function of the first kind of order one for real argument X;
C i.e., EXP(-ABS(X))*I1(X).
C
C Series for BI1        on the interval  0.          to  9.00000D+00
C                                        with weighted error   2.40E-17
C                                         log weighted error  16.62
C                               significant figures required  16.23
C                                    decimal places required  17.14
C
C Series for AI1        on the interval  1.25000D-01 to  3.33333D-01
C                                        with weighted error   6.98E-17
C                                         log weighted error  16.16
C                               significant figures required  14.53
C                                    decimal places required  16.82
C
C Series for AI12       on the interval  0.          to  1.25000D-01
C                                        with weighted error   3.55E-17
C                                         log weighted error  16.45
C                               significant figures required  14.69
C                                    decimal places required  17.12
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  CSEVL, INITS, R1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770401  DATE WRITTEN
C   890210  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   920618  Removed space from variable names.  (RWC, WRB)
C***END PROLOGUE  BESI1E
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DIMENSION BI1CS(11), AI1CS(21), AI12CS(22)
      LOGICAL FIRST
      SAVE BI1CS, AI1CS, AI12CS, NTI1, NTAI1, NTAI12, XMIN, XSML, FIRST
      DATA BI1CS( 1) /   -.0019717132 61099859E0 /
      DATA BI1CS( 2) /    .4073488766 7546481E0 /
      DATA BI1CS( 3) /    .0348389942 99959456E0 /
      DATA BI1CS( 4) /    .0015453945 56300123E0 /
      DATA BI1CS( 5) /    .0000418885 21098377E0 /
      DATA BI1CS( 6) /    .0000007649 02676483E0 /
      DATA BI1CS( 7) /    .0000000100 42493924E0 /
      DATA BI1CS( 8) /    .0000000000 99322077E0 /
      DATA BI1CS( 9) /    .0000000000 00766380E0 /
      DATA BI1CS(10) /    .0000000000 00004741E0 /
      DATA BI1CS(11) /    .0000000000 00000024E0 /
      DATA AI1CS( 1) /   -.0284674418 1881479E0 /
      DATA AI1CS( 2) /   -.0192295323 1443221E0 /
      DATA AI1CS( 3) /   -.0006115185 8579437E0 /
      DATA AI1CS( 4) /   -.0000206997 1253350E0 /
      DATA AI1CS( 5) /    .0000085856 1914581E0 /
      DATA AI1CS( 6) /    .0000010494 9824671E0 /
      DATA AI1CS( 7) /   -.0000002918 3389184E0 /
      DATA AI1CS( 8) /   -.0000000155 9378146E0 /
      DATA AI1CS( 9) /    .0000000131 8012367E0 /
      DATA AI1CS(10) /   -.0000000014 4842341E0 /
      DATA AI1CS(11) /   -.0000000002 9085122E0 /
      DATA AI1CS(12) /    .0000000001 2663889E0 /
      DATA AI1CS(13) /   -.0000000000 1664947E0 /
      DATA AI1CS(14) /   -.0000000000 0166665E0 /
      DATA AI1CS(15) /    .0000000000 0124260E0 /
      DATA AI1CS(16) /   -.0000000000 0027315E0 /
      DATA AI1CS(17) /    .0000000000 0002023E0 /
      DATA AI1CS(18) /    .0000000000 0000730E0 /
      DATA AI1CS(19) /   -.0000000000 0000333E0 /
      DATA AI1CS(20) /    .0000000000 0000071E0 /
      DATA AI1CS(21) /   -.0000000000 0000006E0 /
      DATA AI12CS( 1) /    .0285762350 1828014E0 /
      DATA AI12CS( 2) /   -.0097610974 9136147E0 /
      DATA AI12CS( 3) /   -.0001105889 3876263E0 /
      DATA AI12CS( 4) /   -.0000038825 6480887E0 /
      DATA AI12CS( 5) /   -.0000002512 2362377E0 /
      DATA AI12CS( 6) /   -.0000000263 1468847E0 /
      DATA AI12CS( 7) /   -.0000000038 3538039E0 /
      DATA AI12CS( 8) /   -.0000000005 5897433E0 /
      DATA AI12CS( 9) /   -.0000000000 1897495E0 /
      DATA AI12CS(10) /    .0000000000 3252602E0 /
      DATA AI12CS(11) /    .0000000000 1412580E0 /
      DATA AI12CS(12) /    .0000000000 0203564E0 /
      DATA AI12CS(13) /   -.0000000000 0071985E0 /
      DATA AI12CS(14) /   -.0000000000 0040836E0 /
      DATA AI12CS(15) /   -.0000000000 0002101E0 /
      DATA AI12CS(16) /    .0000000000 0004273E0 /
      DATA AI12CS(17) /    .0000000000 0001041E0 /
      DATA AI12CS(18) /   -.0000000000 0000382E0 /
      DATA AI12CS(19) /   -.0000000000 0000186E0 /
      DATA AI12CS(20) /    .0000000000 0000033E0 /
      DATA AI12CS(21) /    .0000000000 0000028E0 /
      DATA AI12CS(22) /   -.0000000000 0000003E0 /
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  BESI1E
      IF (FIRST) THEN
         NTI1 = INITS (BI1CS, 11, 0.1*R1MACH(3))
         NTAI1 = INITS (AI1CS, 21, 0.1*R1MACH(3))
         NTAI12 = INITS (AI12CS, 22, 0.1*R1MACH(3))
C
         XMIN = 2.0*R1MACH(1)
         XSML = SQRT (4.5*R1MACH(3))
      ENDIF
      FIRST = .FALSE.
C
      Y = ABS(X)
      IF (Y.GT.3.0) GO TO 20
C
      BESI1E = 0.0
      IF (Y.EQ.0.0)  RETURN
C
      IF (Y .LE. XMIN) THEN
        WRITE(ICOUT,1)
        CALL DPWRST('XXX','BUG ')
      ENDIF
    1 FORMAT('***** WARNING FROM BESI1E, UNDERFLOW BECAUSE THE ',
     1       'ABSOLUTE VALUE OF X IS SO SMALL.  ****')
      IF (Y.GT.XMIN) BESI1E = 0.5*X
      IF (Y.GT.XSML) BESI1E = X * (.875 + CSEVL(Y*Y/4.5-1., BI1CS,NTI1))
      BESI1E = EXP(-Y) * BESI1E
      RETURN
C
 20   IF (Y.LE.8.) BESI1E = (.375 + CSEVL ((48./Y-11.)/5., AI1CS, NTAI1)
     1  ) / SQRT(Y)
      IF (Y.GT.8.) BESI1E = (.375 + CSEVL (16./Y-1.0, AI12CS, NTAI12))
     1  / SQRT(Y)
      BESI1E = SIGN (BESI1E, X)
C
      RETURN
      END
      SUBROUTINE BESJ (X, ALPHA, N, Y, NZ)
C***BEGIN PROLOGUE  BESJ
C***PURPOSE  Compute an N member sequence of J Bessel functions
C            J/SUB(ALPHA+K-1)/(X), K=1,...,N for non-negative ALPHA
C            and X.
C***LIBRARY   SLATEC
C***CATEGORY  C10A3
C***TYPE      SINGLE PRECISION (BESJ-S, DBESJ-D)
C***KEYWORDS  J BESSEL FUNCTION, SPECIAL FUNCTIONS
C***AUTHOR  Amos, D. E., (SNLA)
C           Daniel, S. L., (SNLA)
C           Weston, M. K., (SNLA)
C***DESCRIPTION
C
C     Abstract
C         BESJ computes an N member sequence of J Bessel functions
C         J/sub(ALPHA+K-1)/(X), K=1,...,N for non-negative ALPHA and X.
C         A combination of the power series, the asymptotic expansion
C         for X to infinity and the uniform asymptotic expansion for
C         NU to infinity are applied over subdivisions of the (NU,X)
C         plane.  For values of (NU,X) not covered by one of these
C         formulae, the order is incremented or decremented by integer
C         values into a region where one of the formulae apply. Backward
C         recursion is applied to reduce orders by integer values except
C         where the entire sequence lies in the oscillatory region.  In
C         this case forward recursion is stable and values from the
C         asymptotic expansion for X to infinity start the recursion
C         when it is efficient to do so.  Leading terms of the series
C         and uniform expansion are tested for underflow.  If a sequence
C         is requested and the last member would underflow, the result
C         is set to zero and the next lower order tried, etc., until a
C         member comes on scale or all members are set to zero.
C         Overflow cannot occur.
C
C     Description of Arguments
C
C         Input
C           X      - X .GE. 0.0E0
C           ALPHA  - order of first member of the sequence,
C                    ALPHA .GE. 0.0E0
C           N      - number of members in the sequence, N .GE. 1
C
C         Output
C           Y      - a vector whose first  N components contain
C                    values for J/sub(ALPHA+K-1)/(X), K=1,...,N
C           NZ     - number of components of Y set to zero due to
C                    underflow,
C                    NZ=0   , normal return, computation completed
C                    NZ .NE. 0, last NZ components of Y set to zero,
C                             Y(K)=0.0E0, K=N-NZ+1,...,N.
C
C     Error Conditions
C         Improper input arguments - a fatal error
C         Underflow  - a non-fatal error (NZ .NE. 0)
C
C***REFERENCES  D. E. Amos, S. L. Daniel and M. K. Weston, CDC 6600
C                 subroutines IBESS and JBESS for Bessel functions
C                 I(NU,X) and J(NU,X), X .GE. 0, NU .GE. 0, ACM
C                 Transactions on Mathematical Software 3, (1977),
C                 pp. 76-92.
C               F. W. J. Olver, Tables of Bessel Functions of Moderate
C                 or Large Orders, NPL Mathematical Tables 6, Her
C                 Majesty's Stationery Office, London, 1962.
C***ROUTINES CALLED  ALNGAM, ASYJY, I1MACH, JAIRY, R1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   750101  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  BESJ
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      EXTERNAL JAIRY
      INTEGER I,IALP,IDALP,IFLW,IN,INLIM,IS,I1,I2,K,KK,KM,KT,N,NN,
     1        NS,NZ
      REAL       AK,AKM,ALPHA,ANS,AP,ARG,COEF,DALPHA,DFN,DTM,EARG,
     1           ELIM1,ETX,FIDAL,FLGJY,FN,FNF,FNI,FNP1,FNU,FNULIM,
     2           GLN,PDF,PIDT,PP,RDEN,RELB,RTTP,RTWO,RTX,RZDEN,
     3           S,SA,SB,SXO2,S1,S2,T,TA,TAU,TB,TEMP,TFN,TM,TOL,
     4           TOLLN,TRX,TX,T1,T2,WK,X,XO2,XO2L,Y,RTOL,SLIM
      SAVE RTWO, PDF, RTTP, PIDT, PP, INLIM, FNULIM
      DOUBLE PRECISION DLNGAM
      DIMENSION Y(*), TEMP(3), FNULIM(2), PP(4), WK(7)
      DATA RTWO,PDF,RTTP,PIDT                    / 1.34839972492648E+00,
     1 7.85398163397448E-01, 7.97884560802865E-01, 1.57079632679490E+00/
      DATA  PP(1),  PP(2),  PP(3),  PP(4)        / 8.72909153935547E+00,
     1 2.65693932265030E-01, 1.24578576865586E-01, 7.70133747430388E-04/
      DATA INLIM           /      150            /
      DATA FNULIM(1), FNULIM(2) /      100.0E0,     60.0E0     /
C***FIRST EXECUTABLE STATEMENT  BESJ
      NZ = 0
      KT = 1
      NS=0
C     I1MACH(14) REPLACES I1MACH(11) IN A DOUBLE PRECISION CODE
C     I1MACH(15) REPLACES I1MACH(12) IN A DOUBLE PRECISION CODE
      TA = R1MACH(3)
      TOL = MAX(TA,1.0E-15)
      I1 = I1MACH(11) + 1
      I2 = I1MACH(12)
      TB = R1MACH(5)
      ELIM1 = -2.303E0*(I2*TB+3.0E0)
      RTOL=1.0E0/TOL
      SLIM=R1MACH(1)*1.0E+3*RTOL
C     TOLLN = -LN(TOL)
      TOLLN = 2.303E0*TB*I1
      TOLLN = MIN(TOLLN,34.5388E0)
      IF (N-1) 720, 10, 20
   10 KT = 2
   20 NN = N
      IF (X) 730, 30, 80
   30 IF (ALPHA) 710, 40, 50
   40 Y(1) = 1.0E0
      IF (N.EQ.1) RETURN
      I1 = 2
      GO TO 60
   50 I1 = 1
   60 DO 70 I=I1,N
        Y(I) = 0.0E0
   70 CONTINUE
      RETURN
   80 CONTINUE
      IF (ALPHA.LT.0.0E0) GO TO 710
C
      IALP = INT(ALPHA)
      FNI = IALP + N - 1
      FNF = ALPHA - IALP
      DFN = FNI + FNF
      FNU = DFN
      XO2 = X*0.5E0
      SXO2 = XO2*XO2
C
C     DECISION TREE FOR REGION WHERE SERIES, ASYMPTOTIC EXPANSION FOR X
C     TO INFINITY AND ASYMPTOTIC EXPANSION FOR NU TO INFINITY ARE
C     APPLIED.
C
      IF (SXO2.LE.(FNU+1.0E0)) GO TO 90
      TA = MAX(20.0E0,FNU)
      IF (X.GT.TA) GO TO 120
      IF (X.GT.12.0E0) GO TO 110
      XO2L = LOG(XO2)
      NS = INT(SXO2-FNU) + 1
      GO TO 100
   90 FN = FNU
      FNP1 = FN + 1.0E0
      XO2L = LOG(XO2)
      IS = KT
      IF (X.LE.0.50E0) GO TO 330
      NS = 0
  100 FNI = FNI + NS
      DFN = FNI + FNF
      FN = DFN
      FNP1 = FN + 1.0E0
      IS = KT
      IF (N-1+NS.GT.0) IS = 3
      GO TO 330
  110 ANS = MAX(36.0E0-FNU,0.0E0)
      NS = INT(ANS)
      FNI = FNI + NS
      DFN = FNI + FNF
      FN = DFN
      IS = KT
      IF (N-1+NS.GT.0) IS = 3
      GO TO 130
  120 CONTINUE
      RTX = SQRT(X)
      TAU = RTWO*RTX
      TA = TAU + FNULIM(KT)
      IF (FNU.LE.TA) GO TO 480
      FN = FNU
      IS = KT
C
C     UNIFORM ASYMPTOTIC EXPANSION FOR NU TO INFINITY
C
  130 CONTINUE
      I1 = ABS(3-IS)
      I1 = MAX(I1,1)
      FLGJY = 1.0E0
      CALL ASYJY(JAIRY,X,FN,FLGJY,I1,TEMP(IS),WK,IFLW)
      IF(IFLW.NE.0) GO TO 380
      GO TO (320, 450, 620), IS
  310 TEMP(1) = TEMP(3)
      KT = 1
  320 IS = 2
      FNI = FNI - 1.0E0
      DFN = FNI + FNF
      FN = DFN
      IF(I1.EQ.2) GO TO 450
      GO TO 130
C
C     SERIES FOR (X/2)**2.LE.NU+1
C
  330 CONTINUE
      GLN = REAL(DLNGAM(DBLE(FNP1)))
      ARG = FN*XO2L - GLN
      IF (ARG.LT.(-ELIM1)) GO TO 400
      EARG = EXP(ARG)
  340 CONTINUE
      S = 1.0E0
      IF (X.LT.TOL) GO TO 360
      AK = 3.0E0
      T2 = 1.0E0
      T = 1.0E0
      S1 = FN
      DO 350 K=1,17
        S2 = T2 + S1
        T = -T*SXO2/S2
        S = S + T
        IF (ABS(T).LT.TOL) GO TO 360
        T2 = T2 + AK
        AK = AK + 2.0E0
        S1 = S1 + FN
  350 CONTINUE
  360 CONTINUE
      TEMP(IS) = S*EARG
      GO TO (370, 450, 610), IS
  370 EARG = EARG*FN/XO2
      FNI = FNI - 1.0E0
      DFN = FNI + FNF
      FN = DFN
      IS = 2
      GO TO 340
C
C     SET UNDERFLOW VALUE AND UPDATE PARAMETERS
C     UNDERFLOW CAN ONLY OCCUR FOR NS=0 SINCE THE ORDER MUST BE
C     LARGER THAN 36. THEREFORE, NS NEED NOT BE CONSIDERED.
C
  380 Y(NN) = 0.0E0
      NN = NN - 1
      FNI = FNI - 1.0E0
      DFN = FNI + FNF
      FN = DFN
      IF (NN-1) 440, 390, 130
  390 KT = 2
      IS = 2
      GO TO 130
  400 Y(NN) = 0.0E0
      NN = NN - 1
      FNP1 = FN
      FNI = FNI - 1.0E0
      DFN = FNI + FNF
      FN = DFN
      IF (NN-1) 440, 410, 420
  410 KT = 2
      IS = 2
  420 IF (SXO2.LE.FNP1) GO TO 430
      GO TO 130
  430 ARG = ARG - XO2L + LOG(FNP1)
      IF (ARG.LT.(-ELIM1)) GO TO 400
      GO TO 330
  440 NZ = N - NN
      RETURN
C
C     BACKWARD RECURSION SECTION
C
  450 CONTINUE
      IF(NS.NE.0) GO TO 451
      NZ = N - NN
      IF (KT.EQ.2) GO TO 470
C     BACKWARD RECUR FROM INDEX ALPHA+NN-1 TO ALPHA
      Y(NN) = TEMP(1)
      Y(NN-1) = TEMP(2)
      IF (NN.EQ.2) RETURN
  451 CONTINUE
      TRX = 2.0E0/X
      DTM = FNI
      TM = (DTM+FNF)*TRX
      AK=1.0E0
      TA=TEMP(1)
      TB=TEMP(2)
      IF(ABS(TA).GT.SLIM) GO TO 455
      TA=TA*RTOL
      TB=TB*RTOL
      AK=TOL
  455 CONTINUE
      KK=2
      IN=NS-1
      IF(IN.EQ.0) GO TO 690
      IF(NS.NE.0) GO TO 670
      K=NN-2
      DO 460 I=3,NN
        S=TB
        TB=TM*TB-TA
        TA=S
        Y(K)=TB*AK
        K=K-1
        DTM = DTM - 1.0E0
        TM = (DTM+FNF)*TRX
  460 CONTINUE
      RETURN
  470 Y(1) = TEMP(2)
      RETURN
C
C     ASYMPTOTIC EXPANSION FOR X TO INFINITY WITH FORWARD RECURSION IN
C     OSCILLATORY REGION X.GT.MAX(20, NU), PROVIDED THE LAST MEMBER
C     OF THE SEQUENCE IS ALSO IN THE REGION.
C
  480 CONTINUE
      IN = INT(ALPHA-TAU+2.0E0)
      IF (IN.LE.0) GO TO 490
      IDALP = IALP - IN - 1
      KT = 1
      GO TO 500
  490 CONTINUE
      IDALP = IALP
      IN = 0
  500 IS = KT
      FIDAL = IDALP
      DALPHA = FIDAL + FNF
      ARG = X - PIDT*DALPHA - PDF
      SA = SIN(ARG)
      SB = COS(ARG)
      COEF = RTTP/RTX
      ETX = 8.0E0*X
  510 CONTINUE
      DTM = FIDAL + FIDAL
      DTM = DTM*DTM
      TM = 0.0E0
      IF (FIDAL.EQ.0.0E0 .AND. ABS(FNF).LT.TOL) GO TO 520
      TM = 4.0E0*FNF*(FIDAL+FIDAL+FNF)
  520 CONTINUE
      TRX = DTM - 1.0E0
      T2 = (TRX+TM)/ETX
      S2 = T2
      RELB = TOL*ABS(T2)
      T1 = ETX
      S1 = 1.0E0
      FN = 1.0E0
      AK = 8.0E0
      DO 530 K=1,13
        T1 = T1 + ETX
        FN = FN + AK
        TRX = DTM - FN
        AP = TRX + TM
        T2 = -T2*AP/T1
        S1 = S1 + T2
        T1 = T1 + ETX
        AK = AK + 8.0E0
        FN = FN + AK
        TRX = DTM - FN
        AP = TRX + TM
        T2 = T2*AP/T1
        S2 = S2 + T2
        IF (ABS(T2).LE.RELB) GO TO 540
        AK = AK + 8.0E0
  530 CONTINUE
  540 TEMP(IS) = COEF*(S1*SB-S2*SA)
      IF(IS.EQ.2) GO TO 560
      FIDAL = FIDAL + 1.0E0
      DALPHA = FIDAL + FNF
      IS = 2
      TB = SA
      SA = -SB
      SB = TB
      GO TO 510
C
C     FORWARD RECURSION SECTION
C
  560 IF (KT.EQ.2) GO TO 470
      S1 = TEMP(1)
      S2 = TEMP(2)
      TX = 2.0E0/X
      TM = DALPHA*TX
      IF (IN.EQ.0) GO TO 580
C
C     FORWARD RECUR TO INDEX ALPHA
C
      DO 570 I=1,IN
        S = S2
        S2 = TM*S2 - S1
        TM = TM + TX
        S1 = S
  570 CONTINUE
      IF (NN.EQ.1) GO TO 600
      S = S2
      S2 = TM*S2 - S1
      TM = TM + TX
      S1 = S
  580 CONTINUE
C
C     FORWARD RECUR FROM INDEX ALPHA TO ALPHA+N-1
C
      Y(1) = S1
      Y(2) = S2
      IF (NN.EQ.2) RETURN
      DO 590 I=3,NN
        Y(I) = TM*Y(I-1) - Y(I-2)
        TM = TM + TX
  590 CONTINUE
      RETURN
  600 Y(1) = S2
      RETURN
C
C     BACKWARD RECURSION WITH NORMALIZATION BY
C     ASYMPTOTIC EXPANSION FOR NU TO INFINITY OR POWER SERIES.
C
  610 CONTINUE
C     COMPUTATION OF LAST ORDER FOR SERIES NORMALIZATION
      AKM = MAX(3.0E0-FN,0.0E0)
      KM = INT(AKM)
      TFN = FN + KM
      TA = (GLN+TFN-0.9189385332E0-0.0833333333E0/TFN)/(TFN+0.5E0)
      TA = XO2L - TA
      TB = -(1.0E0-1.5E0/TFN)/TFN
      AKM = TOLLN/(-TA+SQRT(TA*TA-TOLLN*TB)) + 1.5E0
      IN = KM + INT(AKM)
      GO TO 660
  620 CONTINUE
C     COMPUTATION OF LAST ORDER FOR ASYMPTOTIC EXPANSION NORMALIZATION
      GLN = WK(3) + WK(2)
      IF (WK(6).GT.30.0E0) GO TO 640
      RDEN = (PP(4)*WK(6)+PP(3))*WK(6) + 1.0E0
      RZDEN = PP(1) + PP(2)*WK(6)
      TA = RZDEN/RDEN
      IF (WK(1).LT.0.10E0) GO TO 630
      TB = GLN/WK(5)
      GO TO 650
  630 TB=(1.259921049E0+(0.1679894730E0+0.0887944358E0*WK(1))*WK(1))
     1 /WK(7)
      GO TO 650
  640 CONTINUE
      TA = 0.5E0*TOLLN/WK(4)
      TA=((0.0493827160E0*TA-0.1111111111E0)*TA+0.6666666667E0)*TA*WK(6)
      IF (WK(1).LT.0.10E0) GO TO 630
      TB = GLN/WK(5)
  650 IN = INT(TA/TB+1.5E0)
      IF (IN.GT.INLIM) GO TO 310
  660 CONTINUE
      DTM = FNI + IN
      TRX = 2.0E0/X
      TM = (DTM+FNF)*TRX
      TA = 0.0E0
      TB = TOL
      KK = 1
      AK=1.0E0
  670 CONTINUE
C
C     BACKWARD RECUR UNINDEXED AND SCALE WHEN MAGNITUDES ARE CLOSE TO
C     UNDERFLOW LIMITS (LESS THAN SLIM=R1MACH(1)*1.0E+3/TOL)
C
      DO 680 I=1,IN
        S = TB
        TB = TM*TB - TA
        TA = S
        DTM = DTM - 1.0E0
        TM = (DTM+FNF)*TRX
  680 CONTINUE
C     NORMALIZATION
      IF (KK.NE.1) GO TO 690
      S=TEMP(3)
      SA=TA/TB
      TA=S
      TB=S
      IF(ABS(S).GT.SLIM) GO TO 685
      TA=TA*RTOL
      TB=TB*RTOL
      AK=TOL
  685 CONTINUE
      TA=TA*SA
      KK = 2
      IN = NS
      IF (NS.NE.0) GO TO 670
  690 Y(NN) = TB*AK
      NZ = N - NN
      IF (NN.EQ.1) RETURN
      K = NN - 1
      S=TB
      TB = TM*TB - TA
      TA=S
      Y(K)=TB*AK
      IF (NN.EQ.2) RETURN
      DTM = DTM - 1.0E0
      TM = (DTM+FNF)*TRX
      K=NN-2
C
C     BACKWARD RECUR INDEXED
C
      DO 700 I=3,NN
        S=TB
        TB = TM*TB - TA
        TA=S
        Y(K)=TB*AK
        DTM = DTM - 1.0E0
        TM = (DTM+FNF)*TRX
        K = K - 1
  700 CONTINUE
      RETURN
C
C
C
  710 CONTINUE
      WRITE(ICOUT,711)
  711 FORMAT('***** ERORR FROM BESJ, THE ORDER ALPHA IS NEGATIVE. ***')
      CALL DPWRST('XXX','BUG ')
      RETURN
  720 CONTINUE
      WRITE(ICOUT,721)
  721 FORMAT('***** ERORR FROM BESJ, N IS LESS THAN ONE.. ***')
      CALL DPWRST('XXX','BUG ')
      RETURN
  730 CONTINUE
      WRITE(ICOUT,731)
  731 FORMAT('***** ERORR FROM BESJ, X IS LESS THAN ZERO.. ***')
      CALL DPWRST('XXX','BUG ')
      RETURN
      END
      FUNCTION BESJ0(X)
C***BEGIN PROLOGUE  BESJ0
C***DATE WRITTEN   770401   (YYMMDD)
C***REVISION DATE  820801   (YYMMDD)
C***CATEGORY NO.  C10A1
C***KEYWORDS  BESSEL FUNCTION,FIRST KIND,ORDER ZERO,SPECIAL FUNCTION
C***AUTHOR  FULLERTON, W., (LANL)
C***PURPOSE  Computes the Bessel function of the first kind of order
C            zero
C***DESCRIPTION
C
C BESJ0(X) calculates the Bessel function of the first kind of
C order zero for real argument X.
C
C Series for BJ0        on the interval  0.          to  1.60000D+01
C                                        with weighted error   7.47E-18
C                                         log weighted error  17.13
C                               significant figures required  16.98
C                                    decimal places required  17.68
C
C Series for BM0        on the interval  0.          to  6.25000D-02
C                                        with weighted error   4.98E-17
C                                         log weighted error  16.30
C                               significant figures required  14.97
C                                    decimal places required  16.96
C
C Series for BTH0       on the interval  0.          to  6.25000D-02
C                                        with weighted error   3.67E-17
C                                         log weighted error  16.44
C                               significant figures required  15.53
C                                    decimal places required  17.13
C***REFERENCES  (NONE)
C***ROUTINES CALLED  CSEVL,INITS,R1MACH,XERROR
C***END PROLOGUE  BESJ0
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DIMENSION BJ0CS(13), BM0CS(21), BTH0CS(24)
      DATA BJ0 CS( 1) /    .1002541619 68939137E0 /
      DATA BJ0 CS( 2) /   -.6652230077 64405132E0 /
      DATA BJ0 CS( 3) /    .2489837034 98281314E0 /
      DATA BJ0 CS( 4) /   -.0332527231 700357697E0 /
      DATA BJ0 CS( 5) /    .0023114179 304694015E0 /
      DATA BJ0 CS( 6) /   -.0000991127 741995080E0 /
      DATA BJ0 CS( 7) /    .0000028916 708643998E0 /
      DATA BJ0 CS( 8) /   -.0000000612 108586630E0 /
      DATA BJ0 CS( 9) /    .0000000009 838650793E0 /
      DATA BJ0 CS(10) /   -.0000000000 124235515E0 /
      DATA BJ0 CS(11) /    .0000000000 001265433E0 /
      DATA BJ0 CS(12) /   -.0000000000 000010619E0 /
      DATA BJ0 CS(13) /    .0000000000 000000074E0 /
      DATA BM0 CS( 1) /    .0928496163 7381644E0 /
      DATA BM0 CS( 2) /   -.0014298770 7403484E0 /
      DATA BM0 CS( 3) /    .0000283057 9271257E0 /
      DATA BM0 CS( 4) /   -.0000014330 0611424E0 /
      DATA BM0 CS( 5) /    .0000001202 8628046E0 /
      DATA BM0 CS( 6) /   -.0000000139 7113013E0 /
      DATA BM0 CS( 7) /    .0000000020 4076188E0 /
      DATA BM0 CS( 8) /   -.0000000003 5399669E0 /
      DATA BM0 CS( 9) /    .0000000000 7024759E0 /
      DATA BM0 CS(10) /   -.0000000000 1554107E0 /
      DATA BM0 CS(11) /    .0000000000 0376226E0 /
      DATA BM0 CS(12) /   -.0000000000 0098282E0 /
      DATA BM0 CS(13) /    .0000000000 0027408E0 /
      DATA BM0 CS(14) /   -.0000000000 0008091E0 /
      DATA BM0 CS(15) /    .0000000000 0002511E0 /
      DATA BM0 CS(16) /   -.0000000000 0000814E0 /
      DATA BM0 CS(17) /    .0000000000 0000275E0 /
      DATA BM0 CS(18) /   -.0000000000 0000096E0 /
      DATA BM0 CS(19) /    .0000000000 0000034E0 /
      DATA BM0 CS(20) /   -.0000000000 0000012E0 /
      DATA BM0 CS(21) /    .0000000000 0000004E0 /
      DATA BTH0CS( 1) /   -.2463916377 4300119E0 /
      DATA BTH0CS( 2) /    .0017370983 07508963E0 /
      DATA BTH0CS( 3) /   -.0000621836 33402968E0 /
      DATA BTH0CS( 4) /    .0000043680 50165742E0 /
      DATA BTH0CS( 5) /   -.0000004560 93019869E0 /
      DATA BTH0CS( 6) /    .0000000621 97400101E0 /
      DATA BTH0CS( 7) /   -.0000000103 00442889E0 /
      DATA BTH0CS( 8) /    .0000000019 79526776E0 /
      DATA BTH0CS( 9) /   -.0000000004 28198396E0 /
      DATA BTH0CS(10) /    .0000000001 02035840E0 /
      DATA BTH0CS(11) /   -.0000000000 26363898E0 /
      DATA BTH0CS(12) /    .0000000000 07297935E0 /
      DATA BTH0CS(13) /   -.0000000000 02144188E0 /
      DATA BTH0CS(14) /    .0000000000 00663693E0 /
      DATA BTH0CS(15) /   -.0000000000 00215126E0 /
      DATA BTH0CS(16) /    .0000000000 00072659E0 /
      DATA BTH0CS(17) /   -.0000000000 00025465E0 /
      DATA BTH0CS(18) /    .0000000000 00009229E0 /
      DATA BTH0CS(19) /   -.0000000000 00003448E0 /
      DATA BTH0CS(20) /    .0000000000 00001325E0 /
      DATA BTH0CS(21) /   -.0000000000 00000522E0 /
      DATA BTH0CS(22) /    .0000000000 00000210E0 /
      DATA BTH0CS(23) /   -.0000000000 00000087E0 /
      DATA BTH0CS(24) /    .0000000000 00000036E0 /
      DATA PI4 / 0.7853981633 9744831E0 /
      DATA NTJ0, NTM0, NTTH0, XSML, XMAX / 3*0, 2*0./
C***FIRST EXECUTABLE STATEMENT  BESJ0
      IF (NTJ0.NE.0) GO TO 10
      NTJ0 = INITS (BJ0CS, 13, 0.1*R1MACH(3))
      NTM0 = INITS (BM0CS, 21, 0.1*R1MACH(3))
      NTTH0 = INITS (BTH0CS, 24, 0.1*R1MACH(3))
C
      XSML = SQRT (4.0*R1MACH(3))
      XMAX = 1.0/R1MACH(4)
C
 10   Y = ABS(X)
      IF (Y.GT.4.0) GO TO 20
C
      BESJ0 = 1.0
      IF (Y.GT.XSML) BESJ0 = CSEVL (.125*Y*Y-1., BJ0CS, NTJ0)
      RETURN
C
 20   CONTINUE
      IF (Y.GT.XMAX) THEN
        WRITE(ICOUT,1)
        CALL DPWRST('XXX','BUG ')
        BESJ0 = 0.0
        RETURN
      ENDIF
    1 FORMAT('***** ERORR FROM BESJ0, NO PRECISION BECAUSE THE ',
     1       'ABSOLUTE VALUE OF X IS TOO BIG.  ****')
C
      Z = 32.0/Y**2 - 1.0
      AMPL = (0.75 + CSEVL (Z, BM0CS, NTM0)) / SQRT(Y)
      THETA = Y - PI4 + CSEVL (Z, BTH0CS, NTTH0) / Y
      BESJ0 = AMPL * COS (THETA)
C
      RETURN
      END
      FUNCTION BESJ1(X)
C***BEGIN PROLOGUE  BESJ1
C***DATE WRITTEN   780601   (YYMMDD)
C***REVISION DATE  820801   (YYMMDD)
C***CATEGORY NO.  C10A1
C***KEYWORDS  BESSEL FUNCTION,FIRST KIND,ORDER ONE,SPECIAL FUNCTION
C***AUTHOR  FULLERTON, W., (LANL)
C***PURPOSE  Computes the Bessel function of the first kind of order one
C***DESCRIPTION
C
C BESJ1(X) calculates the Bessel function of the first kind of
C order one for real argument X.
C
C Series for BJ1        on the interval  0.          to  1.60000D+01
C                                        with weighted error   4.48E-17
C                                         log weighted error  16.35
C                               significant figures required  15.77
C                                    decimal places required  16.89
C
C Series for BM1        on the interval  0.          to  6.25000D-02
C                                        with weighted error   5.61E-17
C                                         log weighted error  16.25
C                               significant figures required  14.97
C                                    decimal places required  16.91
C
C Series for BTH1       on the interval  0.          to  6.25000D-02
C                                        with weighted error   4.10E-17
C                                         log weighted error  16.39
C                               significant figures required  15.96
C                                    decimal places required  17.08
C***REFERENCES  (NONE)
C***ROUTINES CALLED  CSEVL,INITS,R1MACH,XERROR
C***END PROLOGUE  BESJ1
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DIMENSION BJ1CS(12), BM1CS(21), BTH1CS(24)
      DATA BJ1 CS( 1) /   -.1172614151 3332787E0 /
      DATA BJ1 CS( 2) /   -.2536152183 0790640E0 /
      DATA BJ1 CS( 3) /    .0501270809 84469569E0 /
      DATA BJ1 CS( 4) /   -.0046315148 09625081E0 /
      DATA BJ1 CS( 5) /    .0002479962 29415914E0 /
      DATA BJ1 CS( 6) /   -.0000086789 48686278E0 /
      DATA BJ1 CS( 7) /    .0000002142 93917143E0 /
      DATA BJ1 CS( 8) /   -.0000000039 36093079E0 /
      DATA BJ1 CS( 9) /    .0000000000 55911823E0 /
      DATA BJ1 CS(10) /   -.0000000000 00632761E0 /
      DATA BJ1 CS(11) /    .0000000000 00005840E0 /
      DATA BJ1 CS(12) /   -.0000000000 00000044E0 /
      DATA BM1 CS( 1) /    .1047362510 931285E0 /
      DATA BM1 CS( 2) /    .0044244389 3702345E0 /
      DATA BM1 CS( 3) /   -.0000566163 9504035E0 /
      DATA BM1 CS( 4) /    .0000023134 9417339E0 /
      DATA BM1 CS( 5) /   -.0000001737 7182007E0 /
      DATA BM1 CS( 6) /    .0000000189 3209930E0 /
      DATA BM1 CS( 7) /   -.0000000026 5416023E0 /
      DATA BM1 CS( 8) /    .0000000004 4740209E0 /
      DATA BM1 CS( 9) /   -.0000000000 8691795E0 /
      DATA BM1 CS(10) /    .0000000000 1891492E0 /
      DATA BM1 CS(11) /   -.0000000000 0451884E0 /
      DATA BM1 CS(12) /    .0000000000 0116765E0 /
      DATA BM1 CS(13) /   -.0000000000 0032265E0 /
      DATA BM1 CS(14) /    .0000000000 0009450E0 /
      DATA BM1 CS(15) /   -.0000000000 0002913E0 /
      DATA BM1 CS(16) /    .0000000000 0000939E0 /
      DATA BM1 CS(17) /   -.0000000000 0000315E0 /
      DATA BM1 CS(18) /    .0000000000 0000109E0 /
      DATA BM1 CS(19) /   -.0000000000 0000039E0 /
      DATA BM1 CS(20) /    .0000000000 0000014E0 /
      DATA BM1 CS(21) /   -.0000000000 0000005E0 /
      DATA BTH1CS( 1) /    .7406014102 6313850E0 /
      DATA BTH1CS( 2) /   -.0045717556 59637690E0 /
      DATA BTH1CS( 3) /    .0001198185 10964326E0 /
      DATA BTH1CS( 4) /   -.0000069645 61891648E0 /
      DATA BTH1CS( 5) /    .0000006554 95621447E0 /
      DATA BTH1CS( 6) /   -.0000000840 66228945E0 /
      DATA BTH1CS( 7) /    .0000000133 76886564E0 /
      DATA BTH1CS( 8) /   -.0000000024 99565654E0 /
      DATA BTH1CS( 9) /    .0000000005 29495100E0 /
      DATA BTH1CS(10) /   -.0000000001 24135944E0 /
      DATA BTH1CS(11) /    .0000000000 31656485E0 /
      DATA BTH1CS(12) /   -.0000000000 08668640E0 /
      DATA BTH1CS(13) /    .0000000000 02523758E0 /
      DATA BTH1CS(14) /   -.0000000000 00775085E0 /
      DATA BTH1CS(15) /    .0000000000 00249527E0 /
      DATA BTH1CS(16) /   -.0000000000 00083773E0 /
      DATA BTH1CS(17) /    .0000000000 00029205E0 /
      DATA BTH1CS(18) /   -.0000000000 00010534E0 /
      DATA BTH1CS(19) /    .0000000000 00003919E0 /
      DATA BTH1CS(20) /   -.0000000000 00001500E0 /
      DATA BTH1CS(21) /    .0000000000 00000589E0 /
      DATA BTH1CS(22) /   -.0000000000 00000237E0 /
      DATA BTH1CS(23) /    .0000000000 00000097E0 /
      DATA BTH1CS(24) /   -.0000000000 00000040E0 /
      DATA PI4 / 0.7853981633 9744831E0 /
      DATA NTJ1, NTM1, NTTH1, XSML, XMIN, XMAX / 3*0, 3*0./
C***FIRST EXECUTABLE STATEMENT  BESJ1
      IF (NTJ1.NE.0) GO TO 10
      NTJ1 = INITS (BJ1CS, 12, 0.1*R1MACH(3))
      NTM1 = INITS (BM1CS, 21, 0.1*R1MACH(3))
      NTTH1 = INITS (BTH1CS, 24, 0.1*R1MACH(3))
C
      XSML = SQRT (8.0*R1MACH(3))
      XMIN = 2.0*R1MACH(1)
      XMAX = 1.0/R1MACH(4)
C
 10   Y = ABS(X)
      IF (Y.GT.4.0) GO TO 20
C
      BESJ1 = 0.
      IF (Y.EQ.0.0) RETURN
      IF (Y.LT.XMIN) THEN
        WRITE(ICOUT,2)
        CALL DPWRST('XXX','BUG ')
      ENDIF
    2 FORMAT('***** WARNING FROM BESJ1, UNDERFLOW BECAUSE THE ',
     1       'ABSOLUTE VALUE OF X IS TOO SMALL.  ****')
      IF (Y.GT.XMIN) BESJ1 = 0.5*X
      IF (Y.GT.XSML) BESJ1 = X * (.25 + CSEVL(.125*Y*Y-1., BJ1CS, NTJ1))
      RETURN
C
 20   CONTINUE
      IF (Y.GT.XMAX) THEN
        WRITE(ICOUT,1)
        CALL DPWRST('XXX','BUG ')
        BESJ1 = 0.0
        RETURN
      ENDIF
    1 FORMAT('***** ERORR FROM BESJ1, NO PRECISION BECAUSE THE ',
     1       'ABSOLUTE VALUE OF X IS TOO BIG.  ****')
      Z = 32.0/Y**2 - 1.0
      AMPL = (0.75 + CSEVL (Z, BM1CS, NTM1)) / SQRT(Y)
      THETA = Y - 3.0*PI4 + CSEVL (Z, BTH1CS, NTTH1) / Y
      BESJ1 = SIGN (AMPL, X) * COS (THETA)
C
      RETURN
      END
      SUBROUTINE BESK (X, FNU, KODE, N, Y, NZ)
C***BEGIN PROLOGUE  BESK
C***PURPOSE  Implement forward recursion on the three term recursion
C            relation for a sequence of non-negative order Bessel
C            functions K/SUB(FNU+I-1)/(X), or scaled Bessel functions
C            EXP(X)*K/SUB(FNU+I-1)/(X), I=1,...,N for real, positive
C            X and non-negative orders FNU.
C***LIBRARY   SLATEC
C***CATEGORY  C10B3
C***TYPE      SINGLE PRECISION (BESK-S, DBESK-D)
C***KEYWORDS  K BESSEL FUNCTION, SPECIAL FUNCTIONS
C***AUTHOR  Amos, D. E., (SNLA)
C***DESCRIPTION
C
C     Abstract
C         BESK implements forward recursion on the three term
C         recursion relation for a sequence of non-negative order Bessel
C         functions K/sub(FNU+I-1)/(X), or scaled Bessel functions
C         EXP(X)*K/sub(FNU+I-1)/(X), I=1,...,N for real X .GT. 0.0E0 and
C         non-negative orders FNU.  If FNU .LT. NULIM, orders FNU and
C         FNU+1 are obtained from BESKNU to start the recursion.  If
C         FNU .GE. NULIM, the uniform asymptotic expansion is used for
C         orders FNU and FNU+1 to start the recursion.  NULIM is 35 or
C         70 depending on whether N=1 or N .GE. 2.  Under and overflow
C         tests are made on the leading term of the asymptotic expansion
C         before any extensive computation is done.
C
C     Description of Arguments
C
C         Input
C           X      - X .GT. 0.0E0
C           FNU    - order of the initial K function, FNU .GE. 0.0E0
C           KODE   - a parameter to indicate the scaling option
C                    KODE=1 returns Y(I)=       K/sub(FNU+I-1)/(X),
C                                        I=1,...,N
C                    KODE=2 returns Y(I)=EXP(X)*K/sub(FNU+I-1)/(X),
C                                        I=1,...,N
C           N      - number of members in the sequence, N .GE. 1
C
C         Output
C           y      - a vector whose first n components contain values
C                    for the sequence
C                    Y(I)=       K/sub(FNU+I-1)/(X), I=1,...,N  or
C                    Y(I)=EXP(X)*K/sub(FNU+I-1)/(X), I=1,...,N
C                    depending on KODE
C           NZ     - number of components of Y set to zero due to
C                    underflow with KODE=1,
C                    NZ=0   , normal return, computation completed
C                    NZ .NE. 0, first NZ components of Y set to zero
C                             due to underflow, Y(I)=0.0E0, I=1,...,NZ
C
C     Error Conditions
C         Improper input arguments - a fatal error
C         Overflow - a fatal error
C         Underflow with KODE=1 -  a non-fatal error (NZ .NE. 0)
C
C***REFERENCES  F. W. J. Olver, Tables of Bessel Functions of Moderate
C                 or Large Orders, NPL Mathematical Tables 6, Her
C                 Majesty's Stationery Office, London, 1962.
C               N. M. Temme, On the numerical evaluation of the modified
C                 Bessel function of the third kind, Journal of
C                 Computational Physics 19, (1975), pp. 324-337.
C***ROUTINES CALLED  ASYIK, BESK0, BESK0E, BESK1, BESK1E, BESKNU,
C                    I1MACH, R1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   790201  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  BESK
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C
      INTEGER I, J, K, KODE, MZ, N, NB, ND, NN, NUD, NULIM, NZ
      REAL CN, DNU, ELIM, ETX, FLGIK,FN, FNN, FNU,GLN,GNU,RTZ,S,S1,S2,
     1 T, TM, TRX, W, X, XLIM, Y, ZN
      REAL BESK0, BESK1, BESK1E, BESK0E
      DIMENSION W(2), NULIM(2), Y(*)
      SAVE NULIM
      DATA NULIM(1),NULIM(2) / 35 , 70 /
C***FIRST EXECUTABLE STATEMENT  BESK
      NN = -I1MACH(12)
      ELIM = 2.303E0*(NN*R1MACH(5)-3.0E0)
      XLIM = R1MACH(1)*1.0E+3
      IF (KODE.LT.1 .OR. KODE.GT.2) GO TO 280
      IF (FNU.LT.0.0E0) GO TO 290
      IF (X.LE.0.0E0) GO TO 300
      IF (X.LT.XLIM) GO TO 320
      IF (N.LT.1) GO TO 310
      ETX = KODE - 1
C
C     ND IS A DUMMY VARIABLE FOR N
C     GNU IS A DUMMY VARIABLE FOR FNU
C     NZ = NUMBER OF UNDERFLOWS ON KODE=1
C
      ND = N
      NZ = 0
      NUD = INT(FNU)
      DNU = FNU - NUD
      GNU = FNU
      NN = MIN(2,ND)
      FN = FNU + N - 1
      FNN = FN
      IF (FN.LT.2.0E0) GO TO 150
C
C     OVERFLOW TEST  (LEADING EXPONENTIAL OF ASYMPTOTIC EXPANSION)
C     FOR THE LAST ORDER, FNU+N-1.GE.NULIM
C
      ZN = X/FN
      IF (ZN.EQ.0.0E0) GO TO 320
      RTZ = SQRT(1.0E0+ZN*ZN)
      GLN = LOG((1.0E0+RTZ)/ZN)
      T = RTZ*(1.0E0-ETX) + ETX/(ZN+RTZ)
      CN = -FN*(T-GLN)
      IF (CN.GT.ELIM) GO TO 320
      IF (NUD.LT.NULIM(NN)) GO TO 30
      IF (NN.EQ.1) GO TO 20
   10 CONTINUE
C
C     UNDERFLOW TEST (LEADING EXPONENTIAL OF ASYMPTOTIC EXPANSION)
C     FOR THE FIRST ORDER, FNU.GE.NULIM
C
      FN = GNU
      ZN = X/FN
      RTZ = SQRT(1.0E0+ZN*ZN)
      GLN = LOG((1.0E0+RTZ)/ZN)
      T = RTZ*(1.0E0-ETX) + ETX/(ZN+RTZ)
      CN = -FN*(T-GLN)
   20 CONTINUE
      IF (CN.LT.-ELIM) GO TO 230
C
C     ASYMPTOTIC EXPANSION FOR ORDERS FNU AND FNU+1.GE.NULIM
C
      FLGIK = -1.0E0
      CALL ASYIK(X,GNU,KODE,FLGIK,RTZ,CN,NN,Y)
      IF (NN.EQ.1) GO TO 240
      TRX = 2.0E0/X
      TM = (GNU+GNU+2.0E0)/X
      GO TO 130
C
   30 CONTINUE
      IF (KODE.EQ.2) GO TO 40
C
C     UNDERFLOW TEST (LEADING EXPONENTIAL OF ASYMPTOTIC EXPANSION IN X)
C     FOR ORDER DNU
C
      IF (X.GT.ELIM) GO TO 230
   40 CONTINUE
      IF (DNU.NE.0.0E0) GO TO 80
      IF (KODE.EQ.2) GO TO 50
      S1 = BESK0(X)
      GO TO 60
   50 S1 = BESK0E(X)
   60 CONTINUE
      IF (NUD.EQ.0 .AND. ND.EQ.1) GO TO 120
      IF (KODE.EQ.2) GO TO 70
      S2 = BESK1(X)
      GO TO 90
   70 S2 = BESK1E(X)
      GO TO 90
   80 CONTINUE
      NB = 2
      IF (NUD.EQ.0 .AND. ND.EQ.1) NB = 1
      CALL BESKNU(X, DNU, KODE, NB, W, NZ)
      S1 = W(1)
      IF (NB.EQ.1) GO TO 120
      S2 = W(2)
   90 CONTINUE
      TRX = 2.0E0/X
      TM = (DNU+DNU+2.0E0)/X
C     FORWARD RECUR FROM DNU TO FNU+1 TO GET Y(1) AND Y(2)
      IF (ND.EQ.1) NUD = NUD - 1
      IF (NUD.GT.0) GO TO 100
      IF (ND.GT.1) GO TO 120
      S1 = S2
      GO TO 120
  100 CONTINUE
      DO 110 I=1,NUD
        S = S2
        S2 = TM*S2 + S1
        S1 = S
        TM = TM + TRX
  110 CONTINUE
      IF (ND.EQ.1) S1 = S2
  120 CONTINUE
      Y(1) = S1
      IF (ND.EQ.1) GO TO 240
      Y(2) = S2
  130 CONTINUE
      IF (ND.EQ.2) GO TO 240
C     FORWARD RECUR FROM FNU+2 TO FNU+N-1
      DO 140 I=3,ND
        Y(I) = TM*Y(I-1) + Y(I-2)
        TM = TM + TRX
  140 CONTINUE
      GO TO 240
C
  150 CONTINUE
C     UNDERFLOW TEST FOR KODE=1
      IF (KODE.EQ.2) GO TO 160
      IF (X.GT.ELIM) GO TO 230
  160 CONTINUE
C     OVERFLOW TEST
      IF (FN.LE.1.0E0) GO TO 170
      IF (-FN*(LOG(X)-0.693E0).GT.ELIM) GO TO 320
  170 CONTINUE
      IF (DNU.EQ.0.0E0) GO TO 180
      CALL BESKNU(X, FNU, KODE, ND, Y, MZ)
      GO TO 240
  180 CONTINUE
      J = NUD
      IF (J.EQ.1) GO TO 210
      J = J + 1
      IF (KODE.EQ.2) GO TO 190
      Y(J) = BESK0(X)
      GO TO 200
  190 Y(J) = BESK0E(X)
  200 IF (ND.EQ.1) GO TO 240
      J = J + 1
  210 IF (KODE.EQ.2) GO TO 220
      Y(J) = BESK1(X)
      GO TO 240
  220 Y(J) = BESK1E(X)
      GO TO 240
C
C     UPDATE PARAMETERS ON UNDERFLOW
C
  230 CONTINUE
      NUD = NUD + 1
      ND = ND - 1
      IF (ND.EQ.0) GO TO 240
      NN = MIN(2,ND)
      GNU = GNU + 1.0E0
      IF (FNN.LT.2.0E0) GO TO 230
      IF (NUD.LT.NULIM(NN)) GO TO 230
      GO TO 10
  240 CONTINUE
      NZ = N - ND
      IF (NZ.EQ.0) RETURN
      IF (ND.EQ.0) GO TO 260
      DO 250 I=1,ND
        J = N - I + 1
        K = ND - I + 1
        Y(J) = Y(K)
  250 CONTINUE
  260 CONTINUE
      DO 270 I=1,NZ
        Y(I) = 0.0E0
  270 CONTINUE
      RETURN
C
C
C
  280 CONTINUE
      WRITE(ICOUT,281)
  281 FORMAT('***** ERORR FROM BESK, KODE IS NOT 1 OR 2. ***')
      CALL DPWRST('XXX','BUG ')
      RETURN
  290 CONTINUE
      WRITE(ICOUT,291)
  291 FORMAT('***** ERORR FROM BESK, THE ORDER FNU IS NEGATIVE. ***')
      CALL DPWRST('XXX','BUG ')
      RETURN
  300 CONTINUE
      WRITE(ICOUT,301)
  301 FORMAT('**** ERORR FROM BESK, X IS LESS THAN OR EQUAL TO ZERO. ')
      CALL DPWRST('XXX','BUG ')
      RETURN
  310 CONTINUE
      WRITE(ICOUT,311)
  311 FORMAT('***** ERORR FROM BESK, N IS LESS THAN ONE.. ***')
      CALL DPWRST('XXX','BUG ')
      RETURN
  320 CONTINUE
      WRITE(ICOUT,321)
  321 FORMAT('***** ERORR FROM BESK, OVERFLOW, FNU OR N TOO LARGE OR ',
     1       'X TOO SMALL. *****')
      CALL DPWRST('XXX','BUG ')
      RETURN
      END
      SUBROUTINE BESKNU (X, FNU, KODE, N, Y, NZ)
C***BEGIN PROLOGUE  BESKNU
C***SUBSIDIARY
C***PURPOSE  Subsidiary to BESK
C***LIBRARY   SLATEC
C***TYPE      SINGLE PRECISION (BESKNU-S, DBSKNU-D)
C***AUTHOR  Amos, D. E., (SNLA)
C***DESCRIPTION
C
C     Abstract
C         BESKNU computes N member sequences of K Bessel functions
C         K/SUB(FNU+I-1)/(X), I=1,N for non-negative orders FNU and
C         positive X. Equations of the references are implemented on
C         small orders DNU for K/SUB(DNU)/(X) and K/SUB(DNU+1)/(X).
C         Forward recursion with the three term recursion relation
C         generates higher orders FNU+I-1, I=1,...,N. The parameter
C         KODE permits K/SUB(FNU+I-1)/(X) values or scaled values
C         EXP(X)*K/SUB(FNU+I-1)/(X), I=1,N to be returned.
C
C         To start the recursion FNU is normalized to the interval
C         -0.5.LE.DNU.LT.0.5. A special form of the power series is
C         implemented on 0.LT.X.LE.X1 while the Miller algorithm for the
C         K Bessel function in terms of the confluent hypergeometric
C         function U(FNU+0.5,2*FNU+1,X) is implemented on X1.LT.X.LE.X2.
C         For X.GT.X2, the asymptotic expansion for large X is used.
C         When FNU is a half odd integer, a special formula for
C         DNU=-0.5 and DNU+1.0=0.5 is used to start the recursion.
C
C         BESKNU assumes that a significant digit SINH(X) function is
C         available.
C
C     Description of Arguments
C
C         Input
C           X      - X.GT.0.0E0
C           FNU    - Order of initial K function, FNU.GE.0.0E0
C           N      - Number of members of the sequence, N.GE.1
C           KODE   - A parameter to indicate the scaling option
C                    KODE= 1  returns
C                             Y(I)=       K/SUB(FNU+I-1)/(X)
C                                  I=1,...,N
C                        = 2  returns
C                             Y(I)=EXP(X)*K/SUB(FNU+I-1)/(X)
C                                  I=1,...,N
C
C         Output
C           Y      - A vector whose first N components contain values
C                    for the sequence
C                    Y(I)=       K/SUB(FNU+I-1)/(X), I=1,...,N or
C                    Y(I)=EXP(X)*K/SUB(FNU+I-1)/(X), I=1,...,N
C                    depending on KODE
C           NZ     - Number of components set to zero due to
C                    underflow,
C                    NZ= 0   , Normal return
C                    NZ.NE.0 , First NZ components of Y set to zero
C                              due to underflow, Y(I)=0.0E0,I=1,...,NZ
C
C     Error Conditions
C         Improper input arguments - a fatal error
C         Overflow - a fatal error
C         Underflow with KODE=1 - a non-fatal error (NZ.NE.0)
C
C***SEE ALSO  BESK
C***REFERENCES  N. M. Temme, On the numerical evaluation of the modified
C                 Bessel function of the third kind, Journal of
C                 Computational Physics 19, (1975), pp. 324-337.
C***ROUTINES CALLED  GAMMA, I1MACH, R1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   790201  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   900328  Added TYPE section.  (WRB)
C   900727  Added EXTERNAL statement.  (WRB)
C   910408  Updated the AUTHOR and REFERENCES sections.  (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  BESKNU
C
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      INTEGER I, IFLAG, INU, J, K, KK, KODE, KODED, N, NN, NZ
      REAL A, AK, A1, A2, B, BK, CC, CK, COEF, CX, DK, DNU, DNU2, ELIM,
     1 ETEST, EX, F, FC, FHS, FK, FKS, FLRX, FMU, FNU, G1, G2, P, PI,
     2 PT, P1, P2, Q, RTHPI, RX, S, SMU, SQK, ST, S1, S2, TM, TOL, T1,
     3 T2, X, X1, X2, Y
      DOUBLE PRECISION DGAMMA
      DIMENSION A(160), B(160), Y(*), CC(8)
      EXTERNAL DGAMMA
      SAVE X1, X2, PI, RTHPI, CC
      DATA X1, X2 / 2.0E0, 17.0E0 /
      DATA PI,RTHPI        / 3.14159265358979E+00, 1.25331413731550E+00/
      DATA CC(1), CC(2), CC(3), CC(4), CC(5), CC(6), CC(7), CC(8)
     1                     / 5.77215664901533E-01,-4.20026350340952E-02,
     2-4.21977345555443E-02, 7.21894324666300E-03,-2.15241674114900E-04,
     3-2.01348547807000E-05, 1.13302723200000E-06, 6.11609500000000E-09/
C***FIRST EXECUTABLE STATEMENT  BESKNU
      KK = -I1MACH(12)
      ELIM = 2.303E0*(KK*R1MACH(5)-3.0E0)
      AK = R1MACH(3)
      TOL = MAX(AK,1.0E-15)
      IF (X.LE.0.0E0) GO TO 350
      IF (FNU.LT.0.0E0) GO TO 360
      IF (KODE.LT.1 .OR. KODE.GT.2) GO TO 370
      IF (N.LT.1) GO TO 380
      NZ = 0
      IFLAG = 0
      KODED = KODE
      RX = 2.0E0/X
      INU = INT(FNU+0.5E0)
      DNU = FNU - INU
      IF (ABS(DNU).EQ.0.5E0) GO TO 120
      DNU2 = 0.0E0
      IF (ABS(DNU).LT.TOL) GO TO 10
      DNU2 = DNU*DNU
   10 CONTINUE
      IF (X.GT.X1) GO TO 120
C
C     SERIES FOR X.LE.X1
C
      A1 = 1.0E0 - DNU
      A2 = 1.0E0 + DNU
      T1 = 1.0E0/DGAMMA(DBLE(A1))
      T2 = 1.0E0/DGAMMA(DBLE(A2))
      IF (ABS(DNU).GT.0.1E0) GO TO 40
C     SERIES FOR F0 TO RESOLVE INDETERMINACY FOR SMALL ABS(DNU)
      S = CC(1)
      AK = 1.0E0
      DO 20 K=2,8
        AK = AK*DNU2
        TM = CC(K)*AK
        S = S + TM
        IF (ABS(TM).LT.TOL) GO TO 30
   20 CONTINUE
   30 G1 = -S
      GO TO 50
   40 CONTINUE
      G1 = (T1-T2)/(DNU+DNU)
   50 CONTINUE
      G2 = (T1+T2)*0.5E0
      SMU = 1.0E0
      FC = 1.0E0
      FLRX = LOG(RX)
      FMU = DNU*FLRX
      IF (DNU.EQ.0.0E0) GO TO 60
      FC = DNU*PI
      FC = FC/SIN(FC)
      IF (FMU.NE.0.0E0) SMU = SINH(FMU)/FMU
   60 CONTINUE
      F = FC*(G1*COSH(FMU)+G2*FLRX*SMU)
      FC = EXP(FMU)
      P = 0.5E0*FC/T2
      Q = 0.5E0/(FC*T1)
      AK = 1.0E0
      CK = 1.0E0
      BK = 1.0E0
      S1 = F
      S2 = P
      IF (INU.GT.0 .OR. N.GT.1) GO TO 90
      IF (X.LT.TOL) GO TO 80
      CX = X*X*0.25E0
   70 CONTINUE
      F = (AK*F+P+Q)/(BK-DNU2)
      P = P/(AK-DNU)
      Q = Q/(AK+DNU)
      CK = CK*CX/AK
      T1 = CK*F
      S1 = S1 + T1
      BK = BK + AK + AK + 1.0E0
      AK = AK + 1.0E0
      S = ABS(T1)/(1.0E0+ABS(S1))
      IF (S.GT.TOL) GO TO 70
   80 CONTINUE
      Y(1) = S1
      IF (KODED.EQ.1) RETURN
      Y(1) = S1*EXP(X)
      RETURN
   90 CONTINUE
      IF (X.LT.TOL) GO TO 110
      CX = X*X*0.25E0
  100 CONTINUE
      F = (AK*F+P+Q)/(BK-DNU2)
      P = P/(AK-DNU)
      Q = Q/(AK+DNU)
      CK = CK*CX/AK
      T1 = CK*F
      S1 = S1 + T1
      T2 = CK*(P-AK*F)
      S2 = S2 + T2
      BK = BK + AK + AK + 1.0E0
      AK = AK + 1.0E0
      S = ABS(T1)/(1.0E0+ABS(S1)) + ABS(T2)/(1.0E0+ABS(S2))
      IF (S.GT.TOL) GO TO 100
  110 CONTINUE
      S2 = S2*RX
      IF (KODED.EQ.1) GO TO 170
      F = EXP(X)
      S1 = S1*F
      S2 = S2*F
      GO TO 170
  120 CONTINUE
      COEF = RTHPI/SQRT(X)
      IF (KODED.EQ.2) GO TO 130
      IF (X.GT.ELIM) GO TO 330
      COEF = COEF*EXP(-X)
  130 CONTINUE
      IF (ABS(DNU).EQ.0.5E0) GO TO 340
      IF (X.GT.X2) GO TO 280
C
C     MILLER ALGORITHM FOR X1.LT.X.LE.X2
C
      ETEST = COS(PI*DNU)/(PI*X*TOL)
      FKS = 1.0E0
      FHS = 0.25E0
      FK = 0.0E0
      CK = X + X + 2.0E0
      P1 = 0.0E0
      P2 = 1.0E0
      K = 0
  140 CONTINUE
      K = K + 1
      FK = FK + 1.0E0
      AK = (FHS-DNU2)/(FKS+FK)
      BK = CK/(FK+1.0E0)
      PT = P2
      P2 = BK*P2 - AK*P1
      P1 = PT
      A(K) = AK
      B(K) = BK
      CK = CK + 2.0E0
      FKS = FKS + FK + FK + 1.0E0
      FHS = FHS + FK + FK
      IF (ETEST.GT.FK*P1) GO TO 140
      KK = K
      S = 1.0E0
      P1 = 0.0E0
      P2 = 1.0E0
      DO 150 I=1,K
        PT = P2
        P2 = (B(KK)*P2-P1)/A(KK)
        P1 = PT
        S = S + P2
        KK = KK - 1
  150 CONTINUE
      S1 = COEF*(P2/S)
      IF (INU.GT.0 .OR. N.GT.1) GO TO 160
      GO TO 200
  160 CONTINUE
      S2 = S1*(X+DNU+0.5E0-P1/P2)/X
C
C     FORWARD RECURSION ON THE THREE TERM RECURSION RELATION
C
  170 CONTINUE
      CK = (DNU+DNU+2.0E0)/X
      IF (N.EQ.1) INU = INU - 1
      IF (INU.GT.0) GO TO 180
      IF (N.GT.1) GO TO 200
      S1 = S2
      GO TO 200
  180 CONTINUE
      DO 190 I=1,INU
        ST = S2
        S2 = CK*S2 + S1
        S1 = ST
        CK = CK + RX
  190 CONTINUE
      IF (N.EQ.1) S1 = S2
  200 CONTINUE
      IF (IFLAG.EQ.1) GO TO 220
      Y(1) = S1
      IF (N.EQ.1) RETURN
      Y(2) = S2
      IF (N.EQ.2) RETURN
      DO 210 I=3,N
        Y(I) = CK*Y(I-1) + Y(I-2)
        CK = CK + RX
  210 CONTINUE
      RETURN
C     IFLAG=1 CASES
  220 CONTINUE
      S = -X + LOG(S1)
      Y(1) = 0.0E0
      NZ = 1
      IF (S.LT.-ELIM) GO TO 230
      Y(1) = EXP(S)
      NZ = 0
  230 CONTINUE
      IF (N.EQ.1) RETURN
      S = -X + LOG(S2)
      Y(2) = 0.0E0
      NZ = NZ + 1
      IF (S.LT.-ELIM) GO TO 240
      NZ = NZ - 1
      Y(2) = EXP(S)
  240 CONTINUE
      IF (N.EQ.2) RETURN
      KK = 2
      IF (NZ.LT.2) GO TO 260
      DO 250 I=3,N
        KK = I
        ST = S2
        S2 = CK*S2 + S1
        S1 = ST
        CK = CK + RX
        S = -X + LOG(S2)
        NZ = NZ + 1
        Y(I) = 0.0E0
        IF (S.LT.-ELIM) GO TO 250
        Y(I) = EXP(S)
        NZ = NZ - 1
        GO TO 260
  250 CONTINUE
      RETURN
  260 CONTINUE
      IF (KK.EQ.N) RETURN
      S2 = S2*CK + S1
      CK = CK + RX
      KK = KK + 1
      Y(KK) = EXP(-X+LOG(S2))
      IF (KK.EQ.N) RETURN
      KK = KK + 1
      DO 270 I=KK,N
        Y(I) = CK*Y(I-1) + Y(I-2)
        CK = CK + RX
  270 CONTINUE
      RETURN
C
C     ASYMPTOTIC EXPANSION FOR LARGE X, X.GT.X2
C
C     IFLAG=0 MEANS NO UNDERFLOW OCCURRED
C     IFLAG=1 MEANS AN UNDERFLOW OCCURRED- COMPUTATION PROCEEDS WITH
C     KODED=2 AND A TEST FOR ON SCALE VALUES IS MADE DURING FORWARD
C     RECURSION
  280 CONTINUE
      NN = 2
      IF (INU.EQ.0 .AND. N.EQ.1) NN = 1
      DNU2 = DNU + DNU
      FMU = 0.0E0
      IF (ABS(DNU2).LT.TOL) GO TO 290
      FMU = DNU2*DNU2
  290 CONTINUE
      EX = X*8.0E0
      S2 = 0.0E0
      DO 320 K=1,NN
        S1 = S2
        S = 1.0E0
        AK = 0.0E0
        CK = 1.0E0
        SQK = 1.0E0
        DK = EX
        DO 300 J=1,30
          CK = CK*(FMU-SQK)/DK
          S = S + CK
          DK = DK + EX
          AK = AK + 8.0E0
          SQK = SQK + AK
          IF (ABS(CK).LT.TOL) GO TO 310
  300   CONTINUE
  310   S2 = S*COEF
        FMU = FMU + 8.0E0*DNU + 4.0E0
  320 CONTINUE
      IF (NN.GT.1) GO TO 170
      S1 = S2
      GO TO 200
  330 CONTINUE
      KODED = 2
      IFLAG = 1
      GO TO 120
C
C     FNU=HALF ODD INTEGER CASE
C
  340 CONTINUE
      S1 = COEF
      S2 = COEF
      GO TO 170
C
C
  350 CONTINUE
      WRITE(ICOUT,351)
  351 FORMAT('** ERROR FROM BESKNU, X IS LESS THAN OR EQUAL TO ZERO. ')
      CALL DPWRST('XXX','BUG ')
      RETURN
  360 CONTINUE
      WRITE(ICOUT,361)
  361 FORMAT('***** ERROR FROM BESKNU, THE ORDER FNU IS NEGATIVE. ***')
      CALL DPWRST('XXX','BUG ')
      RETURN
  370 CONTINUE
      WRITE(ICOUT,371)
  371 FORMAT('***** ERROR FROM BESKNU, KODE IS NOT 1 OR 2. ***')
      CALL DPWRST('XXX','BUG ')
      RETURN
  380 CONTINUE
      WRITE(ICOUT,381)
  381 FORMAT('***** ERROR FROM BESKNU, N IS LESS THAN ONE.. ***')
      CALL DPWRST('XXX','BUG ')
      RETURN
      END
      FUNCTION BESK0 (X)
C***BEGIN PROLOGUE  BESK0
C***PURPOSE  Compute the modified (hyperbolic) Bessel function of the
C            third kind of order zero.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C10B1
C***TYPE      SINGLE PRECISION (BESK0-S, DBESK0-D)
C***KEYWORDS  FNLIB, HYPERBOLIC BESSEL FUNCTION,
C             MODIFIED BESSEL FUNCTION, ORDER ZERO, SPECIAL FUNCTIONS,
C             THIRD KIND
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C BESK0(X) calculates the modified (hyperbolic) Bessel function
C of the third kind of order zero for real argument X .GT. 0.0.
C
C Series for BK0        on the interval  0.          to  4.00000D+00
C                                        with weighted error   3.57E-19
C                                         log weighted error  18.45
C                               significant figures required  17.99
C                                    decimal places required  18.97
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  BESI0, BESK0E, CSEVL, INITS, R1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770401  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C***END PROLOGUE  BESK0
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DIMENSION BK0CS(11)
      LOGICAL FIRST
      SAVE BK0CS, NTK0, XSML, XMAX, FIRST
      DATA BK0CS( 1) /   -.0353273932 3390276872E0 /
      DATA BK0CS( 2) /    .3442898999 246284869E0 /
      DATA BK0CS( 3) /    .0359799365 1536150163E0 /
      DATA BK0CS( 4) /    .0012646154 1144692592E0 /
      DATA BK0CS( 5) /    .0000228621 2103119451E0 /
      DATA BK0CS( 6) /    .0000002534 7910790261E0 /
      DATA BK0CS( 7) /    .0000000019 0451637722E0 /
      DATA BK0CS( 8) /    .0000000000 1034969525E0 /
      DATA BK0CS( 9) /    .0000000000 0004259816E0 /
      DATA BK0CS(10) /    .0000000000 0000013744E0 /
      DATA BK0CS(11) /    .0000000000 0000000035E0 /
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  BESK0
      IF (FIRST) THEN
         NTK0 = INITS (BK0CS, 11, 0.1*R1MACH(3))
         XSML = SQRT (4.0*R1MACH(3))
         XMAXT = -LOG(R1MACH(1))
         XMAX = XMAXT - 0.5*XMAXT*LOG(XMAXT)/(XMAXT+0.5) - 0.01
      ENDIF
      FIRST = .FALSE.
C
      IF (X .LE. 0.) THEN
        WRITE(ICOUT,1)
    1   FORMAT('***** ERORR FROM BESK0, X IS ZERO OR NEGATIVE.  *****')
        CALL DPWRST('XXX','BUG ')
        BESK0 = 0.0
        RETURN
      ENDIF
      IF (X.GT.2.) GO TO 20
C
      Y = 0.
      IF (X.GT.XSML) Y = X*X
      BESK0 = -LOG(0.5*X)*BESI0(X) - .25 + CSEVL (.5*Y-1., BK0CS, NTK0)
      RETURN
C
 20   BESK0 = 0.
      IF (X.GT.XMAX) THEN
        WRITE(ICOUT,2)
        CALL DPWRST('XXX','BUG ')
        BESK0 = 0.0
        RETURN
      ENDIF
    2 FORMAT('***** ERORR FROM BESK0, UNDERFLOWS BECAUSE THE ',
     1       'VALUE OF X IS TOO BIG.  ****')
      IF (X.GT.XMAX) RETURN
C
      BESK0 = EXP(-X) * BESK0E(X)
C
      RETURN
      END
      FUNCTION BESK0E (X)
C***BEGIN PROLOGUE  BESK0E
C***PURPOSE  Compute the exponentially scaled modified (hyperbolic)
C            Bessel function of the third kind of order zero.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C10B1
C***TYPE      SINGLE PRECISION (BESK0E-S, DBSK0E-D)
C***KEYWORDS  EXPONENTIALLY SCALED, FNLIB, HYPERBOLIC BESSEL FUNCTION,
C             MODIFIED BESSEL FUNCTION, ORDER ZERO, SPECIAL FUNCTIONS,
C             THIRD KIND
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C BESK0E(X) computes the exponentially scaled modified (hyperbolic)
C Bessel function of third kind of order zero for real argument
C X .GT. 0.0, i.e., EXP(X)*K0(X).
C
C Series for BK0        on the interval  0.          to  4.00000D+00
C                                        with weighted error   3.57E-19
C                                         log weighted error  18.45
C                               significant figures required  17.99
C                                    decimal places required  18.97
C
C Series for AK0        on the interval  1.25000D-01 to  5.00000D-01
C                                        with weighted error   5.34E-17
C                                         log weighted error  16.27
C                               significant figures required  14.92
C                                    decimal places required  16.89
C
C Series for AK02       on the interval  0.          to  1.25000D-01
C                                        with weighted error   2.34E-17
C                                         log weighted error  16.63
C                               significant figures required  14.67
C                                    decimal places required  17.20
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  BESI0, CSEVL, INITS, R1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770401  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C***END PROLOGUE  BESK0E
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DIMENSION BK0CS(11), AK0CS(17), AK02CS(14)
      LOGICAL FIRST
      SAVE BK0CS, AK0CS, AK02CS, NTK0, NTAK0, NTAK02, XSML, FIRST
      DATA BK0CS( 1) /   -.0353273932 3390276872E0 /
      DATA BK0CS( 2) /    .3442898999 246284869E0 /
      DATA BK0CS( 3) /    .0359799365 1536150163E0 /
      DATA BK0CS( 4) /    .0012646154 1144692592E0 /
      DATA BK0CS( 5) /    .0000228621 2103119451E0 /
      DATA BK0CS( 6) /    .0000002534 7910790261E0 /
      DATA BK0CS( 7) /    .0000000019 0451637722E0 /
      DATA BK0CS( 8) /    .0000000000 1034969525E0 /
      DATA BK0CS( 9) /    .0000000000 0004259816E0 /
      DATA BK0CS(10) /    .0000000000 0000013744E0 /
      DATA BK0CS(11) /    .0000000000 0000000035E0 /
      DATA AK0CS( 1) /   -.0764394790 3327941E0 /
      DATA AK0CS( 2) /   -.0223565260 5699819E0 /
      DATA AK0CS( 3) /    .0007734181 1546938E0 /
      DATA AK0CS( 4) /   -.0000428100 6688886E0 /
      DATA AK0CS( 5) /    .0000030817 0017386E0 /
      DATA AK0CS( 6) /   -.0000002639 3672220E0 /
      DATA AK0CS( 7) /    .0000000256 3713036E0 /
      DATA AK0CS( 8) /   -.0000000027 4270554E0 /
      DATA AK0CS( 9) /    .0000000003 1694296E0 /
      DATA AK0CS(10) /   -.0000000000 3902353E0 /
      DATA AK0CS(11) /    .0000000000 0506804E0 /
      DATA AK0CS(12) /   -.0000000000 0068895E0 /
      DATA AK0CS(13) /    .0000000000 0009744E0 /
      DATA AK0CS(14) /   -.0000000000 0001427E0 /
      DATA AK0CS(15) /    .0000000000 0000215E0 /
      DATA AK0CS(16) /   -.0000000000 0000033E0 /
      DATA AK0CS(17) /    .0000000000 0000005E0 /
      DATA AK02CS( 1) /   -.0120186982 6307592E0 /
      DATA AK02CS( 2) /   -.0091748526 9102569E0 /
      DATA AK02CS( 3) /    .0001444550 9317750E0 /
      DATA AK02CS( 4) /   -.0000040136 1417543E0 /
      DATA AK02CS( 5) /    .0000001567 8318108E0 /
      DATA AK02CS( 6) /   -.0000000077 7011043E0 /
      DATA AK02CS( 7) /    .0000000004 6111825E0 /
      DATA AK02CS( 8) /   -.0000000000 3158592E0 /
      DATA AK02CS( 9) /    .0000000000 0243501E0 /
      DATA AK02CS(10) /   -.0000000000 0020743E0 /
      DATA AK02CS(11) /    .0000000000 0001925E0 /
      DATA AK02CS(12) /   -.0000000000 0000192E0 /
      DATA AK02CS(13) /    .0000000000 0000020E0 /
      DATA AK02CS(14) /   -.0000000000 0000002E0 /
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  BESK0E
      IF (FIRST) THEN
         NTK0 = INITS (BK0CS, 11, 0.1*R1MACH(3))
         NTAK0 = INITS (AK0CS, 17, 0.1*R1MACH(3))
         NTAK02 = INITS (AK02CS, 14, 0.1*R1MACH(3))
         XSML = SQRT (4.0*R1MACH(3))
      ENDIF
      FIRST = .FALSE.
C
      IF (X .LE. 0.) THEN
        WRITE(ICOUT,1)
    1   FORMAT('***** ERORR FROM BESK0E, X ZERO OR NEGATIVE.  *******')
        CALL DPWRST('XXX','BUG ')
        BESK0E=0.0
        RETURN
      ENDIF
      IF (X.GT.2.) GO TO 20
C
      Y = 0.
      IF (X.GT.XSML) Y = X*X
      BESK0E = EXP(X) * (-LOG(0.5*X)*BESI0(X)
     1  - .25 + CSEVL (.5*Y-1., BK0CS, NTK0) )
      RETURN
C
 20   IF (X.LE.8.) BESK0E = (1.25 + CSEVL ((16./X-5.)/3., AK0CS, NTAK0))
     1  / SQRT(X)
      IF (X.GT.8.) BESK0E = (1.25 + CSEVL (16./X-1., AK02CS, NTAK02))
     1  / SQRT(X)
C
      RETURN
      END
      FUNCTION BESK1 (X)
C***BEGIN PROLOGUE  BESK1
C***PURPOSE  Compute the modified (hyperbolic) Bessel function of the
C            third kind of order one.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C10B1
C***TYPE      SINGLE PRECISION (BESK1-S, DBESK1-D)
C***KEYWORDS  FNLIB, HYPERBOLIC BESSEL FUNCTION,
C             MODIFIED BESSEL FUNCTION, ORDER ONE, SPECIAL FUNCTIONS,
C             THIRD KIND
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C BESK1(X) computes the modified (hyperbolic) Bessel function of third
C kind of order one for real argument X, where X .GT. 0.
C
C Series for BK1        on the interval  0.          to  4.00000D+00
C                                        with weighted error   7.02E-18
C                                         log weighted error  17.15
C                               significant figures required  16.73
C                                    decimal places required  17.67
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  BESI1, BESK1E, CSEVL, INITS, R1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770401  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C***END PROLOGUE  BESK1
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DIMENSION BK1CS(11)
      LOGICAL FIRST
      SAVE BK1CS, NTK1, XMIN, XSML, XMAX, FIRST
      DATA BK1CS( 1) /    .0253002273 389477705E0 /
      DATA BK1CS( 2) /   -.3531559607 76544876E0 /
      DATA BK1CS( 3) /   -.1226111808 22657148E0 /
      DATA BK1CS( 4) /   -.0069757238 596398643E0 /
      DATA BK1CS( 5) /   -.0001730288 957513052E0 /
      DATA BK1CS( 6) /   -.0000024334 061415659E0 /
      DATA BK1CS( 7) /   -.0000000221 338763073E0 /
      DATA BK1CS( 8) /   -.0000000001 411488392E0 /
      DATA BK1CS( 9) /   -.0000000000 006666901E0 /
      DATA BK1CS(10) /   -.0000000000 000024274E0 /
      DATA BK1CS(11) /   -.0000000000 000000070E0 /
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  BESK1
      IF (FIRST) THEN
         NTK1 = INITS (BK1CS, 11, 0.1*R1MACH(3))
         XMIN = EXP (MAX(LOG(R1MACH(1)), -LOG(R1MACH(2))) + .01)
         XSML = SQRT (4.0*R1MACH(3))
         XMAXT = -LOG(R1MACH(1))
         XMAX = XMAXT - 0.5*XMAXT*LOG(XMAXT)/(XMAXT+0.5)
      ENDIF
      FIRST = .FALSE.
C
      IF (X .LE. 0.) THEN
        WRITE(ICOUT,1)
    1   FORMAT('***** ERORR FROM BESK1, X ZERO OR NEGATIVE.  *******')
        CALL DPWRST('XXX','BUG ')
        BESK1=0.0
        RETURN
      ENDIF
      IF (X.GT.2.0) GO TO 20
C
      IF (X .LE. XMIN) THEN
        WRITE(ICOUT,2)
        CALL DPWRST('XXX','BUG ')
      ENDIF
    2 FORMAT('***** WARNING FROM BESK1, UNDERFLOW BECAUSE THE ',
     1       'VALUE OF X IS SO SMALL.  ****')
      Y = 0.
      IF (X.GT.XSML) Y = X*X
      BESK1 = LOG(0.5*X)*BESI1(X) +
     1  (0.75 + CSEVL (.5*Y-1., BK1CS, NTK1))/X
      RETURN
C
 20   BESK1 = 0.
      IF (X.GT.XMAX) THEN
        WRITE(ICOUT,3)
        CALL DPWRST('XXX','BUG ')
        BESK1 = 0.0
        RETURN
      ENDIF
    3 FORMAT('***** ERORR FROM BESK1, UNDERFLOW BECAUSE THE ',
     1       'VALUE OF X IS TOO BIG.  ****')
      IF (X.GT.XMAX) RETURN
C
      BESK1 = EXP(-X) * BESK1E(X)
C
      RETURN
      END
      FUNCTION BESK1E (X)
C***BEGIN PROLOGUE  BESK1E
C***PURPOSE  Compute the exponentially scaled modified (hyperbolic)
C            Bessel function of the third kind of order one.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C10B1
C***TYPE      SINGLE PRECISION (BESK1E-S, DBSK1E-D)
C***KEYWORDS  EXPONENTIALLY SCALED, FNLIB, HYPERBOLIC BESSEL FUNCTION,
C             MODIFIED BESSEL FUNCTION, ORDER ONE, SPECIAL FUNCTIONS,
C             THIRD KIND
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C BESK1E(X) computes the exponentially scaled modified (hyperbolic)
C Bessel function of third kind of order one for real argument
C X .GT. 0.0, i.e., EXP(X)*K1(X).
C
C Series for BK1        on the interval  0.          to  4.00000D+00
C                                        with weighted error   7.02E-18
C                                         log weighted error  17.15
C                               significant figures required  16.73
C                                    decimal places required  17.67
C
C Series for AK1        on the interval  1.25000D-01 to  5.00000D-01
C                                        with weighted error   6.06E-17
C                                         log weighted error  16.22
C                               significant figures required  15.41
C                                    decimal places required  16.83
C
C Series for AK12       on the interval  0.          to  1.25000D-01
C                                        with weighted error   2.58E-17
C                                         log weighted error  16.59
C                               significant figures required  15.22
C                                    decimal places required  17.16
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  BESI1, CSEVL, INITS, R1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770401  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C***END PROLOGUE  BESK1E
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DIMENSION BK1CS(11), AK1CS(17), AK12CS(14)
      LOGICAL FIRST
      SAVE BK1CS, AK1CS, AK12CS, NTK1, NTAK1, NTAK12, XMIN, XSML,
     1 FIRST
      DATA BK1CS( 1) /    .0253002273 389477705E0 /
      DATA BK1CS( 2) /   -.3531559607 76544876E0 /
      DATA BK1CS( 3) /   -.1226111808 22657148E0 /
      DATA BK1CS( 4) /   -.0069757238 596398643E0 /
      DATA BK1CS( 5) /   -.0001730288 957513052E0 /
      DATA BK1CS( 6) /   -.0000024334 061415659E0 /
      DATA BK1CS( 7) /   -.0000000221 338763073E0 /
      DATA BK1CS( 8) /   -.0000000001 411488392E0 /
      DATA BK1CS( 9) /   -.0000000000 006666901E0 /
      DATA BK1CS(10) /   -.0000000000 000024274E0 /
      DATA BK1CS(11) /   -.0000000000 000000070E0 /
      DATA AK1CS( 1) /    .2744313406 973883E0 /
      DATA AK1CS( 2) /    .0757198995 3199368E0 /
      DATA AK1CS( 3) /   -.0014410515 5647540E0 /
      DATA AK1CS( 4) /    .0000665011 6955125E0 /
      DATA AK1CS( 5) /   -.0000043699 8470952E0 /
      DATA AK1CS( 6) /    .0000003540 2774997E0 /
      DATA AK1CS( 7) /   -.0000000331 1163779E0 /
      DATA AK1CS( 8) /    .0000000034 4597758E0 /
      DATA AK1CS( 9) /   -.0000000003 8989323E0 /
      DATA AK1CS(10) /    .0000000000 4720819E0 /
      DATA AK1CS(11) /   -.0000000000 0604783E0 /
      DATA AK1CS(12) /    .0000000000 0081284E0 /
      DATA AK1CS(13) /   -.0000000000 0011386E0 /
      DATA AK1CS(14) /    .0000000000 0001654E0 /
      DATA AK1CS(15) /   -.0000000000 0000248E0 /
      DATA AK1CS(16) /    .0000000000 0000038E0 /
      DATA AK1CS(17) /   -.0000000000 0000006E0 /
      DATA AK12CS( 1) /    .0637930834 3739001E0 /
      DATA AK12CS( 2) /    .0283288781 3049721E0 /
      DATA AK12CS( 3) /   -.0002475370 6739052E0 /
      DATA AK12CS( 4) /    .0000057719 7245160E0 /
      DATA AK12CS( 5) /   -.0000002068 9392195E0 /
      DATA AK12CS( 6) /    .0000000097 3998344E0 /
      DATA AK12CS( 7) /   -.0000000005 5853361E0 /
      DATA AK12CS( 8) /    .0000000000 3732996E0 /
      DATA AK12CS( 9) /   -.0000000000 0282505E0 /
      DATA AK12CS(10) /    .0000000000 0023720E0 /
      DATA AK12CS(11) /   -.0000000000 0002176E0 /
      DATA AK12CS(12) /    .0000000000 0000215E0 /
      DATA AK12CS(13) /   -.0000000000 0000022E0 /
      DATA AK12CS(14) /    .0000000000 0000002E0 /
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  BESK1E
      IF (FIRST) THEN
         NTK1 = INITS (BK1CS, 11, 0.1*R1MACH(3))
         NTAK1 = INITS (AK1CS, 17, 0.1*R1MACH(3))
         NTAK12 = INITS (AK12CS, 14, 0.1*R1MACH(3))
C
         XMIN = EXP (MAX(LOG(R1MACH(1)), -LOG(R1MACH(2))) + .01)
         XSML = SQRT (4.0*R1MACH(3))
      ENDIF
      FIRST = .FALSE.
C
      IF (X .LE. 0.) THEN
        WRITE(ICOUT,1)
    1   FORMAT('***** ERORR FROM BESK1E, X ZERO OR NEGATIVE.  *******')
        CALL DPWRST('XXX','BUG ')
        BESK1E=0.0
        RETURN
      ENDIF
      IF (X.GT.2.0) GO TO 20
C
      IF (X .LT. XMIN) THEN
        WRITE(ICOUT,2)
        CALL DPWRST('XXX','BUG ')
        BESK1E = 0.0
        RETURN
      ENDIF
    2 FORMAT('***** ERROR FROM BESK1E, OVERRFLOW BECAUSE THE ',
     1       'VALUE OF X IS SO SMALL.  ****')
      Y = 0.
      IF (X.GT.XSML) Y = X*X
      BESK1E = EXP(X) * (LOG(0.5*X)*BESI1(X) +
     1  (0.75 + CSEVL (.5*Y-1., BK1CS, NTK1))/X )
      RETURN
C
 20   IF (X.LE.8.) BESK1E = (1.25 + CSEVL ((16./X-5.)/3., AK1CS, NTAK1))
     1  / SQRT(X)
      IF (X.GT.8.) BESK1E = (1.25 + CSEVL (16./X-1., AK12CS, NTAK12))
     1  / SQRT(X)
C
      RETURN
      END
      SUBROUTINE BESICF(ZZ,AA,NMAX,BI)
C THIS ROUTINE CALCULATES BESSEL FUNCTIONS I OF COMPLEX ARGUMENT AND
C REAL ORDER.  ARGUMENTS ARE AS FOR BESJCF, EXCEPT THAT HERE, IT IS REAL
C PART OF ZZ THAT MUST NOT EXCEED EXPARG IN ABSOLUTE VALUE
C EQUATION 9.6.3 OF REFERENCE 1 AS LISTED IN BESJCF IS USED 
      COMPLEX ZZ,BI(*),BB,CC,ZDUMMY
C
C Definition of real and imaginary parts of complex number,
C standard Fortran and will work on Convex with -r8 -i8.
      REALP(ZDUMMY) = REAL(ZDUMMY)
      AIMAGP(ZDUMMY) = REAL((0,-1)*ZDUMMY)
C
      CC=(0.,1.)
      IF(AIMAGP(ZZ).LT.0.) CC=-CC
      BB=-CC*ZZ
      CALL BESJCF(BB,AA,NMAX,BI)
      ANGLE= 1.5707963267949*AA*AIMAGP(CC)
      BB=CMPLX(COS(ANGLE),SIN(ANGLE))
      BI(1)=-CC*BB*BI(1)
      MAXP=NMAX+2
      DO 1 N=2,MAXP 
      BI(N)=BI(N)*BB
    1 BB=CC*BB
      RETURN
      END 
      SUBROUTINE BESJCF(ZZ,AA,NMAX,BJ)
C THIS ROUTINE CALCULATES BESSEL FUNCTIONS J OF COMPLEX ARGUMENT AND
C REAL ORDER
C ROUTINE WRITTEN AND TESTED BY DAVID SAGIN (SOOKNE), COMPUTER CENTER,
C TEL-AVIV UNIVERSITY.  ROUTINE DATED 3/3/77
C
C DESCRIPTION OF VARIABLES IN THE CALLING VECTOR
C
C ZZ   COMPLEX ARGUMENT. LIMITATIONS ARE  ABS(AIMAG(ZZ)).LT.EXPARG (SEE
C      BELOW), AND ZZ*CONJG(ZZ) NOT ZERO IN THE COMPUTER
C AA   FRACTIONAL PART OF REAL ORDER FOR WHICH J*S AND/OR Y*S ARE TO BE
C      CALCULATED.  AA MUST BE GREATER THAN -.5 AND AT MOST +.5.
C NMAX NON-NEGATIVE INTEGER SUCH THAT NMAX+AA IS THE HIGHEST ORDER YOU
C      WANT.
C BJ   COMPLEX VECTOR OF LENGTH NMAX+2, IN
C      WHICH BESLCF RETURNS J*S OF ORDERS AA-1, AA, AA+1,...AA+NMAX.
C
C NUMBERS IN PARENTHESES (IN COMMENT CARDS BELOW) REFER TO THESE
C REFERENCES
C 1) MILTON ABRAMOWITZ AND IRENE A. STEGUN, HANDBOOK OF MATHEMATICAL
C    FUNCTIONS, NATIONAL BUREAU OF STANDARDS, 1964
C 2) M. GOLDSTEIN AND R. M. THALER, RECURRENCE TECHNIQUES FOR THE CALCU-
C    LATION OF BESSEL FUNCTIONS, MATHEMATICS OF COMPUTATION, VOLUME 13,
C    APRIL 1959, PAGE 102
C 3) F. W. J. OLVER AND D. J. SOOKNE, NOTE ON BACKWARD RECURRENCE ALGO-
C    RITHMS, MATHEMATICS OF COMPUTATION, VOLUME 26, OCT. 1972, PAGE 941
C 4) DAVID J. SOOKNE, BESSEL FUNCTIONS OF COMPLEX ARGUMENT AND INTEGER
C    ORDER, JOURNAL OF RESEARCH OF THE NATIONAL BUREAU OF STANDARDS,
C    SERIES B, VOLUME 77A, JULY-DEC. 1973, PAGE 111
C 5) A. ERDELYI ET AL., HIGHER TRANSCENDENTAL FUNCTIONS, VOLUME 2
C    CHAPTER 7, MCGRAW-HILL, NEW YORK, 1953
C
C  NOTE.
C     THIS ROUTINE CALLS A FUNCTION GAM1(X) WHICH RETURNS THE GAMMA
C     FUNCTION OF X FOR POSITIVE X .LE. GAML. SEE THE DEFINITION OF
C     GAML UNDER MACHINE DEPENDENT CONSTANTS BELOW.
C
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOMC.INC'
      DOUBLE PRECISION DGAMMA
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      COMPLEX BJ(*),B,BA1,BB,BBB,BD,FAC,SUM,Z,ZI,ZP,ZZ,ZDUMMY
C Note: Old variable LOG changed to LOGICL by D.W. Lozier, 4/27/88, to
C avoid conflict with generic function.
      LOGICAL LOGICL(4)
C-----------------------------------------------------------------------
C
C  MACHINE DEPENDENT CONSTANTS.
C  ---------------------------
C
      SAVE ISAVE, SQRTPI, DYOUK, EXPARG, GAML, LOU
      DATA ISAVE /1/
C
C Definition of real and imaginary parts of complex number,
C standard Fortran and will work on Convex with -r8 -i8.
      REALP(ZDUMMY) = REAL(ZDUMMY)
      AIMAGP(ZDUMMY) = REAL((0,-1)*ZDUMMY)
C
      IF (ISAVE.GT.0) THEN
        ISAVE = 0
C SQUARE ROOT OF PI, MACHINE ACCURACY, AND LIMIT ON ARGUMENT TO EXP
        SQRTPI = SQRT (4.0*ATAN (1.0))
        DYOUK = R1MACH (4)
        EXPARG = LOG (R1MACH (2))
C GAML IS AN INTEGER (PREFERABLY THE SMALLEST) SUCH THAT
C 1./(1680*LGAMMA(GAML)*GAML**7).LE.DYOUK.   SEE FORMULA 6.1.41 OF (1)
C Note: Code changed 4/27/88 by D.W. Lozier to prevent integer overflow.
C Previously, an integer factorial was formed, then the log was taken.
C In IEEE double precision, GAML=32 and i! overflows, causing the old
C code to fail.
        I = 2
        GAMLF = LOG(2.0)
    6   I = I + 1
        GAML = I
        GAMLF = GAMLF + LOG(GAML)
        IF ((1680.0*GAMLF*(GAML**7)*DYOUK) .LT. 1.0) GO TO 6
        LOU = I1MACH(2)
      ENDIF
C
C-----------------------------------------------------------------------
      Z=ZZ
      A=AA
      N=NMAX
      E=REALP(Z)**2+AIMAGP(Z)**2
C CHECK THAT INPUT DATA IS LEGAL
      IF ((A .LE. -0.5) .OR. (A .GT. 0.5) .OR.
     *  (ABS(AIMAGP(Z)) .GT. EXPARG) .OR. (E .EQ. 0.) .OR. (N .LT. 0))
     *  GO TO 86
      MAXN=N
      MAXP=2+MAXN
C AVOID UNDERFLOW OR OVERFLOW IN COMPLEX DIVIDE
      F=1./MAX(ABS(REALP(Z)),ABS(AIMAGP(Z)))
      ZI=2.*F/(Z*F) 
      BD=LOG(.5*Z)
      ZP=EXP(A*BD)
      BBB=ZP/REAL(DGAMMA(DBLE(1.+A)))
      LOGICL(1)=MAXN.LE.0
      LOGICL(3)=E.LE.DYOUK
      LOGICL(4)=A.EQ.0.
      FAC = (1.0, 0.0)
      IF(LOGICL(3)) GO TO 72
C ROUTINE BACALC RETURNS N AND B (=J-SUB(N+A)OF-X) WITH WHICH TO START
C CALCULATING J*S VIA BACK RECURSION
      CALL BACKLC(Z,A,N,B)
      K=(N+1)/2
      IF(N.LE.MAXN) GO TO 80
C
C INITIALIZE VARIABLES FOR THE BACK-RECURSION.  COEF IS THE COEFFICIENT
C OF THE NORMALIZATION SUM, AND FAC IS USED IN CALCULATING THE NORMALI-
C ZATION FACTOR.  THESE ARE CALCULATED VIA EQUATION 44 OF CHAPTER 7.15
C OF (5) IF A.NE.0.  IN THIS CASE, COS(PHI) IS ZERO OR 1 DEPENDING ON 
C WHETHER ABS(COS(Z)) IS LESS THAN 1 OR GREATER THAN 1 RESPECTIVELY.
C IF A.EQ.0, THE NORMALIZATION IS VIA EQUATION 9.1.46 OR 9.1.47 OF (1),
C DEPENDING OR COS(Z).
C
    8 COEF=2.
      KD=1
      BB=COS(Z)
      LOGICL(2)=.FALSE.
      IF(ABS(BB).LE.1.) GO TO 11
      KD=2
      FAC=BB
      LOGICL(2)=.TRUE.
   11 IF(LOGICL(4)) GO TO 14
      D=REAL(KD*K)
      G=A*REAL(KD)
      C=D+G
      F=2.+A/REAL(K)
      IF(LOGICL(2)) F=F*SQRTPI/(REAL(DGAMMA(DBLE(A+.5)))*2.**(2.*A))
      IF(C.GT.GAML) GO TO 12
      COEF=F*REAL(DGAMMA(DBLE(C)))/REAL(DGAMMA(DBLE(D)))
      GO TO 14
   12 E=C*D
      COEF=(D-.5)*LOG(C/D)+G*(LOG(C)-1.-
     1(1.-(C*C+E+D*D-(C**4+C*C*E+E*E+D*D*E+D**4)/(3.5*E*E))/(30.*E*E))
     2/(12.*E))
      COEF=F*EXP(COEF)
   14 BB = (0.0, 0.0)
      SUM = (0.0, 0.0)
      G=1.
      IF(LOGICL(2).AND.K.NE.2*(K/2)) COEF=-COEF
      LOGICL(3)=2*K.NE.N
      IF(LOGICL(3)) GO TO 20
      SUM=COEF*B
C USING 9.1.27 OF (1) (EQUATION 1 OF (4) IS THE ANALOG FOR INTEGER
C ORDERS), CALCULATE UNNORMALIZED J*S OF ORDERS N-1+A, N-2+A,...A.
C ACCUMULATE THE NORMALIZATION SUM AS DESCRIBED ABOVE.
   20 E=REAL(N)+A
      N=N-1
      BBB=BB
      BB=B
      B=(ZI*E)*BB-BBB
      IF(LOGICL(1)) GO TO 22
      IF(N.LE.MAXN) BJ(N+2)=B 
   22 LOGICL(3)=.NOT.LOGICL(3)
      IF(LOGICL(3)) GO TO 20
      D=REAL(K)
      K=K-1
      F=REAL(K)+A
      IF(LOGICL(4)) GO TO 24
      G=D*(REAL(N)+A)/(F*(E+1.))
      COEF=COEF*G
      IF(LOGICL(2)) COEF=COEF*REAL(N+1)/(2.*F+1.) 
   24 IF(LOGICL(2)) COEF=-COEF
      IF(N.EQ.0) GO TO 28
      SUM=SUM+COEF*B
      GO TO 20
   28 BA1=(ZI*A)*B-BB
      IF(LOGICL(4)) COEF=1.
C THE BACK-RECURSION IS FINISHED.  CALCULATE THE NORMALIZATION FACTOR 
      SUM=SUM+COEF*B
      F=1./MAX(ABS(REALP(SUM)),ABS(AIMAGP(SUM)))
      FAC=ZP*(F*(FAC/(CMPLX(REALP(SUM)*F,AIMAGP(SUM)*F))))
      BJ(1)=BA1*FAC 
      BJ(2)=B*FAC
      IF(MAXN.EQ.0) GO TO 70
      DO 34 M=3,MAXP
   34 BJ(M)=FAC*BJ(M)
C
C THIS IS THE ONLY RETURN STATEMENT IN THE ROUTINE
C
   70 RETURN
C
C FOR VERY SMALL Z, CALCULATE J*S VIA ASYMPTOTIC FORMULA 9.1.7 OF (1) 
C
   72 BJ(2)=BBB
      BB=(Z*BJ(2))*(.5/(1.+A))
      BJ(1)=-BB
      IF(.NOT.LOGICL(4)) BJ(1)=(ZI*BJ(2))*AA
      IF(MAXP.GE.3) BJ(3)=BB
      IF(MAXP.LT.4) GO TO 70
      DO 74 N=4,MAXP
   74 BJ(N)=(Z*BJ(N-1))*(.5/(A+REAL(N-2)))
      GO TO 70
C UNDERFLOW. SET J*S ZERO
   80 DO 81 M=N,MAXN
   81 BJ(M + 2) = (0.0, 0.0)
      BJ(N+2)=B
      GO TO 8
C CONK OUT
   86 CONTINUE
      WRITE (ICOUT, 88)
      CALL DPWRST('XXX','BUG')
      WRITE (ICOUT, 89) N, A, Z 
      CALL DPWRST('XXX','BUG')
   88 FORMAT('***** FATAL ERROR (BESJCF) --- INVALID INPUT ')
   89 FORMAT('      NMAX = ',I6,' A = ',1PE22.14,' Z = ',2(1PE22.14))
      RETURN
      END 
      SUBROUTINE BESKCF(ZZ,AA,NMAX,BK)
C THIS ROUTINE CALCULATES BESSEL FUNCTIONS K OF COMPLEX ARGUMENT AND
C REAL ORDER.  ARGUMENTS ARE AS FOR ROUTINE BESJCF, EXCEPT HERE IT IS 
C REAL(ZZ) WHICH MUST NOT EXCEED EXPARG IN ABSOLUTE VALUE
C K*S ARE CALCULATED BY FORWARD RECURSION, USING EQUATION 1.9 OF THE
C REFERENCE LISTED IN ROUTINE RECIPG.  TO START THE RECURSION, FUNCTION
C VALUES OF ORDERS A AND A+1 ARE CALCULATED IF A.LE.0, WHILE ORDERS A 
C AND A-1 ARE CALCULATED IF A.GT.0.
C NOTE  IF ANY K-VALUE IS SO BIG THAT ITS CALCULATION WOULD CAUSE OVER-
C FLOW, IT (AND ALL HIGHER ORDERS) ARE SET TO ZERO.
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      COMPLEX AK(21),AK1(21),BK(*),BB,CC,DD,EE,FF,GG,HH,PP,QQ,SS,Z,ZINV,
     1 ZZ,RR,ZDUMMY 
C-----------------------------------------------------------------------
C
C  MACHINE DEPENDENT CONSTANTS.
C  ---------------------------
C
C MACHINE-DEPENDENT CONSTANTS ARE EXPLAINED IN
C ROUTINES BESJCF, BACKLC, AND BESYCF.
C
      SAVE ISAVE,PI,SQRTPI,GADOL,EXPARG,DYOUK,DYOUKH,NTERM,DYOUKI,LOU 
      DATA ISAVE /1/
C
C Definition of real and imaginary parts of complex number,
C standard Fortran and will work on Convex with -r8 -i8.
      REALP(ZDUMMY) = REAL(ZDUMMY)
      AIMAGP(ZDUMMY) = REAL((0,-1)*ZDUMMY)
C
      IF (ISAVE.GT.0) THEN
        ISAVE = 0
        PI = 4.0*ATAN (1.0)
        SQRTPI = SQRT (PI)
        GADOL = R1MACH (2)
        EXPARG = LOG (GADOL)
        DYOUK = R1MACH (4)
        DYOUKH = SQRT (DYOUK) 
        NTERM = 20
        DYOUKI = 1.0 / DYOUK
        LOU = I1MACH(2)
      ENDIF
C
C-----------------------------------------------------------------------
      Z=ZZ
      A=AA
      MAXP=NMAX+2
      Q=ABS(REALP(Z))
      E=Q*Q+AIMAGP(Z)**2
      IF ((A .LE. - 0.5) .OR. (A .GT. 0.5) .OR. (MAXP .LT. 2) .OR.
     *   (E .EQ. 0.0) .OR. (Q .GT. EXPARG)) GO TO 86
      F=SQRT(E)
      BIG=GADOL*MIN(.25,F/REAL(4*MAX(1,NMAX)))
C AVOID UNDERFLOW OR OVERFLOW IN COMPLEX DIVIDE
      F=1./F
      ZINV=2.*F/(Z*F)
      IF(A.EQ..5.OR.E.GE.196.) GO TO 30 
      IF(E.GE.9.) GO TO 20
C FOR SMALL Z, CALCULATE K*S VIA EQUATIONS 2.1 OF THE REFERENCE LISTED
C IN ROUTINE RECIPG 
      BB=.5*Z
      DD=-LOG(BB)
      EE=A*DD
      C=1.
      IF(PI*ABS(A).GT.DYOUKH) C=PI*A/SIN(PI*A)
      SS = (1.0, 0.0)
      IF ((REALP (EE) ** 2 + AIMAGP (EE) ** 2) .GT. DYOUK)
     *   SS = CMPLX (0.0, - 1.0) * SIN (CMPLX (0., 1.0) * EE) / EE
      EE=EXP(EE)
      CALL RECIPG(A,P,Q,G)
      GG=G*EE
      EE=.5*(EE+1./EE)
      FF=C*(P*EE+Q*SS*DD)
      E=A*A
      PP=.5*C*GG
      QQ=.5/GG
      CC = (1.0, 0.0)
      DD=BB*BB
      AK(1)=FF
C IF A.GT.0, CALCULATE KSUB(A-1) BY SUBSTITUTING EQUATIONS 2.1 AND 2.9
C INTO 1.9
      AK1(1)=PP
C IF A.LE.0, CALCULATE KSUB(A+1) VIA 2.9
      IF(A.GT.0.) AK1(1)=QQ
      TEST=DYOUK*MAX(ABS(REALP(AK(1))),ABS(AIMAGP(AK(1))))
      DO 10 N=1,NTERM
      EN=N
      G=1./(EN*EN-E)
      IF(A.GT.0.) GO TO 6
      HH=-G*(EN*(EN*FF+QQ)-A*PP)
      GO TO 8
    6 HH=-G*(EN*(EN*FF+PP)+A*QQ)
    8 FF=G*(EN*FF+PP+QQ)
      CC=CC*DD/EN
      AK(N+1) =CC*FF
      AK1(N+1)=CC*HH
      IF(MAX(ABS(REALP(AK(N+1))),ABS(AIMAGP(AK(N+1)))).LE.TEST) GO TO 12
      PP=PP/(EN-A)
   10 QQ=QQ/(EN+A)
      RETURN
   12 N=N+1
      M=N+1
      GG = (0.0, 0.0)
      HH = (0.0, 0.0)
      DO 14 L=1,N
         ITEMP = M - L
      GG=GG+AK(ITEMP)
   14 HH=HH+AK1(ITEMP)
      BK(2)=GG
      BK(1)=HH*ZINV 
      GO TO 40
C FOR ABS(Z) BETWEEN 3 AND 14, CALCULATE K*S VIA THE ALGORITHM GIVEN
C IN SECTION 3 OF THE REFERENCE.  THE ALGORITHM IS GIVEN FOR REAL Z, BUT
C CAN BE USED WHEN THE REAL PART OF Z IS NON-NEGATIVE.
   20 TEST=DYOUKI*COS(A*PI)/(E*PI)
      E=1.
      PP = (1.0, 0.0)
      QQ = (0.0, 0.0)
      FF=Z
      IF(REALP(Z).LT.0.) FF=-Z
      C=.25-A*A
      DO 22 N=1,99
      AN=(REAL(N*N-N)+C)/REAL(N*N+N)
      E=E*AN
      EN=1./REAL(N+1)
      BB=2.*EN*(REAL(N)+FF)
      RR=QQ
      QQ=PP
      PP=BB*QQ-AN*RR
      IF(MAX(ABS(REALP(PP)),ABS(AIMAGP(PP))).GE.EN*TEST) GO TO 23
   22 CONTINUE
      RETURN
   23 PP=E/PP
      QQ = (0.0, 0.0)
      EE=PP
      M=N 
      N=N+1
      DO 25 L=1,M
      N=N-1
      RR=QQ
      QQ=PP
      AINV=REAL(N*N+N)/(REAL(N*N-N)+C)
      BB=2.*(REAL(N)+FF)/REAL(N+1)
      PP=(BB*QQ-RR)*AINV
   25 EE=EE+PP
      BB=LOG(2.*FF) 
      GG=EXP(-BB*(A+.5))/EE
      BK(2)=SQRTPI*EXP(A*BB-FF)*GG*PP
      E=A 
      IF(A.GT.0.) E=-A
      BK(1)=.5*BK(2)*(FF-QQ/PP+(.5+E))*ZINV
      IF(REALP(Z).GE.0.) GO TO 40
C REAL(Z) IS NEGATIVE, SO USE EQUATION 9.6.31 OF REFERENCE (1) OF BESJCF
      BK(1)=-BK(1)
   26 ZINV=-ZINV
      HH=BK(1)
      GG=BK(2)
      QQ=HH
      IF(A.GT.0.) HH=QQ+A*(ZINV*GG)
      IF(A.LE.0.) QQ=HH-A*(ZINV*GG)
C NOW QQ, GG, HH ARE FUNCTIONS K OF ARGUMENT (-Z) AND ORDER A-1, A, A+1
      CALL BESICF(FF,A,NMAX,BK)
      E=1.
      IF(AIMAGP(Z).GE.0.) E=-1.
      DD=CMPLX(0.,E)
      E=-E*PI
      EE=CMPLX(0.,E)
      E=-E*A
      IF(A.NE..5) DD=CMPLX(COS(E),SIN(E))
      BK(1)=-DD*QQ-EE*BK(1)
      BK(2)=DD*GG-EE*BK(2)
      IF(MAXP.LE.2) GO TO 70
      DD=-DD
      BK(3)=DD*HH-EE*BK(3)
      IF(MAXP.EQ.3) GO TO 70
C USE FORMULA 9.6.31, RECURRING FORWARD ON K OF ARGUMENT (-Z)
      DO 28 N=4,MAXP
      IF(MAX(ABS(REALP(HH)),ABS(AIMAGP(HH))).GT.BIG) GO TO 82
      FF=GG
      GG=HH
      DD=-DD
      HH=(ZINV*(A+REAL(N-3)))*GG+FF
   28 BK(N)=DD*HH-EE*BK(N)
      GO TO 70
C FOR LARGE Z, CALCULATE K*S VIA PHASE-AMPLITUDE EQUATION 9.7.2 OF
C REFERENCE (1) LISTED IN BESJCF.
   30 FF=Z
      EE=ZINV
      IF(REALP(Z).LT.0.) FF=-FF
      IF(REALP(Z).LT.0.) EE=-EE
      DD=SQRT(.25*PI*EE)*EXP(-FF)
      C=A 
      R=1.
      IF(A.GT.0.) R=-1.
      DO 32 M=1,2
      IF(M.EQ.2) C=C+R
      CALL PHASMP(C,EE,1,PP,QQ)
      ITEMP = 3 - M 
   32 BK(ITEMP) = DD * PP
      IF(REALP(Z).LT.0.) GO TO 26
   40 M=3 
      IF(A.GT.0.) GO TO 60
      M=4 
      IF(MAXP.GE.3) BK(3)=BK(1)
      BK(1)=BK(1)-(A*ZINV)*BK(2)
C CALCULATE K*S VIA FORWARD RECURSION, CHECKING FOR POSSIBLE OVERFLOW 
   60 IF(M.GT.MAXP) GO TO 70
      DO 65 N=M,MAXP
      IF(MAX(ABS(REALP(BK(N-1))),ABS(AIMAGP(BK(N-1)))).GT.BIG) GO TO 82
   65 BK(N)=(ZINV*(A+REAL(N-3)))*BK(N-1)+BK(N-2)
   70 RETURN
   82 DO 83 M=N,MAXP
   83 BK(M) = (0.0, 0.0)
      GO TO 70
   86 CONTINUE
      WRITE (ICOUT, 88)NMAX
      CALL DPWRST('XXX','BUG')
      WRITE (ICOUT, 89)A,Z
      CALL DPWRST('XXX','BUG')
   88 FORMAT('***** ERROR (BESKCF) --- INVALID INPUT, NMAX = ', I6)
   89 FORMAT('      A = ', 1PE22.14,' Z = ',2(1PE22.14))
      RETURN
      END 
      SUBROUTINE BESY (X, FNU, N, Y)
C***BEGIN PROLOGUE  BESY
C***PURPOSE  Implement forward recursion on the three term recursion
C            relation for a sequence of non-negative order Bessel
C            functions Y/SUB(FNU+I-1)/(X), I=1,...,N for real, positive
C            X and non-negative orders FNU.
C***LIBRARY   SLATEC
C***CATEGORY  C10A3
C***TYPE      SINGLE PRECISION (BESY-S, DBESY-D)
C***KEYWORDS  SPECIAL FUNCTIONS, Y BESSEL FUNCTION
C***AUTHOR  Amos, D. E., (SNLA)
C***DESCRIPTION
C
C     Abstract
C         BESY implements forward recursion on the three term
C         recursion relation for a sequence of non-negative order Bessel
C         functions Y/sub(FNU+I-1)/(X), I=1,N for real X .GT. 0.0E0 and
C         non-negative orders FNU.  If FNU .LT. NULIM, orders FNU and
C         FNU+1 are obtained from BESYNU which computes by a power
C         series for X .LE. 2, the K Bessel function of an imaginary
C         argument for 2 .LT. X .LE. 20 and the asymptotic expansion for
C         X .GT. 20.
C
C         If FNU .GE. NULIM, the uniform asymptotic expansion is coded
C         in ASYJY for orders FNU and FNU+1 to start the recursion.
C         NULIM is 70 or 100 depending on whether N=1 or N .GE. 2.  An
C         overflow test is made on the leading term of the asymptotic
C         expansion before any extensive computation is done.
C
C     Description of Arguments
C
C         Input
C           X      - X .GT. 0.0E0
C           FNU    - order of the initial Y function, FNU .GE. 0.0E0
C           N      - number of members in the sequence, N .GE. 1
C
C         Output
C           Y      - a vector whose first N components contain values
C                    for the sequence Y(I)=Y/sub(FNU+I-1)/(X), I=1,N.
C
C     Error Conditions
C         Improper input arguments - a fatal error
C         Overflow - a fatal error
C
C***REFERENCES  F. W. J. Olver, Tables of Bessel Functions of Moderate
C                 or Large Orders, NPL Mathematical Tables 6, Her
C                 Majesty's Stationery Office, London, 1962.
C               N. M. Temme, On the numerical evaluation of the modified
C                 Bessel function of the third kind, Journal of
C                 Computational Physics 19, (1975), pp. 324-337.
C               N. M. Temme, On the numerical evaluation of the ordinary
C                 Bessel function of the second kind, Journal of
C                 Computational Physics 21, (1976), pp. 343-350.
C***ROUTINES CALLED  ASYJY, BESY0, BESY1, BESYNU, I1MACH, R1MACH,
C                    XERMSG, YAIRY
C***REVISION HISTORY  (YYMMDD)
C   800501  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  BESY
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C
      EXTERNAL YAIRY, BESY0, BESY1
      INTEGER I, IFLW, J, N, NB, ND, NN, NUD, NULIM
      REAL       AZN,CN,DNU,ELIM,FLGJY,FN,FNU,RAN,S,S1,S2,TM,TRX,
     1           W,WK,W2N,X,XLIM,XXN,Y
      REAL BESY0, BESY1
      DIMENSION W(2), NULIM(2), Y(*), WK(7)
      SAVE NULIM
      DATA NULIM(1),NULIM(2) / 70 , 100 /
C***FIRST EXECUTABLE STATEMENT  BESY
      NN = -I1MACH(12)
      ELIM = 2.303E0*(NN*R1MACH(5)-3.0E0)
      XLIM = R1MACH(1)*1.0E+3
      IF (FNU.LT.0.0E0) GO TO 140
      IF (X.LE.0.0E0) GO TO 150
      IF (X.LT.XLIM) GO TO 170
      IF (N.LT.1) GO TO 160
C
C     ND IS A DUMMY VARIABLE FOR N
C
      ND = N
      NUD = INT(FNU)
      DNU = FNU - NUD
      NN = MIN(2,ND)
      FN = FNU + N - 1
      IF (FN.LT.2.0E0) GO TO 100
C
C     OVERFLOW TEST  (LEADING EXPONENTIAL OF ASYMPTOTIC EXPANSION)
C     FOR THE LAST ORDER, FNU+N-1.GE.NULIM
C
      XXN = X/FN
      W2N = 1.0E0-XXN*XXN
      IF(W2N.LE.0.0E0) GO TO 10
      RAN = SQRT(W2N)
      AZN = LOG((1.0E0+RAN)/XXN) - RAN
      CN = FN*AZN
      IF(CN.GT.ELIM) GO TO 170
   10 CONTINUE
      IF (NUD.LT.NULIM(NN)) GO TO 20
C
C     ASYMPTOTIC EXPANSION FOR ORDERS FNU AND FNU+1.GE.NULIM
C
      FLGJY = -1.0E0
      CALL ASYJY(YAIRY,X,FNU,FLGJY,NN,Y,WK,IFLW)
      IF(IFLW.NE.0) GO TO 170
      IF (NN.EQ.1) RETURN
      TRX = 2.0E0/X
      TM = (FNU+FNU+2.0E0)/X
      GO TO 80
C
   20 CONTINUE
      IF (DNU.NE.0.0E0) GO TO 30
      S1 = BESY0(X)
      IF (NUD.EQ.0 .AND. ND.EQ.1) GO TO 70
      S2 = BESY1(X)
      GO TO 40
   30 CONTINUE
      NB = 2
      IF (NUD.EQ.0 .AND. ND.EQ.1) NB = 1
      CALL BESYNU(X, DNU, NB, W)
      S1 = W(1)
      IF (NB.EQ.1) GO TO 70
      S2 = W(2)
   40 CONTINUE
      TRX = 2.0E0/X
      TM = (DNU+DNU+2.0E0)/X
C     FORWARD RECUR FROM DNU TO FNU+1 TO GET Y(1) AND Y(2)
      IF (ND.EQ.1) NUD = NUD - 1
      IF (NUD.GT.0) GO TO 50
      IF (ND.GT.1) GO TO 70
      S1 = S2
      GO TO 70
   50 CONTINUE
      DO 60 I=1,NUD
        S = S2
        S2 = TM*S2 - S1
        S1 = S
        TM = TM + TRX
   60 CONTINUE
      IF (ND.EQ.1) S1 = S2
   70 CONTINUE
      Y(1) = S1
      IF (ND.EQ.1) RETURN
      Y(2) = S2
   80 CONTINUE
      IF (ND.EQ.2) RETURN
C     FORWARD RECUR FROM FNU+2 TO FNU+N-1
      DO 90 I=3,ND
        Y(I) = TM*Y(I-1) - Y(I-2)
        TM = TM + TRX
   90 CONTINUE
      RETURN
C
  100 CONTINUE
C     OVERFLOW TEST
      IF (FN.LE.1.0E0) GO TO 110
      IF (-FN*(LOG(X)-0.693E0).GT.ELIM) GO TO 170
  110 CONTINUE
      IF (DNU.EQ.0.0E0) GO TO 120
      CALL BESYNU(X, FNU, ND, Y)
      RETURN
  120 CONTINUE
      J = NUD
      IF (J.EQ.1) GO TO 130
      J = J + 1
      Y(J) = BESY0(X)
      IF (ND.EQ.1) RETURN
      J = J + 1
  130 CONTINUE
      Y(J) = BESY1(X)
      IF (ND.EQ.1) RETURN
      TRX = 2.0E0/X
      TM = TRX
      GO TO 80
C
C
C
  140 CONTINUE
      WRITE(ICOUT,141)
  141 FORMAT('***** ERORR FROM BESY, THE ORDER FNU IS NEGATIVE. ***')
      CALL DPWRST('XXX','BUG ')
      RETURN
  150 CONTINUE
      WRITE(ICOUT,151)
  151 FORMAT('**** ERORR FROM BESY, X IS LESS THAN OR EQUAL TO ZERO. ')
      CALL DPWRST('XXX','BUG ')
      RETURN
  160 CONTINUE
      WRITE(ICOUT,161)
  161 FORMAT('***** ERORR FROM BESY, N IS LESS THAN ONE.. ***')
      CALL DPWRST('XXX','BUG ')
      RETURN
  170 CONTINUE
      WRITE(ICOUT,171)
  171 FORMAT('***** ERORR FROM BESY, OVERFLOW, FNU OR N TOO LARGE OR ',
     1       'X TOO SMALL. *****')
      RETURN
      END
      SUBROUTINE BESYNU (X, FNU, N, Y)
C***BEGIN PROLOGUE  BESYNU
C***SUBSIDIARY
C***PURPOSE  Subsidiary to BESY
C***LIBRARY   SLATEC
C***TYPE      SINGLE PRECISION (BESYNU-S, DBSYNU-D)
C***AUTHOR  Amos, D. E., (SNLA)
C***DESCRIPTION
C
C     Abstract
C         BESYNU computes N member sequences of Y Bessel functions
C         Y/SUB(FNU+I-1)/(X), I=1,N for non-negative orders FNU and
C         positive X. Equations of the references are implemented on
C         small orders DNU for Y/SUB(DNU)/(X) and Y/SUB(DNU+1)/(X).
C         Forward recursion with the three term recursion relation
C         generates higher orders FNU+I-1, I=1,...,N.
C
C         To start the recursion FNU is normalized to the interval
C         -0.5.LE.DNU.LT.0.5. A special form of the power series is
C         implemented on 0.LT.X.LE.X1 while the Miller algorithm for the
C         K Bessel function in terms of the confluent hypergeometric
C         function U(FNU+0.5,2*FNU+1,I*X) is implemented on X1.LT.X.LE.X
C         Here I is the complex number SQRT(-1.).
C         For X.GT.X2, the asymptotic expansion for large X is used.
C         When FNU is a half odd integer, a special formula for
C         DNU=-0.5 and DNU+1.0=0.5 is used to start the recursion.
C
C         BESYNU assumes that a significant digit SINH(X) function is
C         available.
C
C     Description of Arguments
C
C         Input
C           X      - X.GT.0.0E0
C           FNU    - Order of initial Y function, FNU.GE.0.0E0
C           N      - Number of members of the sequence, N.GE.1
C
C         Output
C           Y      - A vector whose first N components contain values
C                    for the sequence Y(I)=Y/SUB(FNU+I-1), I=1,N.
C
C     Error Conditions
C         Improper input arguments - a fatal error
C         Overflow - a fatal error
C
C***SEE ALSO  BESY
C***REFERENCES  N. M. Temme, On the numerical evaluation of the ordinary
C                 Bessel function of the second kind, Journal of
C                 Computational Physics 21, (1976), pp. 343-350.
C               N. M. Temme, On the numerical evaluation of the modified
C                 Bessel function of the third kind, Journal of
C                 Computational Physics 19, (1975), pp. 324-337.
C***ROUTINES CALLED  GAMMA, R1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   800501  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   900328  Added TYPE section.  (WRB)
C   900727  Added EXTERNAL statement.  (WRB)
C   910408  Updated the AUTHOR and REFERENCES sections.  (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  BESYNU
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C
      INTEGER I, INU, J, K, KK, N, NN
      REAL A, AK, ARG, A1, A2, BK, CB, CBK, CC, CCK, CK, COEF, CPT,
     1 CP1, CP2, CS, CS1, CS2, CX, DNU, DNU2, ETEST, ETX, F, FC, FHS,
     2 FK, FKS, FLRX, FMU, FN, FNU, FX, G, G1, G2, HPI, P, PI, PT, Q,
     3 RB, RBK, RCK, RELB, RPT, RP1, RP2, RS, RS1, RS2, RTHPI, RX, S,
     4 SA, SB, SMU, SS, ST, S1, S2, TB, TM, TOL, T1, T2, X, X1, X2, Y
      DIMENSION A(120), RB(120), CB(120), Y(*), CC(8)
      DOUBLE PRECISION DGAMMA
      EXTERNAL DGAMMA
      SAVE X1, X2, PI, RTHPI, HPI, CC
      DATA X1, X2 / 3.0E0, 20.0E0 /
      DATA PI,RTHPI        / 3.14159265358979E+00, 7.97884560802865E-01/
      DATA HPI             / 1.57079632679490E+00/
      DATA CC(1), CC(2), CC(3), CC(4), CC(5), CC(6), CC(7), CC(8)
     1                     / 5.77215664901533E-01,-4.20026350340952E-02,
     2-4.21977345555443E-02, 7.21894324666300E-03,-2.15241674114900E-04,
     3-2.01348547807000E-05, 1.13302723200000E-06, 6.11609500000000E-09/
C***FIRST EXECUTABLE STATEMENT  BESYNU
      AK = R1MACH(3)
      TOL = MAX(AK,1.0E-15)
      IF (X.LE.0.0E0) GO TO 270
      IF (FNU.LT.0.0E0) GO TO 280
      IF (N.LT.1) GO TO 290
      RX = 2.0E0/X
      INU = INT(FNU+0.5E0)
      DNU = FNU - INU
      IF (ABS(DNU).EQ.0.5E0) GO TO 260
      DNU2 = 0.0E0
      IF (ABS(DNU).LT.TOL) GO TO 10
      DNU2 = DNU*DNU
   10 CONTINUE
      IF (X.GT.X1) GO TO 120
C
C     SERIES FOR X.LE.X1
C
      A1 = 1.0E0 - DNU
      A2 = 1.0E0 + DNU
      T1 = 1.0E0/REAL(DGAMMA(DBLE(A1)))
      T2 = 1.0E0/REAL(DGAMMA(DBLE(A2)))
      IF (ABS(DNU).GT.0.1E0) GO TO 40
C     SERIES FOR F0 TO RESOLVE INDETERMINACY FOR SMALL ABS(DNU)
      S = CC(1)
      AK = 1.0E0
      DO 20 K=2,8
        AK = AK*DNU2
        TM = CC(K)*AK
        S = S + TM
        IF (ABS(TM).LT.TOL) GO TO 30
   20 CONTINUE
   30 G1 = -(S+S)
      GO TO 50
   40 CONTINUE
      G1 = (T1-T2)/DNU
   50 CONTINUE
      G2 = T1 + T2
      SMU = 1.0E0
      FC = 1.0E0/PI
      FLRX = LOG(RX)
      FMU = DNU*FLRX
      TM = 0.0E0
      IF (DNU.EQ.0.0E0) GO TO 60
      TM = SIN(DNU*HPI)/DNU
      TM = (DNU+DNU)*TM*TM
      FC = DNU/SIN(DNU*PI)
      IF (FMU.NE.0.0E0) SMU = SINH(FMU)/FMU
   60 CONTINUE
      F = FC*(G1*COSH(FMU)+G2*FLRX*SMU)
      FX = EXP(FMU)
      P = FC*T1*FX
      Q = FC*T2/FX
      G = F + TM*Q
      AK = 1.0E0
      CK = 1.0E0
      BK = 1.0E0
      S1 = G
      S2 = P
      IF (INU.GT.0 .OR. N.GT.1) GO TO 90
      IF (X.LT.TOL) GO TO 80
      CX = X*X*0.25E0
   70 CONTINUE
      F = (AK*F+P+Q)/(BK-DNU2)
      P = P/(AK-DNU)
      Q = Q/(AK+DNU)
      G = F + TM*Q
      CK = -CK*CX/AK
      T1 = CK*G
      S1 = S1 + T1
      BK = BK + AK + AK + 1.0E0
      AK = AK + 1.0E0
      S = ABS(T1)/(1.0E0+ABS(S1))
      IF (S.GT.TOL) GO TO 70
   80 CONTINUE
      Y(1) = -S1
      RETURN
   90 CONTINUE
      IF (X.LT.TOL) GO TO 110
      CX = X*X*0.25E0
  100 CONTINUE
      F = (AK*F+P+Q)/(BK-DNU2)
      P = P/(AK-DNU)
      Q = Q/(AK+DNU)
      G = F + TM*Q
      CK = -CK*CX/AK
      T1 = CK*G
      S1 = S1 + T1
      T2 = CK*(P-AK*G)
      S2 = S2 + T2
      BK = BK + AK + AK + 1.0E0
      AK = AK + 1.0E0
      S = ABS(T1)/(1.0E0+ABS(S1)) + ABS(T2)/(1.0E0+ABS(S2))
      IF (S.GT.TOL) GO TO 100
  110 CONTINUE
      S2 = -S2*RX
      S1 = -S1
      GO TO 160
  120 CONTINUE
      COEF = RTHPI/SQRT(X)
      IF (X.GT.X2) GO TO 210
C
C     MILLER ALGORITHM FOR X1.LT.X.LE.X2
C
      ETEST = COS(PI*DNU)/(PI*X*TOL)
      FKS = 1.0E0
      FHS = 0.25E0
      FK = 0.0E0
      RCK = 2.0E0
      CCK = X + X
      RP1 = 0.0E0
      CP1 = 0.0E0
      RP2 = 1.0E0
      CP2 = 0.0E0
      K = 0
  130 CONTINUE
      K = K + 1
      FK = FK + 1.0E0
      AK = (FHS-DNU2)/(FKS+FK)
      PT = FK + 1.0E0
      RBK = RCK/PT
      CBK = CCK/PT
      RPT = RP2
      CPT = CP2
      RP2 = RBK*RPT - CBK*CPT - AK*RP1
      CP2 = CBK*RPT + RBK*CPT - AK*CP1
      RP1 = RPT
      CP1 = CPT
      RB(K) = RBK
      CB(K) = CBK
      A(K) = AK
      RCK = RCK + 2.0E0
      FKS = FKS + FK + FK + 1.0E0
      FHS = FHS + FK + FK
      PT = MAX(ABS(RP1),ABS(CP1))
      FC = (RP1/PT)**2 + (CP1/PT)**2
      PT = PT*SQRT(FC)*FK
      IF (ETEST.GT.PT) GO TO 130
      KK = K
      RS = 1.0E0
      CS = 0.0E0
      RP1 = 0.0E0
      CP1 = 0.0E0
      RP2 = 1.0E0
      CP2 = 0.0E0
      DO 140 I=1,K
        RPT = RP2
        CPT = CP2
        RP2 = (RB(KK)*RPT-CB(KK)*CPT-RP1)/A(KK)
        CP2 = (CB(KK)*RPT+RB(KK)*CPT-CP1)/A(KK)
        RP1 = RPT
        CP1 = CPT
        RS = RS + RP2
        CS = CS + CP2
        KK = KK - 1
  140 CONTINUE
      PT = MAX(ABS(RS),ABS(CS))
      FC = (RS/PT)**2 + (CS/PT)**2
      PT = PT*SQRT(FC)
      RS1 = (RP2*(RS/PT)+CP2*(CS/PT))/PT
      CS1 = (CP2*(RS/PT)-RP2*(CS/PT))/PT
      FC = HPI*(DNU-0.5E0) - X
      P = COS(FC)
      Q = SIN(FC)
      S1 = (CS1*Q-RS1*P)*COEF
      IF (INU.GT.0 .OR. N.GT.1) GO TO 150
      Y(1) = S1
      RETURN
  150 CONTINUE
      PT = MAX(ABS(RP2),ABS(CP2))
      FC = (RP2/PT)**2 + (CP2/PT)**2
      PT = PT*SQRT(FC)
      RPT = DNU + 0.5E0 - (RP1*(RP2/PT)+CP1*(CP2/PT))/PT
      CPT = X - (CP1*(RP2/PT)-RP1*(CP2/PT))/PT
      CS2 = CS1*CPT - RS1*RPT
      RS2 = RPT*CS1 + RS1*CPT
      S2 = (RS2*Q+CS2*P)*COEF/X
C
C     FORWARD RECURSION ON THE THREE TERM RECURSION RELATION
C
  160 CONTINUE
      CK = (DNU+DNU+2.0E0)/X
      IF (N.EQ.1) INU = INU - 1
      IF (INU.GT.0) GO TO 170
      IF (N.GT.1) GO TO 190
      S1 = S2
      GO TO 190
  170 CONTINUE
      DO 180 I=1,INU
        ST = S2
        S2 = CK*S2 - S1
        S1 = ST
        CK = CK + RX
  180 CONTINUE
      IF (N.EQ.1) S1 = S2
  190 CONTINUE
      Y(1) = S1
      IF (N.EQ.1) RETURN
      Y(2) = S2
      IF (N.EQ.2) RETURN
      DO 200 I=3,N
        Y(I) = CK*Y(I-1) - Y(I-2)
        CK = CK + RX
  200 CONTINUE
      RETURN
C
C     ASYMPTOTIC EXPANSION FOR LARGE X, X.GT.X2
C
  210 CONTINUE
      NN = 2
      IF (INU.EQ.0 .AND. N.EQ.1) NN = 1
      DNU2 = DNU + DNU
      FMU = 0.0E0
      IF (ABS(DNU2).LT.TOL) GO TO 220
      FMU = DNU2*DNU2
  220 CONTINUE
      ARG = X - HPI*(DNU+0.5E0)
      SA = SIN(ARG)
      SB = COS(ARG)
      ETX = 8.0E0*X
      DO 250 K=1,NN
        S1 = S2
        T2 = (FMU-1.0E0)/ETX
        SS = T2
        RELB = TOL*ABS(T2)
        T1 = ETX
        S = 1.0E0
        FN = 1.0E0
        AK = 0.0E0
        DO 230 J=1,13
          T1 = T1 + ETX
          AK = AK + 8.0E0
          FN = FN + AK
          T2 = -T2*(FMU-FN)/T1
          S = S + T2
          T1 = T1 + ETX
          AK = AK + 8.0E0
          FN = FN + AK
          T2 = T2*(FMU-FN)/T1
          SS = SS + T2
          IF (ABS(T2).LE.RELB) GO TO 240
  230   CONTINUE
  240   S2 = COEF*(S*SA+SS*SB)
        FMU = FMU + 8.0E0*DNU + 4.0E0
        TB = SA
        SA = -SB
        SB = TB
  250 CONTINUE
      IF (NN.GT.1) GO TO 160
      S1 = S2
      GO TO 190
C
C     FNU=HALF ODD INTEGER CASE
C
  260 CONTINUE
      COEF = RTHPI/SQRT(X)
      S1 = COEF*SIN(X)
      S2 = -COEF*COS(X)
      GO TO 160
C
C
  270 CONTINUE
      WRITE(ICOUT,271)
  271 FORMAT('**** ERORR FROM BESYNU, X IS NOT POSITIVE.')
      CALL DPWRST('XXX','BUG ')
      RETURN
  280 CONTINUE
      WRITE(ICOUT,281)
  281 FORMAT('***** ERORR FROM BESYNU, THE ORDER FNU IS NEGATIVE. ***')
      CALL DPWRST('XXX','BUG ')
      RETURN
 290  CONTINUE
      WRITE(ICOUT,291)
  291 FORMAT('***** ERORR FROM BESYNU, N IS LESS THAN ONE.. ***')
      CALL DPWRST('XXX','BUG ')
      RETURN
      END
      FUNCTION BESY0 (X)
C***BEGIN PROLOGUE  BESY0
C***PURPOSE  Compute the Bessel function of the second kind of order
C            zero.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C10A1
C***TYPE      SINGLE PRECISION (BESY0-S, DBESY0-D)
C***KEYWORDS  BESSEL FUNCTION, FNLIB, ORDER ZERO, SECOND KIND,
C             SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C BESY0(X) calculates the Bessel function of the second kind
C of order zero for real argument X.
C
C Series for BY0        on the interval  0.          to  1.60000D+01
C                                        with weighted error   1.20E-17
C                                         log weighted error  16.92
C                               significant figures required  16.15
C                                    decimal places required  17.48
C
C Series for BM0        on the interval  0.          to  6.25000D-02
C                                        with weighted error   4.98E-17
C                                         log weighted error  16.30
C                               significant figures required  14.97
C                                    decimal places required  16.96
C
C Series for BTH0       on the interval  0.          to  6.25000D-02
C                                        with weighted error   3.67E-17
C                                         log weighted error  16.44
C                               significant figures required  15.53
C                                    decimal places required  17.13
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  BESJ0, CSEVL, INITS, R1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770401  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C***END PROLOGUE  BESY0
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      EXTERNAL BESJ0, CSEVL
C
      DIMENSION BY0CS(13), BM0CS(21), BTH0CS(24)
      LOGICAL FIRST
      SAVE BY0CS, BM0CS, BTH0CS, TWODPI, PI4,
     1 NTY0, NTM0, NTTH0, XSML, XMAX, FIRST
      DATA BY0CS( 1) /   -.0112778393 92865573E0 /
      DATA BY0CS( 2) /   -.1283452375 6042035E0 /
      DATA BY0CS( 3) /   -.1043788479 9794249E0 /
      DATA BY0CS( 4) /    .0236627491 83969695E0 /
      DATA BY0CS( 5) /   -.0020903916 47700486E0 /
      DATA BY0CS( 6) /    .0001039754 53939057E0 /
      DATA BY0CS( 7) /   -.0000033697 47162423E0 /
      DATA BY0CS( 8) /    .0000000772 93842676E0 /
      DATA BY0CS( 9) /   -.0000000013 24976772E0 /
      DATA BY0CS(10) /    .0000000000 17648232E0 /
      DATA BY0CS(11) /   -.0000000000 00188105E0 /
      DATA BY0CS(12) /    .0000000000 00001641E0 /
      DATA BY0CS(13) /   -.0000000000 00000011E0 /
      DATA BM0CS( 1) /    .0928496163 7381644E0 /
      DATA BM0CS( 2) /   -.0014298770 7403484E0 /
      DATA BM0CS( 3) /    .0000283057 9271257E0 /
      DATA BM0CS( 4) /   -.0000014330 0611424E0 /
      DATA BM0CS( 5) /    .0000001202 8628046E0 /
      DATA BM0CS( 6) /   -.0000000139 7113013E0 /
      DATA BM0CS( 7) /    .0000000020 4076188E0 /
      DATA BM0CS( 8) /   -.0000000003 5399669E0 /
      DATA BM0CS( 9) /    .0000000000 7024759E0 /
      DATA BM0CS(10) /   -.0000000000 1554107E0 /
      DATA BM0CS(11) /    .0000000000 0376226E0 /
      DATA BM0CS(12) /   -.0000000000 0098282E0 /
      DATA BM0CS(13) /    .0000000000 0027408E0 /
      DATA BM0CS(14) /   -.0000000000 0008091E0 /
      DATA BM0CS(15) /    .0000000000 0002511E0 /
      DATA BM0CS(16) /   -.0000000000 0000814E0 /
      DATA BM0CS(17) /    .0000000000 0000275E0 /
      DATA BM0CS(18) /   -.0000000000 0000096E0 /
      DATA BM0CS(19) /    .0000000000 0000034E0 /
      DATA BM0CS(20) /   -.0000000000 0000012E0 /
      DATA BM0CS(21) /    .0000000000 0000004E0 /
      DATA BTH0CS( 1) /   -.2463916377 4300119E0 /
      DATA BTH0CS( 2) /    .0017370983 07508963E0 /
      DATA BTH0CS( 3) /   -.0000621836 33402968E0 /
      DATA BTH0CS( 4) /    .0000043680 50165742E0 /
      DATA BTH0CS( 5) /   -.0000004560 93019869E0 /
      DATA BTH0CS( 6) /    .0000000621 97400101E0 /
      DATA BTH0CS( 7) /   -.0000000103 00442889E0 /
      DATA BTH0CS( 8) /    .0000000019 79526776E0 /
      DATA BTH0CS( 9) /   -.0000000004 28198396E0 /
      DATA BTH0CS(10) /    .0000000001 02035840E0 /
      DATA BTH0CS(11) /   -.0000000000 26363898E0 /
      DATA BTH0CS(12) /    .0000000000 07297935E0 /
      DATA BTH0CS(13) /   -.0000000000 02144188E0 /
      DATA BTH0CS(14) /    .0000000000 00663693E0 /
      DATA BTH0CS(15) /   -.0000000000 00215126E0 /
      DATA BTH0CS(16) /    .0000000000 00072659E0 /
      DATA BTH0CS(17) /   -.0000000000 00025465E0 /
      DATA BTH0CS(18) /    .0000000000 00009229E0 /
      DATA BTH0CS(19) /   -.0000000000 00003448E0 /
      DATA BTH0CS(20) /    .0000000000 00001325E0 /
      DATA BTH0CS(21) /   -.0000000000 00000522E0 /
      DATA BTH0CS(22) /    .0000000000 00000210E0 /
      DATA BTH0CS(23) /   -.0000000000 00000087E0 /
      DATA BTH0CS(24) /    .0000000000 00000036E0 /
      DATA TWODPI / 0.6366197723 6758134E0 /
      DATA PI4 / 0.7853981633 9744831E0 /
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  BESY0
      IF (FIRST) THEN
         NTY0 = INITS (BY0CS, 13, 0.1*R1MACH(3))
         NTM0 = INITS (BM0CS, 21, 0.1*R1MACH(3))
         NTTH0 = INITS (BTH0CS, 24, 0.1*R1MACH(3))
C
         XSML = SQRT (4.0*R1MACH(3))
         XMAX = 1.0/R1MACH(4)
      ENDIF
      FIRST = .FALSE.
C
      IF (X .LE. 0.) THEN
        WRITE(ICOUT,1)
    1   FORMAT('***** ERORR FROM BESY0, X ZERO OR NEGATIVE.  *******')
        CALL DPWRST('XXX','BUG ')
        BESY0=0.0
        RETURN
      ENDIF
      IF (X.GT.4.0) GO TO 20
C
      Y = 0.
      IF (X.GT.XSML) Y = X*X
      BESY0 = TWODPI*LOG(0.5*X)*BESJ0(X) + .375 + CSEVL (.125*Y-1.,
     1  BY0CS, NTY0)
      RETURN
C
 20   CONTINUE
      IF (X.GT.XMAX) THEN
        WRITE(ICOUT,2)
        CALL DPWRST('XXX','BUG ')
        BESY0 = 0.0
        RETURN
      ENDIF
    2 FORMAT('***** ERORR FROM BESY0, NO PRECISION BECAUSE THE ',
     1       'VALUE OF X IS TOO BIG.  ****')
C
      Z = 32.0/X**2 - 1.0
      AMPL = (0.75 + CSEVL (Z, BM0CS, NTM0)) / SQRT(X)
      THETA = X - PI4 + CSEVL (Z, BTH0CS, NTTH0) / X
      BESY0 = AMPL * SIN (THETA)
C
      RETURN
      END
      FUNCTION BESY1 (X)
C***BEGIN PROLOGUE  BESY1
C***PURPOSE  Compute the Bessel function of the second kind of order
C            one.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C10A1
C***TYPE      SINGLE PRECISION (BESY1-S, DBESY1-D)
C***KEYWORDS  BESSEL FUNCTION, FNLIB, ORDER ONE, SECOND KIND,
C             SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C BESY1(X) calculates the Bessel function of the second kind of
C order one for real argument X.
C
C Series for BY1        on the interval  0.          to  1.60000D+01
C                                        with weighted error   1.87E-18
C                                         log weighted error  17.73
C                               significant figures required  17.83
C                                    decimal places required  18.30
C
C Series for BM1        on the interval  0.          to  6.25000D-02
C                                        with weighted error   5.61E-17
C                                         log weighted error  16.25
C                               significant figures required  14.97
C                                    decimal places required  16.91
C
C Series for BTH1       on the interval  0.          to  6.25000D-02
C                                        with weighted error   4.10E-17
C                                         log weighted error  16.39
C                               significant figures required  15.96
C                                    decimal places required  17.08
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  BESJ1, CSEVL, INITS, R1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770401  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C***END PROLOGUE  BESY1
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      EXTERNAL BESJ1, CSEVL
C
      DIMENSION BY1CS(14), BM1CS(21), BTH1CS(24)
      LOGICAL FIRST
      SAVE BY1CS, BM1CS, BTH1CS, TWODPI, PI4,
     1 NTY1, NTM1, NTTH1, XMIN, XSML, XMAX, FIRST
      DATA BY1CS( 1) /    .0320804710 0611908629E0 /
      DATA BY1CS( 2) /   1.2627078974 33500450E0 /
      DATA BY1CS( 3) /    .0064999618 9992317500E0 /
      DATA BY1CS( 4) /   -.0893616452 8860504117E0 /
      DATA BY1CS( 5) /    .0132508812 2175709545E0 /
      DATA BY1CS( 6) /   -.0008979059 1196483523E0 /
      DATA BY1CS( 7) /    .0000364736 1487958306E0 /
      DATA BY1CS( 8) /   -.0000010013 7438166600E0 /
      DATA BY1CS( 9) /    .0000000199 4539657390E0 /
      DATA BY1CS(10) /   -.0000000003 0230656018E0 /
      DATA BY1CS(11) /    .0000000000 0360987815E0 /
      DATA BY1CS(12) /   -.0000000000 0003487488E0 /
      DATA BY1CS(13) /    .0000000000 0000027838E0 /
      DATA BY1CS(14) /   -.0000000000 0000000186E0 /
      DATA BM1CS( 1) /    .1047362510 931285E0 /
      DATA BM1CS( 2) /    .0044244389 3702345E0 /
      DATA BM1CS( 3) /   -.0000566163 9504035E0 /
      DATA BM1CS( 4) /    .0000023134 9417339E0 /
      DATA BM1CS( 5) /   -.0000001737 7182007E0 /
      DATA BM1CS( 6) /    .0000000189 3209930E0 /
      DATA BM1CS( 7) /   -.0000000026 5416023E0 /
      DATA BM1CS( 8) /    .0000000004 4740209E0 /
      DATA BM1CS( 9) /   -.0000000000 8691795E0 /
      DATA BM1CS(10) /    .0000000000 1891492E0 /
      DATA BM1CS(11) /   -.0000000000 0451884E0 /
      DATA BM1CS(12) /    .0000000000 0116765E0 /
      DATA BM1CS(13) /   -.0000000000 0032265E0 /
      DATA BM1CS(14) /    .0000000000 0009450E0 /
      DATA BM1CS(15) /   -.0000000000 0002913E0 /
      DATA BM1CS(16) /    .0000000000 0000939E0 /
      DATA BM1CS(17) /   -.0000000000 0000315E0 /
      DATA BM1CS(18) /    .0000000000 0000109E0 /
      DATA BM1CS(19) /   -.0000000000 0000039E0 /
      DATA BM1CS(20) /    .0000000000 0000014E0 /
      DATA BM1CS(21) /   -.0000000000 0000005E0 /
      DATA BTH1CS( 1) /    .7406014102 6313850E0 /
      DATA BTH1CS( 2) /   -.0045717556 59637690E0 /
      DATA BTH1CS( 3) /    .0001198185 10964326E0 /
      DATA BTH1CS( 4) /   -.0000069645 61891648E0 /
      DATA BTH1CS( 5) /    .0000006554 95621447E0 /
      DATA BTH1CS( 6) /   -.0000000840 66228945E0 /
      DATA BTH1CS( 7) /    .0000000133 76886564E0 /
      DATA BTH1CS( 8) /   -.0000000024 99565654E0 /
      DATA BTH1CS( 9) /    .0000000005 29495100E0 /
      DATA BTH1CS(10) /   -.0000000001 24135944E0 /
      DATA BTH1CS(11) /    .0000000000 31656485E0 /
      DATA BTH1CS(12) /   -.0000000000 08668640E0 /
      DATA BTH1CS(13) /    .0000000000 02523758E0 /
      DATA BTH1CS(14) /   -.0000000000 00775085E0 /
      DATA BTH1CS(15) /    .0000000000 00249527E0 /
      DATA BTH1CS(16) /   -.0000000000 00083773E0 /
      DATA BTH1CS(17) /    .0000000000 00029205E0 /
      DATA BTH1CS(18) /   -.0000000000 00010534E0 /
      DATA BTH1CS(19) /    .0000000000 00003919E0 /
      DATA BTH1CS(20) /   -.0000000000 00001500E0 /
      DATA BTH1CS(21) /    .0000000000 00000589E0 /
      DATA BTH1CS(22) /   -.0000000000 00000237E0 /
      DATA BTH1CS(23) /    .0000000000 00000097E0 /
      DATA BTH1CS(24) /   -.0000000000 00000040E0 /
      DATA TWODPI / 0.6366197723 6758134E0 /
      DATA PI4 / 0.7853981633 9744831E0 /
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  BESY1
      IF (FIRST) THEN
         NTY1 = INITS (BY1CS, 14, 0.1*R1MACH(3))
         NTM1 = INITS (BM1CS, 21, 0.1*R1MACH(3))
         NTTH1 = INITS (BTH1CS, 24, 0.1*R1MACH(3))
C
         XMIN = 1.571*EXP ( MAX(LOG(R1MACH(1)), -LOG(R1MACH(2)))+.01)
         XSML = SQRT (4.0*R1MACH(3))
         XMAX = 1.0/R1MACH(4)
      ENDIF
      FIRST = .FALSE.
C
      IF (X .LE. 0.) THEN
        WRITE(ICOUT,1)
    1   FORMAT('***** ERORR FROM BESY1, X ZERO OR NEGATIVE.  *******')
        CALL DPWRST('XXX','BUG ')
        BESY1=0.0
        RETURN
      ENDIF
      IF (X.GT.4.0) GO TO 20
C
      IF (X .LE. XMIN) THEN
        WRITE(ICOUT,2)
        CALL DPWRST('XXX','BUG ')
      ENDIF
    2 FORMAT('***** WARNING FROM BESY1, UNDERFLOW BECAUSE THE ',
     1       'VALUE OF X IS SO SMALL.  ****')
      Y = 0.
      IF (X.GT.XSML) Y = X*X
      BESY1 = TWODPI*LOG(0.5*X)*BESJ1(X) +
     1  (0.5 + CSEVL (.125*Y-1., BY1CS, NTY1))/X
      RETURN
C
 20   CONTINUE
      IF (X.GT.XMAX) THEN
        WRITE(ICOUT,3)
        CALL DPWRST('XXX','BUG ')
        BESY1 = 0.0
        RETURN
      ENDIF
    3 FORMAT('***** ERORR FROM BESY1, NO PRECISION BECAUSE THE ',
     1       'VALUE OF X IS TOO BIG.  ****')
C
      Z = 32.0/X**2 - 1.0
      AMPL = (0.75 + CSEVL (Z, BM1CS, NTM1)) / SQRT(X)
      THETA = X - 3.0*PI4 + CSEVL (Z, BTH1CS, NTTH1) / X
      BESY1 = AMPL * SIN (THETA)
C
      RETURN
      END
      SUBROUTINE BESYCF(ZZ,AA,NMAX,BY)
C THIS ROUTINE CALCULATES BESSEL FUNCTIONS Y OF COMPLEX ARGUMENT AND
C REAL ORDER.  ARGUMENTS ARE AS FOR ROUTINE BESJCF.
C Y*S ARE CALCULATED BY FORWARD RECURSION, USING EQUATION 9.1.27 OF
C REFERENCE (1) LISTED IN BESJCF.  TO START THE RECURSION, FUNCTION
C VALUES OF ORDERS A AND A+1 ARE CALCULATED IF A.LE.0, WHILE ORDERS A 
C AND A-1 ARE CALCULATED IF A.GT.0.
C NOTE  IF ANY Y-VALUE IS SO BIG THAT ITS CALCULATION WOULD CAUSE OVER-
C FLOW, IT (AND ALL HIGHER ORDERS) ARE SET TO ZERO.
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      COMPLEX BY(*),BB,CC,DD,EE,FF,GG,HH,PP,QQ,SS,YA(21),YA1(21),Z,ZINV,
     1 ZZ,ZDUMMY
      DOUBLE PRECISION PIDBL
C-----------------------------------------------------------------------
C
C  MACHINE DEPENDENT CONSTANTS.
C  ---------------------------
C
      SAVE ISAVE,PI,PINV,PIDBL,GADOL,EXPARG,DYOUK,DYOUKH,NTERM,LOU
      DATA ISAVE /1/
C
C Definition of real and imaginary parts of complex number,
C standard Fortran and will work on Convex with -r8 -i8.
      REALP(ZDUMMY) = REAL(ZDUMMY)
      AIMAGP(ZDUMMY) = REAL((0,-1)*ZDUMMY)
C
      IF (ISAVE.GT.0) THEN
        ISAVE = 0
C PI AND 1/PI
        PI = 4.0*ATAN (1.0)
        PINV = 1.0 / PI
        PIDBL = 4.0D0 * ATAN (1.0D0)
C MACHINE-DEPENDENT CONSTANTS  LARGEST REAL NUMBER (APPROX), LIMIT ON 
C ARGUMENT TO LIBRARY EXP ROUTINE, MACHINE ACCURACY, ITS SQUARE ROOT, 
C AND LENGTH OF VECTORS YA1 AND YA, MINUS 1.  FOR ABS(Z).LE.3, 21 TERMS
C ARE SUFFICIENT FOR 14 SIGNIFICANT FIGURE (SEE REFERENCE LISTED BELOW).
        GADOL = R1MACH (2)
        EXPARG = LOG (GADOL)
        DYOUK = R1MACH (4)
        DYOUKH = SQRT (DYOUK) 
        NTERM = 20
        LOU = I1MACH(2)
      ENDIF
C
C-----------------------------------------------------------------------
      Z=ZZ
      A=AA
      MAXP=NMAX+2
      Q=REALP(Z)
      R=ABS(AIMAGP(Z))
      E=Q*Q+R*R
      IF ((A. LE. - 0.5) .OR. (A .GT. 0.5) .OR. (MAXP .LT. 2) .OR.
     *   (E .EQ. 0.0) .OR. (R. GT. EXPARG)) GO TO 86
      F=SQRT(E)
      BIG=GADOL*MIN(.25,F/REAL(4*MAX(1,NMAX)))
C AVOID UNDERFLOW OR OVERFLOW IN COMPLEX DIVIDE
      F=1./F
      ZINV=2.*F/(Z*F)
C Following statement rewritten to make compilation possible
C on Convex with -r8 -i8.
C     IF(MIN(R,REAL(MAXP)).GT.3.) GO TO 20
      IF(R.GT.3.0 .AND. MAXP.GT.3) GO TO 20
      IF(E.GE.196.) GO TO 30
      IF(E.GE.9.) GO TO 20
C FOR SMALL Z, Y IS CALCULATED VIA EQUATIONS 2.1 OR N. M. TEMME, ON THE
C NUMERICAL EVALUATION OF THE ORDINARY BESSEL FUNCTION OF THE SECOND
C KIND, REPORT TW152/75, STICHTING MATHEMATISCH CENTRUM, AMSTERDAM, 9/75
      BB=.5*Z
      DD=-LOG(BB)
      EE=A*DD
      C=PINV
      IF(ABS(A).GT.DYOUKH) C=A/SIN(PI*A)
      SS = (1.0, 0.0)
      IF ((REALP (EE) ** 2 + AIMAGP (EE) ** 2) .GT. DYOUK)
     *   SS =  CMPLX (0.0, - 1.0) * SIN (CMPLX (0.0, 1.0) * EE) / EE
      EE=EXP(EE)
      CALL RECIPG(A,P,Q,G)
      GG=G*EE
      EE=.5*(EE+1./EE)
      FF=(2.*C)*(P*EE+Q*SS*DD)
      E=A*A
      PP=C*GG
      QQ=PINV/GG
      C=.5*PI*A
      R=1.
      IF(ABS(C).GT.DYOUKH) R=SIN(C)/C
      R=PI*C*R*R
      CC = (1.0, 0.0)
      DD=-BB*BB
      GG=FF+R*QQ
      C=0.
      IF(A.NE..5) C=DCOS(PIDBL*DBLE(A)) 
      IF(C.LE..5) GG=(PP-QQ*C)/A
      YA(1)=GG
C IF A.LE.0, CALCULATE YA1=YSUB(A+1) AS IN THE REFERENCE
      YA1(1)=PP
C IF A.GT.0, CALCULATE YA1=YSUB(A-1)=SUM(N=0 TO INFINITY) OF
C CN*(N*GN-QN*COSPI*A), WHICH CAN BE DERIVED BY SUBSTITUTING 2.2 AND 2.3
C OF THE REFERENCE INTO 1.3.
      IF(A.GT.0.) YA1(1)=-C*QQ
      TEST =DYOUK*MAX(ABS(REALP(YA(1))),ABS(AIMAGP(YA(1)))) 
      DO 10 N=1,NTERM
      EN=N
      G=1./(EN*EN-E)
      IF(A.GT.0.) GO TO 6
C RECUR DIRECTLY ON GG AND HH WITHOUT USING FF AS IN THE ORIGINAL PROG.
      HH=-G*(EN*(EN*GG+C*QQ)-A*PP)
      GO TO 8
    6 HH= G*(EN*(EN*GG+PP)+A*C*QQ)
    8 GG=G*(EN*GG+PP+C*QQ)
      CC=CC*DD/EN
      YA(N+1)=CC*GG 
      YA1(N+1)=CC*HH
      IF(MAX(ABS(REALP(YA(N+1))),ABS(AIMAGP(YA(N+1)))).LE.TEST)GOTO12
      PP=PP/(EN-A)
   10 QQ=QQ/(EN+A)
      RETURN
   12 N=N+1
      M=N+1
      GG = (0.0, 0.0)
      HH = (0.0, 0.0)
      DO 14 L=1,N
         ITEMP = M - L
      GG=GG+YA(ITEMP)
   14 HH=HH+YA1(ITEMP)
      BY(2)=-GG
      BY(1)=-HH*ZINV
      M=3 
      IF(A) 40,40,60
C FOR MAG(Z) BETWEEN 3 AND 14, OR FOR ABS(IM(Z)).GT.3, CALCULATE Y VIA
C EQUATIONS 9.6.3 AND 9.6.5 OF REFERENCE 1 LISTED IN BESJCF 
   20 CALL BESJCF(Z,A,NMAX,BY)
      C=-1.
      IF(AIMAGP(Z).LT.0.) C=1.
      CC=CMPLX(0.,C)
      DD=CC*Z
      CALL BESKCF(DD,A,1,YA1) 
      C=.5*C*PI*A
      DD=2.*PINV*CMPLX(COS(C),SIN(C))
      BY(1)=CC*(DD*YA1(1)-BY(1))
      GG=YA1(2)
      BY(2)=-CC*BY(2)-DD*GG
      IF(MAXP.LE.2) GO TO 70
      HH=YA1(3)
      DD=CC*DD
      BY(3)=-CC*BY(3)-DD*HH
      IF(MAXP.EQ.3) GO TO 70
      ZINV=-CC*ZINV 
C IN THIS LOOP, HH IS THE FUNCTION K (OF ARGUMENT IZ OR -IZ) AND CAN BE
C CALCULATED BY FORWARD RECURSION, SINCE THE REAL PART OF THE ARGUMENT
C IS NON-NEGATIVE
      DO 24 N=4,MAXP
      IF(MAX(ABS(REALP(HH)),ABS(AIMAGP(HH))).GT.BIG) GO TO 82
      FF=GG
      GG=HH
      DD=CC*DD
      HH=(ZINV*(A+REAL(N-3)))*GG+FF
   24 BY(N)=-CC*BY(N)-DD*HH
      GO TO 70
C FOR LARGE Z, USE PHASE-AMPLITUDE EQUATIONS 9.2.5 AND 9.2.6 OF REFER-
C ENCE 1 AS LISTED IN BESJCF
   30 BB=Z
      EE=ZINV
C Set FF and GG here to avoid Univac FTN compiler warnings
C that arise due to logic here and in 38-loop below. 
      FF = (0.0,0.0)
      GG = (0.0,0.0)
      IF(REALP(Z).GE.0.) GO TO 32
      BB=-BB
      EE=-EE
      E=1.
      IF(AIMAGP(Z).LT.0.) E=-1.
      C=0.
      IF(A.NE..5) C=DCOS(PIDBL*DBLE(A)) 
      S=SIN(-E*A*PI)
      FF=CMPLX(C,S) 
      GG=CMPLX(0.,2.*E*C)
   32 BB=BB-.5*PI*(A+.5)
      CC=COS(BB)
      SS=SIN(BB)
      DD=SQRT(PINV*EE)
      C=A 
      DO 38 M=1,2
      CALL PHASMP(C,EE,0,PP,QQ)
      IF(REALP(Z).LT.0.) GO TO 34
C REAL(Z).GE.0, SO USE EQUATION 9.2.6
      ITEMP = 3 - M 
      BY(ITEMP)=DD*(PP*SS+QQ*CC)
      IF(M-1) 36,36,38
C REAL(Z).LT.0, SO SUBSTITUTE 9.2.5 AND 9.2.6 INTO 9.1.36
   34 PP=PP*(FF*SS+GG*CC)
      QQ=QQ*(FF*CC-GG*SS)
      ITEMP = 3 - M 
      BY(ITEMP)=DD*(PP+QQ)
      IF(M.EQ.2) GO TO 38
      FF=-FF
      GG=-GG
   36 IF(A.GT.0.) GO TO 37
      C=C+1.
      BB=-CC
      CC=SS
      SS=BB
      GO TO 38
   37 C=C-1.
      BB=-SS
      SS=CC
      CC=BB
   38 CONTINUE
      M=3 
      IF(A.GT.0.) GO TO 60
   40 IF(MAXP.GE.3) BY(3)=BY(1)
      BY(1)=(A*ZINV)*BY(2)-BY(1)
      M=4 
C CALCULATE Y*S BY FORWARD RECURSION, CHECKING FOR POSSIBLE OVERFLOW
   60 IF(M.GT.MAXP) GO TO 70
      DO 65 N=M,MAXP
      IF(MAX(ABS(REALP(BY(N-1))),ABS(AIMAGP(BY(N-1)))).GT.BIG) GO TO 82
   65 BY(N)=(ZINV*(A+REAL(N-3)))*BY(N-1)-BY(N-2)
   70 RETURN
   82 DO 83 L=N,MAXP
   83 BY(L) = (0.0, 0.0)
      GO TO 70
   86 CONTINUE
      WRITE (ICOUT, 88)NMAX
      CALL DPWRST('XXX','BUG')
      WRITE (ICOUT, 89)A,Z
      CALL DPWRST('XXX','BUG')
   88 FORMAT('***** ERROR (BESYCF) --- INVALID INPUT, NMAX = ', I6)
   89 FORMAT('      A = ', 1PE22.14,' Z = ',2(1PE22.14))
      RETURN
      END 
      SUBROUTINE BETCDF(X,ALPHA,BETA,CDF)
C
C     NOTE--ALGORITHM ADDED SEPTEMBER 1994 (ALAN)
C           USE DBETAI ROUTINE FROM SLATEC.  THIS USES THE
C           BOSTEN AND BATTISTE ALGORITHM.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--94/8
C     ORIGINAL VERSION--SEPTEMBER 1994.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DOUBLE PRECISION DCDF
      DOUBLE PRECISION DALPHA
      DOUBLE PRECISION DBETA
      DOUBLE PRECISION DX
      DOUBLE PRECISION DBETAI
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      IF(ALPHA.LE.0.0 .OR. BETA.LE.0.0)THEN
        WRITE(ICOUT,101)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,102)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,103)ALPHA
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,104)BETA
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
      IF(X.LT.0.0)THEN
        WRITE(ICOUT,301)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,302)X
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
      IF(X.GT.1.0)THEN
        WRITE(ICOUT,401)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,402)X
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
  101 FORMAT('***** FATAL DIAGNOSTIC--EITHER THE ALPHA OR BETA IS')
  102 FORMAT('      NON-POSITIVE.')
  103 FORMAT('      THE VALUE OF ALPHA IS ',E15.7)
  104 FORMAT('      THE VALUE OF BETA IS ',E15.7,'       ******')
  301 FORMAT('***** FATAL DIAGNOSTIC--THE INPUT ARGUMENT IS ')
  302 FORMAT('      NON-POSITIVE.  IT HAS THE VALUE ',E15.7)
  401 FORMAT('***** FATAL DIAGNOSTIC--THE INPUT ARGUMENT IS GRETATER')
  402 FORMAT('      THAN 1.  IT HAS THE VALUE ',E15.7)
C
      IF(X.LE.0.)THEN
        CDF=0.0
        GOTO9999
      ELSEIF(X.GE.1)THEN
        CDF=1.0
        GOTO9999
      ENDIF
C
      DX=DBLE(X)
      DALPHA=DBLE(ALPHA)
      DBETA=DBLE(BETA)
      DCDF=DBETAI(DX,DALPHA,DBETA)
      CDF=REAL(DCDF)
C
 9999 CONTINUE
      RETURN
      END
      DOUBLE PRECISION FUNCTION BETFU2 (DALPHA,DX)
C
C     PURPOSE--THIS ROUTINE IS USED IN FINDING THE LIKELIHOOD RATIO
C              BASED CONFIDECE INTERVAL FOR THE 2-PARAMETER BETA
C              MODEL (FULL SAMPLE).  THIS FUNCTION FINDS THE ROOT
C              OF THE EQUATION:
C
C                 2*LL(ALPHA,BETA) - 2*LL(ALPHA,BETA(ALPHA)) -
C                                    CHSPPF(alpha,1)
C
C              WITH
C
C                 LL(ALPHA,BETA) = -N*LOG(BETA(ALPHA,BETA)) +
C                          N*(ALPHA-1)*S3 +N*(BETA-1)*S4
C
C              GIVEN CURRENT VALUE OF ALPHA, WE COMPUTE VALUE OF
C              BETA(ALPHA).  WE THEN COMPUTE THE LIKELIHOOD FUNCTION.
C              NOTE THAT LL(ALPHA,BETA) IS COMPUTED ONCE IN DPMLBE
C              AND PASSED VIA COMMON.
C
C              CALLED BY DFZER2 ROUTINE FOR FINDING THE ROOT OF A
C              FUNCTION.
C
C     EXAMPLE--BETA MAXIMUM LIKELIHOOD Y
C     REFERENCE--KARL BURY, "STATISTICAL DISTRIBUTIONS IN ENGINEERING",
C                CAMBRIDGE UNIVERSITY PRESS, 1999, CHAPTER 13 (SEE
C                EXAMPLE 13.3).
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBUG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004/12
C     ORIGINAL VERSION--DECEMBER   2004.
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DALPHA
      DOUBLE PRECISION DX(*)
C
      INTEGER N
      DOUBLE PRECISION DSUM3
      DOUBLE PRECISION DSUM4
      DOUBLE PRECISION DLLAB
      DOUBLE PRECISION DK
      COMMON/BETCO9/DSUM3,DSUM4,DLLAB,DK,N
C
      DOUBLE PRECISION DBETA
      COMMON/BETCO2/DBETA
C
      DOUBLE PRECISION DALPH2
      COMMON/BETCO4/DALPH2
C
      DOUBLE PRECISION DLBETA
      EXTERNAL DLBETA
      DOUBLE PRECISION BETFU4
      EXTERNAL BETFU4
C
      DOUBLE PRECISION AE
      DOUBLE PRECISION RE
      DOUBLE PRECISION XLOW
      DOUBLE PRECISION XUP
      DOUBLE PRECISION XSTRT
      DOUBLE PRECISION DBETA2
      DOUBLE PRECISION DN
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
      DOUBLE PRECISION DTERM4
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      DALPH2=DALPHA
      DBETA2=DBETA
      AE=1.D-7
      RE=1.D-7
      XSTRT=DBETA2
      XLOW=XSTRT/3.0D0
      XUP=XSTRT*3.0D0
      CALL DFZER3(BETFU4,XLOW,XUP,XSTRT,RE,AE,IFLAG,DX)
      DBETA2=XLOW
C
C  COMPUTE LL(ALPHA,BETA)
C
      DN=DBLE(N)
      DTERM1=0.0D0
      IF(DALPHA.GT.0.0D0 .AND. DBETA.GT.0.0D0)THEN
        DTERM1=-DN*DLBETA(DALPHA,DBETA2)
      ENDIF
      DTERM2=DN*(DALPHA-1.0D0)*DSUM3
      DTERM3=DN*(DBETA2-1.0D0)*DSUM4
      DTERM4=DTERM1 + DTERM2 + DTERM3
C
      BETFU2=2.0*DLLAB - 2.0D0*DTERM4 - DK
C
      RETURN
      END
      DOUBLE PRECISION FUNCTION BETFU5 (DBETA,DX)
C
C     PURPOSE--THIS ROUTINE IS USED IN FINDING THE LIKELIHOOD RATIO
C              BASED CONFIDECE INTERVAL FOR THE 2-PARAMETER BETA
C              MODEL (FULL SAMPLE).  THIS FUNCTION FINDS THE ROOT
C              OF THE EQUATION:
C
C                 2*LL(ALPHA,BETA) - 2*LL(ALPHA,ALPHA(BETA)) -
C                                    CHSPPF(alpha,1)
C
C              WITH
C
C                 LL(ALPHA,BETA) = -N*LOG(BETA(ALPHA,BETA)) +
C                          N*(ALPHA-1)*S3 +N*(BETA-1)*S4
C
C              GIVEN CURRENT VALUE OF BETA, WE COMPUTE VALUE OF
C              ALPHA(BETA).  WE THEN COMPUTE THE LIKELIHOOD FUNCTION.
C              NOTE THAT LL(ALPHA,BETA) IS COMPUTED ONCE IN DPMLBE
C              AND PASSED VIA COMMON.
C
C              CALLED BY DFZER2 ROUTINE FOR FINDING THE ROOT OF A
C              FUNCTION.
C
C     EXAMPLE--BETA MAXIMUM LIKELIHOOD Y
C     REFERENCE--KARL BURY, "STATISTICAL DISTRIBUTIONS IN ENGINEERING",
C                CAMBRIDGE UNIVERSITY PRESS, 1999, CHAPTER 14 (SEE
C                EXAMPLE 14.3).
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBUG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004/12
C     ORIGINAL VERSION--DECEMBER   2004.
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DBETA
      DOUBLE PRECISION DX(*)
C
      INTEGER N
      DOUBLE PRECISION DSUM3
      DOUBLE PRECISION DSUM4
      DOUBLE PRECISION DLLAB
      DOUBLE PRECISION DK
      COMMON/BETCO9/DSUM3,DSUM4,DLLAB,DK,N
C
      DOUBLE PRECISION DALPHA
      COMMON/BETCO5/DALPHA
C
      DOUBLE PRECISION DBETA2
      COMMON/BETCO3/DBETA2
C
      DOUBLE PRECISION DLBETA
      EXTERNAL DLBETA
      DOUBLE PRECISION BETFU3
      EXTERNAL BETFU3
C
      DOUBLE PRECISION AE
      DOUBLE PRECISION RE
      DOUBLE PRECISION XLOW
      DOUBLE PRECISION XUP
      DOUBLE PRECISION XSTRT
      DOUBLE PRECISION DALPH2
      DOUBLE PRECISION DN
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
      DOUBLE PRECISION DTERM4
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      DBETA2=DBETA
      DALPH2=DALPHA
      AE=1.D-7
      RE=1.D-7
      XSTRT=DALPH2
      XLOW=XSTRT/3.0D0
      XUP=XSTRT*3.0D0
      CALL DFZER3(BETFU3,XLOW,XUP,XSTRT,RE,AE,IFLAG,DX)
      DALPH2=XLOW
C
C  COMPUTE LL(ALPHA,BETA)
C
      DN=DBLE(N)
      DTERM1=0.0D0
      IF(DALPHA.GT.0.0D0 .AND. DBETA.GT.0.0D0)THEN
        DTERM1=-DN*DLBETA(DALPH2,DBETA)
      ENDIF
      DTERM2=DN*(DALPH2-1.0D0)*DSUM3
      DTERM3=DN*(DBETA-1.0D0)*DSUM4
      DTERM4=DTERM1 + DTERM2 + DTERM3
C
      BETFU5=2.0*DLLAB - 2.0D0*DTERM4 - DK
C
      RETURN
      END
      DOUBLE PRECISION FUNCTION BETFU3 (DALPHA,DX)
C
C     PURPOSE--THIS ROUTINE IS USED IN FINDING THE LIKELIHOOD RATIO
C              BASED CONFIDENCE INTERVAL FOR THE ALPHA SHAPE PARAMETER
C              OF A 2-PARAMETER BETA MODEL (FULL SAMPLE).  THIS
C              FUNCTION FINDS THE ROOT OF THE EQUATION:
C
C                 DIGAMMA(BETA) - DIGAMMA(ALPHA + BETA) - SUM4
C
C              WITH
C
C                 SUM4 = (1/N)*SUM[i=1 to N][LOG((B - X(i))]/(B-A)
C                 N        = SAMPLE SIZE
C                 A        = LOWER LIMIT
C                 B        = UPPER LIMIT
C
C              NOTE THAT DIGAMMA(BETA) AND SUM4 DO NOT DEPEND ON
C              THE VALUE OF ALPHA, SO THESE ARE COMPUTED ONCE AND
C              PASSED VIA COMMON BLOCKS.
C
C              GIVEN A VALUE FOR THE BETA SHAPE PARAMETER (DBETA), WE
C              NEED TO DETERMINE THE VALUE OF THE ALPHA SHAPE PARAMETER
C              (DALPHA).
C
C              CALLED BY DFZER2 ROUTINE FOR FINDING THE ROOT OF A
C              FUNCTION.  DFZER2 IS MODIFIED VERSION OF DFZERO THAT
C              PASSES ALONG THE DATA ARRAY.
C
C     EXAMPLE--BETA MAXIMUM LIKELIHOOD Y
C     REFERENCE--KARL BURY, "STATISTICAL DISTRIBUTIONS IN ENGINEERING",
C                CAMBRIDGE UNIVERSITY PRESS, 1999, CHAPTER 14 (SEE
C                EXAMPLE 14.3).
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBUG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004/12
C     ORIGINAL VERSION--DECEMBER   2004.
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DALPHA
      DOUBLE PRECISION DX(*)
C
      INTEGER N
      DOUBLE PRECISION DSUM3
      DOUBLE PRECISION DSUM4
      DOUBLE PRECISION DLLAB
      DOUBLE PRECISION DK
      COMMON/BETCO9/DSUM3,DSUM4,DLLAB,DK,N
C
      DOUBLE PRECISION DBETA
      COMMON/BETCO3/DBETA
C
      DOUBLE PRECISION DN
C
      DOUBLE PRECISION DPSI
      EXTERNAL DPSI
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      DN=DBLE(N)
      BETFU3=DPSI(DALPHA) - DPSI(DALPHA + DBETA) - DSUM3
C
      RETURN
      END
      DOUBLE PRECISION FUNCTION BETFU4 (DBETA,DX)
C
C     PURPOSE--THIS ROUTINE IS USED IN FINDING THE LIKELIHOOD RATIO
C              BASED CONFIDENCE INTERVAL FOR THE BETA SHAPE PARAMETER
C              OF A 2-PARAMETER BETA MODEL (FULL SAMPLE).  THIS
C              FUNCTION FINDS THE ROOT OF THE EQUATION:
C
C                 DIGAMMA(ALPHA) - DIGAMMA(ALPHA + BETA) - SUM3
C
C              WITH
C
C                 SUM3 = (1/N)*SUM[i=1 to N][LOG((X(i) - A)]/(B-A)
C                 N        = SAMPLE SIZE
C                 A        = LOWER LIMIT
C                 B        = UPPER LIMIT
C
C              NOTE THAT DIGAMMA(ALPHA) AND SUM3 DO NOT DEPEND ON
C              THE VALUE OF BETA, SO THESE ARE COMPUTED ONCE AND
C              PASSED VIA COMMON BLOCKS.
C
C              GIVEN A VALUE FOR THE ALPHA SHAPE PARAMETER (DALPHA),
C              DETERMINE VALUE OF BETA.  THIS IS
C              THE ROOT OF THE ABOVE EQUATION.
C
C              CALLED BY DFZER2 ROUTINE FOR FINDING THE ROOT OF A
C              FUNCTION.  DFZER2 IS MODIFIED VERSION OF DFZERO THAT
C              PASSES ALONG THE DATA ARRAY.
C
C     EXAMPLE--BETA MAXIMUM LIKELIHOOD Y
C     REFERENCE--KARL BURY, "STATISTICAL DISTRIBUTIONS IN ENGINEERING",
C                CAMBRIDGE UNIVERSITY PRESS, 1999, CHAPTER 14 (SEE
C                EXAMPLE 14.3).
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBUG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004/12
C     ORIGINAL VERSION--DECEMBER   2004.
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DBETA
      DOUBLE PRECISION DX(*)
C
      INTEGER N
      DOUBLE PRECISION DSUM3
      DOUBLE PRECISION DSUM4
      DOUBLE PRECISION DLLAB
      DOUBLE PRECISION DK
      COMMON/BETCO9/DSUM3,DSUM4,DLLAB,DK,N
C
      DOUBLE PRECISION DALPHA
      COMMON/BETCO4/DALPHA
C
      DOUBLE PRECISION DN
C
      DOUBLE PRECISION DPSI
      EXTERNAL DPSI
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      DN=DBLE(N)
      BETFU4=DPSI(DBETA) - DPSI(DALPHA + DBETA) - DSUM4
C
      RETURN
      END
      REAL FUNCTION BETFU7(ALPHA)
C
C     PURPOSE--THIS ROUTINE IS USED IN FINDING CONFIDENCE LIMITS
C              FOR PERCENTILES OF THE BETA DISTRIBUTION (BASED ON
C              MAXIMUM LIKELIHOOD ESTIMATION).  THIS FUNCTION
C              COMPUTES THE DERIVATIVE OF THE BETA PERCENT POINT
C              FUNCTION WITH RESPECT TO THE ALPHA SHAPE PARAMETER.
C
C              CALLED BY DIFF ROUTINE FOR FINDING THE DERIVATIVE
C              OF A FUNCTION.
C     EXAMPLE--BETA MAXIMUM LIKELIHOOD Y
C     REFERENCE--KARL BURY, "STATISTICAL DISTRIBUTIONS IN
C                ENGINEERING", CAMBRIDGE UNIVERSITY PRESS,
C                1999, CHAPTER 13.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBUG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004/12
C     ORIGINAL VERSION--DECEMBER   2004.
C
C---------------------------------------------------------------------
C
      REAL ALPHA
C
      COMMON/BETCO7/P,BETA
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      CALL BETPPF(P,ALPHA,BETA,APPF)
      BETFU7=APPF
C
      RETURN
      END
      REAL FUNCTION BETFU8(BETA)
C
C     PURPOSE--THIS ROUTINE IS USED IN FINDING CONFIDENCE LIMITS
C              FOR PERCENTILES OF THE BETA DISTRIBUTION (BASED ON
C              MAXIMUM LIKELIHOOD ESTIMATION).  THIS FUNCTION
C              COMPUTES THE DERIVATIVE OF THE BETA PERCENT POINT
C              FUNCTION WITH RESPECT TO THE BETA SHAPE PARAMETER.
C
C              CALLED BY DIFF ROUTINE FOR FINDING THE DERIVATIVE
C              OF A FUNCTION.
C     EXAMPLE--BETA MAXIMUM LIKELIHOOD Y
C     REFERENCE--KARL BURY, "STATISTICAL DISTRIBUTIONS IN
C                ENGINEERING", CAMBRIDGE UNIVERSITY PRESS,
C                1999, CHAPTER 13.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBUG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004/12
C     ORIGINAL VERSION--DECEMBER   2004.
C
C---------------------------------------------------------------------
C
      REAL BETA
C
      COMMON/BETCO8/P,ALPHA
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      CALL BETPPF(P,ALPHA,BETA,APPF)
      BETFU8=APPF
C
      RETURN
      END
      SUBROUTINE BETPDF(X,ALPHA,BETA,PDF)
C
C     NOTE--BETA PDF IS:
C              BETPDF(X,A,B) = X**(A-1)*(1-X)**(B-1)/BETA(A,B)
C           WHERE BETA(A,B) IS THE COMPLETE BETA FUNCTION.
C           USE LOGARITHMS TO OBTAIN:
C              LN(BETAPDF) = (A-1)*LN(X)+(B-1)*LN(1-X)-LN(BETA(A,B))
C           AND THEN TAKE EXPONENT.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--94/8
C     ORIGINAL VERSION--SEPTEMBER 1994.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C
      DOUBLE PRECISION DPDF
      DOUBLE PRECISION DALPHA
      DOUBLE PRECISION DBETA
      DOUBLE PRECISION DX
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
      DOUBLE PRECISION DTERM4
      DOUBLE PRECISION DLBETA
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      PDF=0.0
      IF(ALPHA.LE.0.0 .OR. BETA.LE.0.0)THEN
        WRITE(ICOUT,101)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,102)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,103)ALPHA
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,104)BETA
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
      IF(X.LE.0.0)THEN
        WRITE(ICOUT,301)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,302)X
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
      IF(X.GE.1.0)THEN
        WRITE(ICOUT,401)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,402)X
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
  101 FORMAT('***** FATAL DIAGNOSTIC--EITHER THE ALPHA OR BETA IS')
  102 FORMAT('      NON-POSITIVE.')
  103 FORMAT('      THE VALUE OF ALPHA IS ',E15.7)
  104 FORMAT('      THE VALUE OF BETA IS ',E15.7,'       ******')
  301 FORMAT('***** FATAL DIAGNOSTIC--THE INPUT ARGUMENT IS ')
  302 FORMAT('      NON-POSITIVE.  IT HAS THE VALUE ',E15.7)
  401 FORMAT('***** FATAL DIAGNOSTIC--THE INPUT ARGUMENT IS GRETATER')
  402 FORMAT('      THAN OR EQUAL TO 1.  IT HAS THE VALUE ',E15.7)
C
      IF(X.LE.0.0.OR.X.GE.1.0)GOTO900
      DX=DBLE(X)
      DALPHA=DBLE(ALPHA)
      DBETA=DBLE(BETA)
      DTERM3=DLBETA(DALPHA,DBETA)
      DTERM1=(DALPHA-1.D0)*DLOG(DX)
      DTERM2=(DBETA-1.D0)*DLOG(1.D0-DX)
      DTERM4=DTERM1 + DTERM2 - DTERM3
      DPDF=DEXP(DTERM4)
      PDF=REAL(DPDF)
      GOTO9999
C
C  HANDLE X = 0 OR 1 CASE SEPARATELY.  FOR NOW, LEAVE AS UNDEFINED
C  (SO PDF = 0.0).
C
 900  CONTINUE
      PDF=0.0
CCCCC DX=DBLE(X)
CCCCC DALPHA=DBLE(ALPHA)
CCCCC DBETA=DBLE(BETA)
CCCCC DTERM3=DLBETA(DALPHA,DBETA)
CCCCC DTERM1=0.D0
CCCCC DTERM2=0.D0
CCCCC DTERM4=DTERM1 + DTERM2 - DTERM3
CCCCC DPDF=DEXP(DTERM4)
CCCCC PDF=SNGL(DPDF)
      GOTO9999
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE BETPPF(P,ALPHA,BETA,PPF)
C
C     NOTE--ALGORITHM ADDED SEPTEMBER 1994 (ALAN)
C           USE ALGORITHM FROM KENNEDY AND GENTLE (PP. 109-112) WITH
C           THE MODIFICATION THAT WE USE OUR BETA CDF ROUTINE.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--82/7
C     ORIGINAL VERSION--JULY      1981.
C     UPDATED         --FEBRUARY  1982.
C     UPDATED         --MAY       1982.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DOUBLE PRECISION DCDF
      DOUBLE PRECISION DALPHA
      DOUBLE PRECISION DBETA
      DOUBLE PRECISION DX
      DOUBLE PRECISION DBETAI
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DATA EPS /1.0E-6/
      DATA SIG /1.0E-5/
      DATA ZERO /0./
      DATA MAXIT /200/
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(P.LT.0.0.OR.P.GT.1.0)GOTO50
      IF(ALPHA.LE.0.0)GOTO55
      IF(BETA.LE.0.0)GOTO60
      GOTO90
   50 WRITE(ICOUT,1)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)P
      CALL DPWRST('XXX','BUG ')
      PPF=0.0
      RETURN
   55 WRITE(ICOUT,11)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)ALPHA
      CALL DPWRST('XXX','BUG ')
      PPF=0.0
      RETURN
   60 WRITE(ICOUT,25)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)BETA
      CALL DPWRST('XXX','BUG ')
      PPF=0.0
      GOTO9999
   90 CONTINUE
    1 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ',
     1' BETPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL')
   11 FORMAT('***** FATAL ERROR--THE 2ND INPUT ARGUMENT TO THE ',
     1' BETPPF SUBROUTINE IS NON-POSITIVE')
   25 FORMAT('***** FATAL ERROR--THE 3RD INPUT ARGUMENT TO THE ',
     1' BETPPF SUBROUTINE IS NON-POSITIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
      A = ALPHA
      B = BETA
C
      IERR=0
      IC = 0
      AB = A/B
      XL = 0.0
      XR = 1.0
      FXL = -P
      FXR = 1.0 - P
CCCCC INVALID P EXPLICITLY CHECKED FOR EARLIER.
      IF(FXL*FXR .GT. ZERO)GOTO50
C
C  BISECTION METHOD
C
  105 CONTINUE
      X = (XL+XR)*0.5
      DX=DBLE(X)
      DALPHA=DBLE(A)
      DBETA=DBLE(B)
      DCDF=DBETAI(DX,DALPHA,DBETA)
      P1=REAL(DCDF)
      PPF=X
CCCCC IF(IERR.NE.0)THEN
CCCCC   WRITE(ICOUT,120)
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC ENDIF
CC120 FORMAT('***** FATAL ERROR--ERROR IN BETCDF ROUTINE.  *****')
      FCS = P1 - P
      IF(FCS*FXL.GT.ZERO)GOTO110
      XR = X
      FXR = FCS 
      GOTO115
  110 CONTINUE
      XL = X
      FXL = FCS
  115 CONTINUE
      XRML = XR - XL
      IF(XRML.LE.SIG .AND. ABS(FCS).LE.EPS)GOTO9999
      IC = IC + 1
      IF(IC.LE.MAXIT)GOTO105
      WRITE(ICOUT,130)
      CALL DPWRST('XXX','BUG ')
  130 FORMAT('***** FATAL ERROR--BETPPF ROUTINE DID NOT CONVERGE. ***')
      GOTO9999
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE BETRAN(N,ALPHA,BETA,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE BETA DISTRIBUTION
C          WITH SINGLE PRECISION SHAPE
C          PARAMETERS = ALPHA AND BETA.
C              THE PROTOTYPE BETA DISTRIBUTION USED
C              HEREIN HAS MEAN = ALPHA/(ALPHA+BETA)
C              AND STANDARD DEVIATION =
C              SQRT((ALPHA*BETA) / ((ALPHA+BETA)**2)*(ALPHA+BETA+1))
C              THIS DISTRIBUTION IS DEFINED FOR ALL X
C              BETWEEN 0.0 (INCLUSIVELY) AND 1.0 (INCLUSIVELY).
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C              F(X) = (1/CONSTANT) * X**(ALPHA-1) * (1.0-X)**(BETA-1)
C              WHERE THE CONSTANT = THE BETA FUNCTION EVALUATED
C              AT THE VALUES ALPHA AND BETA.
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --ALPHA  = THE SINGLE PRECISION VALUE OF THE
C                                FIRST  SHAPE PARAMETER.
C                                ALPHA SHOULD BE GREATER THAN
C                                OR EQUAL TO 1.0.
C                     --BETA   = THE SINGLE PRECISION VALUE OF THE
C                                SECOND SHAPE PARAMETER.
C                                BETA  SHOULD BE GREATER THAN
C                                OR EQUAL TO 1.0.
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST N)
C                                INTO WHICH THE GENERATED
C                                RANDOM SAMPLE WILL BE PLACED.
C     OUTPUT--A RANDOM SAMPLE OF SIZE N
C             FROM THE BETA DISTRIBUTION
C             WITH SHAPE PARAMETER VALUES = ALPHA AND BETA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C                 --ALPHA SHOULD BE GREATER THAN
C                   OR EQUAL TO 1.0.
C                 --BETA  SHOULD BE GREATER THAN
C                   OR EQUAL TO 1.0.
C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN, NORRAN.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--SQRT, EXP.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--GREENWOOD, 'A FAST GENERATOR FOR
C                 BETA-DISTRIBUTED RANDOM VARIABLES',
C                 COMPSTAT 1974, PROCEEDINGS IN
C                 COMPUTATIONAL STATISTICS, VIENNA,
C                 SEPTEMBER, 1974, PAGES 19-27.
C               --TOCHER, THE ART OF SIMULATION,
C                 1963, PAGES 24-27.
C               --HAMMERSLEY AND HANDSCOMB, MONTE CARLO METHODS,
C                 1964, PAGES 36-37.
C               --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--2, 1970, PAGES 37-56.
C               --HASTINGS AND PEACOCK, STATISTICAL
C                 DISTRIBUTIONS--A HANDBOOK FOR
C                 STUDENTS AND PRACTITIONERS, 1975,
C                 PAGES 30-35.
C               --NATIONAL BUREAU OF STANDARDS APPLIED MATHEMATICS
C                 SERIES 55, 1964, PAGE 952.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLARITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--82.3
C     ORIGINAL VERSION--NOVEMBER  1975.
C     UPDATED         --FEBRUARY  1976.
C     UPDATED         --JUNE      1978.
C     UPDATED         --DECEMBER  1981.
C     UPDATED         --DECEMBER  2001. FOR ALPHA < 1 OR BETA < 1,
C                                       USE PERCENT POINT METHOD
C     UPDATED         --NOVEMBER  2001. FOR ALPHA < 1 OR BETA < 1,
C                                       USE JOHNK'S ALGORITHM
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
C
      DIMENSION XN(2)
      DIMENSION U(2)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----DATA STATEMENTS-------------------------------------------------
C
      DATA ATHIRD/0.33333333/
      DATA SQRT3 /1.73205081/
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)GOTO50
      IF(ALPHA.LE.0.0)GOTO60
      IF(BETA.LT.0.0)GOTO65
      GOTO90
   50 WRITE(ICOUT, 5)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,47)N
      CALL DPWRST('XXX','BUG ')
      RETURN
   60 WRITE(ICOUT,16)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)ALPHA
      CALL DPWRST('XXX','BUG ')
      RETURN
   65 WRITE(ICOUT,26)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)BETA
      CALL DPWRST('XXX','BUG ')
      RETURN
   90 CONTINUE
    5 FORMAT('***** FATAL ERROR--THE FIRST  INPUT ARGUMENT TO THE ',
     1' BETRAN SUBROUTINE IS NON-POSITIVE *****')
   16 FORMAT('***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE ',
     1' BETRAN SUBROUTINE IS SMALLER THAN 0.0 *****')
   26 FORMAT('***** FATAL ERROR--THE THIRD  INPUT ARGUMENT TO THE ',
     1' BETRAN SUBROUTINE IS SMALLER THAN 0.0 *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
C
C     GENERATE N BETA RANDOM NUMBERS
C     BY USING THE FACT THAT
C     IF X1 IS A GAMMA VARIATE WITH PARAMETER ALPHA
C     AND IF X2 IS A GAMMA VARIATE WITH PARAMETER BETA,
C     THEN THE RATIO X1/(X1+X2) IS A BETA VARIATE
C     WITH PARAMETERS ALPHA AND BETA.
C
C     TO GENERATE N GAMMA DISTRIBUTION RANDOM NUMBERS,
C     USE GREENWOOD'S REJECTION ALGORITHM--
C     1) GENERATE A NORMAL RANDOM NUMBER;
C     2) TRANSFORM THE NORMAL VARIATE TO AN APPROXIMATE
C        GAMMA VARIATE USING THE WILSON-HILFERTY
C        APPROXIMATION (SEE THE JOHNSON AND KOTZ
C        REFERENCE, PAGE 176);
C     3) FORM THE REJECTION FUNCTION VALUE, BASED
C        ON THE PROBABILITY DENSITY FUNCTION VALUE
C        OF THE ACTUAL DISTRIBUTION OF THE PSEUDO-GAMMA
C        VARIATE, AND THE PROBABILITY DENSITY FUNCTION VALUE
C        OF A TRUE GAMMA VARIATE.
C     4) GENERATE A UNIFORM RANDOM NUMBER;
C     5) IF THE UNIFORM RANDOM NUMBER IS LESS THAN
C        THE REJECTION FUNCTION VALUE, THEN ACCEPT
C        THE PSEUDO-RANDOM NUMBER AS A GAMMA VARIATE;
C        IF THE UNIFORM RANDOM NUMBER IS LARGER THAN
C        THE REJECTION FUNCTION VALUE, THEN REJECT
C        THE PSEUDO-RANDOM NUMBER AS A GAMMA VARIATE.
C
C     FOR ALPHA < 1 AND BETA < 1, USE JOHNK'S ALGORITHM
C     (JAMES GENTLE, "RANDOM NUMBER GENERATION AND MONTE CARLO
C     METHODS", SECOND EDITION, SPRINGER-VERLANG, 2003.
C     FOR ALPHA OR BETA <= 0, THEN USE THE PERCENT POINT METHOD.
C
      IF(ALPHA.EQ.1.0 .AND. BETA.EQ.1.0)THEN
        CALL UNIRAN(N,ISEED,X)
        GOTO9000
      ENDIF
C
      IF(ALPHA.LT.1.0 .AND. BETA.LT.1.0)THEN
        NTEMP=1
        DO400I=1,N
  401     CONTINUE
          CALL UNIRAN(NTEMP,ISEED,X(I))
          U1=X(I)
          CALL UNIRAN(NTEMP,ISEED,X(I))
          U2=X(I)
          V1=U1**(1.0/ALPHA)
          V2=U2**(1.0/BETA)
          W=V1 + V2
          IF(W.GT.1)GOTO401
          X(I)=V1/W
  400   CONTINUE
        GOTO9000
      ENDIF
C
C     FOR CASE WHERE ALPHA < 1 AND BETA > 1 (OR SIMILARLY,
C     WHEN ALPHA > 1 AND BETA < 1), USE ALGORITHM GIVEN BY
C     IN: "A FAMILY OF SWITCHING ALGORITHMS FOR THE COMPUTER
C     GENERATION OF BETA RANDOM VARIABLES", A. C. ATKINSON,
C     BIOMETRIKA, 1979, 66, 1, PP. 141-145.
C
      IF(ALPHA.LE.1.0 .AND. BETA.GE.1.0)THEN
        NTEMP=2
        P=ALPHA
        Q=BETA
        S1=1.0
CCCCC   T=(ALPHA-1.0)/(BETA+1.0-ALPHA)
        T=(1.0-ALPHA)/(BETA+1.0-ALPHA)
        S2=T**(ALPHA-1.0)
        R=BETA*T/(BETA*T + ALPHA*(1.0-T)**BETA)
C
        DO600I=1,N
  610     CONTINUE
          CALL UNIRAN(NTEMP,ISEED,U)
          U1=U(1)
          U2=U(2)
          IF(U1.LE.R)THEN
            XTEMP=T*(U1/R)**(1.0/P)
            H1=XTEMP**(ALPHA-P)*(1.0-XTEMP)**(BETA-1.0)
            IF(S1*U2.LE.H1)THEN
              X(I)=XTEMP
              GOTO600
            ELSE
              GOTO610
            ENDIF
          ELSE
            XTEMP=1.0 - (1.0-T)*((1.0-U1)/(1.0-R))**(1.0/Q)
            H2=XTEMP**(ALPHA-1.0)
            IF(S2*U2.LE.H2)THEN
              X(I)=XTEMP
              GOTO600
            ELSE
              GOTO610
            ENDIF
          ENDIF
  600   CONTINUE
CCCCC   DO600I=1,N
CCCCC     CALL BETPPF(X(I),ALPHA,BETA,XTEMP)
CCCCC     X(I)=XTEMP
CC600   CONTINUE
        GOTO9000
      ENDIF
      IF(ALPHA.GE.1.0 .AND. BETA.LE.1.0)THEN
C
        ALPSAV=ALPHA
        BETSAV=BETA
        ALPHA=BETSAV
        BETA=ALPSAV
C
        NTEMP=2
        P=ALPHA
        Q=BETA
        S1=1.0
        T=(1.0-ALPHA)/(BETA+1.0-ALPHA)
        S2=T**(ALPHA-1.0)
        R=BETA*T/(BETA*T + ALPHA*(1.0-T)**BETA)
C
        DO700I=1,N
  710     CONTINUE
          CALL UNIRAN(NTEMP,ISEED,U)
          U1=U(1)
          U2=U(2)
          IF(U1.LE.R)THEN
            XTEMP=T*(U1/R)**(1.0/P)
            H1=XTEMP**(ALPHA-P)*(1.0-XTEMP)**(BETA-1.0)
            IF(S1*U2.LE.H1)THEN
              X(I)=1.0-XTEMP
              GOTO700
            ELSE
              GOTO710
            ENDIF
          ELSE
            XTEMP=1.0 - (1.0-T)*((1.0-U1)/(1.0-R))**(1.0/Q)
            H2=XTEMP**(ALPHA-1.0)*(1.0-XTEMP)**(BETA-Q)
            IF(S2*U2.LE.H2)THEN
              X(I)=1.0-XTEMP
              GOTO700
            ELSE
              GOTO710
            ENDIF
          ENDIF
  700   CONTINUE
        ALPHA=ALPSAV
        BETA=BETSAV
        GOTO9000
      ENDIF
C
      A1=1.0/(9.0*ALPHA)
      B1=SQRT(A1)
      XN01=-SQRT3+B1
      XG01=ALPHA*(1.0-A1+B1*XN01)**3
      A2=1.0/(9.0*BETA)
      B2=SQRT(A2)
      XN02=-SQRT3+B2
      XG02=BETA*(1.0-A2+B2*XN02)**3
C
      DO100I=1,N
C
  150 CALL NORRAN(1,ISEED,XN)
      XG=ALPHA*(1.0-A1+B1*XN(1))**3
      IF(XG.LT.0.0)GOTO150
      TERM=(XG/XG01)**(ALPHA-ATHIRD)
      ARG=0.5*XN(1)*XN(1)-XG-0.5*XN01*XN01+XG01
      FUNCT=TERM*EXP(ARG)
      CALL UNIRAN(1,ISEED,U)
      IF(U(1).LE.FUNCT)GOTO170
      GOTO150
  170 XG1=XG
C
  250 CALL NORRAN(1,ISEED,XN)
      XG=BETA*(1.0-A2+B2*XN(1))**3
      IF(XG.LT.0.0)GOTO250
      TERM=(XG/XG02)**(BETA-ATHIRD)
      ARG=0.5*XN(1)*XN(1)-XG-0.5*XN02*XN02+XG02
      FUNCT=TERM*EXP(ARG)
      CALL UNIRAN(1,ISEED,U)
      IF(U(1).LE.FUNCT)GOTO270
      GOTO250
  270 XG2=XG
C
      X(I)=XG1/(XG1+XG2)
C
  100 CONTINUE
C
 9000 CONTINUE
      RETURN
      END
      FUNCTION BI (X)
C***BEGIN PROLOGUE  BI
C***PURPOSE  Evaluate the Bairy function (the Airy function of the
C            second kind).
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C10D
C***TYPE      SINGLE PRECISION (BI-S, DBI-D)
C***KEYWORDS  BAIRY FUNCTION, FNLIB, SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C BI(X) calculates the Airy function of the second kind for real
C argument X.
C
C Series for BIF        on the interval -1.00000D+00 to  1.00000D+00
C                                        with weighted error   1.88E-19
C                                         log weighted error  18.72
C                               significant figures required  17.74
C                                    decimal places required  19.20
C
C Series for BIG        on the interval -1.00000D+00 to  1.00000D+00
C                                        with weighted error   2.61E-17
C                                         log weighted error  16.58
C                               significant figures required  15.17
C                                    decimal places required  17.03
C
C Series for BIF2       on the interval  1.00000D+00 to  8.00000D+00
C                                        with weighted error   1.11E-17
C                                         log weighted error  16.95
C                        approx significant figures required  16.5
C                                    decimal places required  17.45
C
C Series for BIG2       on the interval  1.00000D+00 to  8.00000D+00
C                                        with weighted error   1.19E-18
C                                         log weighted error  17.92
C                        approx significant figures required  17.2
C                                    decimal places required  18.42
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  BIE, CSEVL, INITS, R1MACH, R9AIMP, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770701  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C***END PROLOGUE  BI
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DIMENSION BIFCS(9), BIGCS(8), BIF2CS(10), BIG2CS(10)
      LOGICAL FIRST
      SAVE BIFCS, BIGCS, BIF2CS, BIG2CS, NBIF, NBIG, NBIF2,
     1 NBIG2, X3SML, XMAX, FIRST
      DATA BIFCS( 1) /   -.0167302164 7198664948E0 /
      DATA BIFCS( 2) /    .1025233583 424944561E0 /
      DATA BIFCS( 3) /    .0017083092 5073815165E0 /
      DATA BIFCS( 4) /    .0000118625 4546774468E0 /
      DATA BIFCS( 5) /    .0000000449 3290701779E0 /
      DATA BIFCS( 6) /    .0000000001 0698207143E0 /
      DATA BIFCS( 7) /    .0000000000 0017480643E0 /
      DATA BIFCS( 8) /    .0000000000 0000020810E0 /
      DATA BIFCS( 9) /    .0000000000 0000000018E0 /
      DATA BIGCS( 1) /    .0224662232 4857452E0 /
      DATA BIGCS( 2) /    .0373647754 5301955E0 /
      DATA BIGCS( 3) /    .0004447621 8957212E0 /
      DATA BIGCS( 4) /    .0000024708 0756363E0 /
      DATA BIGCS( 5) /    .0000000079 1913533E0 /
      DATA BIGCS( 6) /    .0000000000 1649807E0 /
      DATA BIGCS( 7) /    .0000000000 0002411E0 /
      DATA BIGCS( 8) /    .0000000000 0000002E0 /
      DATA BIF2CS( 1) /   0.0998457269 3816041E0 /
      DATA BIF2CS( 2) /    .4786249778 63005538E0 /
      DATA BIF2CS( 3) /    .0251552119 604330118E0 /
      DATA BIF2CS( 4) /    .0005820693 885232645E0 /
      DATA BIF2CS( 5) /    .0000074997 659644377E0 /
      DATA BIF2CS( 6) /    .0000000613 460287034E0 /
      DATA BIF2CS( 7) /    .0000000003 462753885E0 /
      DATA BIF2CS( 8) /    .0000000000 014288910E0 /
      DATA BIF2CS( 9) /    .0000000000 000044962E0 /
      DATA BIF2CS(10) /    .0000000000 000000111E0 /
      DATA BIG2CS( 1) /    .0333056621 45514340E0 /
      DATA BIG2CS( 2) /    .1613092151 23197068E0 /
      DATA BIG2CS( 3) /    .0063190073 096134286E0 /
      DATA BIG2CS( 4) /    .0001187904 568162517E0 /
      DATA BIG2CS( 5) /    .0000013045 345886200E0 /
      DATA BIG2CS( 6) /    .0000000093 741259955E0 /
      DATA BIG2CS( 7) /    .0000000000 474580188E0 /
      DATA BIG2CS( 8) /    .0000000000 001783107E0 /
      DATA BIG2CS( 9) /    .0000000000 000005167E0 /
      DATA BIG2CS(10) /    .0000000000 000000011E0 /
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  BI
      IF (FIRST) THEN
         ETA = 0.1*R1MACH(3)
         NBIF  = INITS (BIFCS , 9, ETA)
         NBIG  = INITS (BIGCS , 8, ETA)
         NBIF2 = INITS (BIF2CS, 10, ETA)
         NBIG2 = INITS (BIG2CS, 10, ETA)
C
         X3SML = ETA**0.3333
         XMAX = (1.5*LOG(R1MACH(2)))**0.6666
      ENDIF
      FIRST = .FALSE.
C
      IF (X.GE.(-1.0)) GO TO 20
      CALL R9AIMP (X, XM, THETA)
      BI = XM * SIN(THETA)
      RETURN
C
 20   IF (X.GT.1.0) GO TO 30
      Z = 0.0
      IF (ABS(X).GT.X3SML) Z = X**3
      BI = 0.625 + CSEVL (Z, BIFCS, NBIF) + X*(0.4375 +
     1  CSEVL (Z, BIGCS, NBIG))
      RETURN
C
 30   IF (X.GT.2.0) GO TO 40
      Z = (2.0*X**3 - 9.0) / 7.0
      BI = 1.125 + CSEVL (Z, BIF2CS, NBIF2) + X*(0.625 +
     1  CSEVL (Z, BIG2CS, NBIG2))
      RETURN
C
 40   IF (X .GT. XMAX) THEN
        WRITE(ICOUT,1)
        CALL DPWRST('XXX','BUG ')
        BI = 0.0
        RETURN
      ENDIF
    1 FORMAT('***** ERORR FROM BI, OVERFLOWS BECAUSE THE ',
     1       'VALUE OF X IS TOO BIG.  ****')
C
      BI = BIE(X) * EXP(2.0*X*SQRT(X)/3.0)
      RETURN
C
      END
      FUNCTION BIE (X)
C***BEGIN PROLOGUE  BIE
C***PURPOSE  Calculate the Bairy function for a negative argument and an
C            exponentially scaled Bairy function for a non-negative
C            argument.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C10D
C***TYPE      SINGLE PRECISION (BIE-S, DBIE-D)
C***KEYWORDS  BAIRY FUNCTION, EXPONENTIALLY SCALED, FNLIB,
C             SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C Evaluate BI(X) for X .LE. 0  and  BI(X)*EXP(ZETA)  where
C ZETA = 2/3 * X**(3/2)  for X .GE. 0.0
C
C Series for BIF        on the interval -1.00000D+00 to  1.00000D+00
C                                        with weighted error   1.88E-19
C                                         log weighted error  18.72
C                               significant figures required  17.74
C                                    decimal places required  19.20
C
C Series for BIG        on the interval -1.00000D+00 to  1.00000D+00
C                                        with weighted error   2.61E-17
C                                         log weighted error  16.58
C                               significant figures required  15.17
C                                    decimal places required  17.03
C
C Series for BIF2       on the interval  1.00000D+00 to  8.00000D+00
C                                        with weighted error   1.11E-17
C                                         log weighted error  16.95
C                        approx significant figures required  16.5
C                                    decimal places required  17.45
C
C Series for BIG2       on the interval  1.00000D+00 to  8.00000D+00
C                                        with weighted error   1.19E-18
C                                         log weighted error  17.92
C                        approx significant figures required  17.2
C                                    decimal places required  18.42
C
C Series for BIP        on the interval  1.25000D-01 to  3.53553D-01
C                                        with weighted error   1.91E-17
C                                         log weighted error  16.72
C                               significant figures required  15.35
C                                    decimal places required  17.41
C
C Series for BIP2       on the interval  0.          to  1.25000D-01
C                                        with weighted error   1.05E-18
C                                         log weighted error  17.98
C                               significant figures required  16.74
C                                    decimal places required  18.71
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  CSEVL, INITS, R1MACH, R9AIMP
C***REVISION HISTORY  (YYMMDD)
C   770701  DATE WRITTEN
C   890206  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C***END PROLOGUE  BIE
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      LOGICAL FIRST
      DIMENSION BIFCS(9), BIGCS(8), BIF2CS(10), BIG2CS(10), BIPCS(24),
     1  BIP2CS(29)
      SAVE BIFCS, BIGCS, BIF2CS, BIG2CS, BIPCS, BIP2CS, ATR, BTR,
     1 NBIF, NBIG, NBIF2, NBIG2, NBIP, NBIP2, X3SML, X32SML, XBIG, FIRST
      DATA BIFCS( 1) /   -.0167302164 7198664948E0 /
      DATA BIFCS( 2) /    .1025233583 424944561E0 /
      DATA BIFCS( 3) /    .0017083092 5073815165E0 /
      DATA BIFCS( 4) /    .0000118625 4546774468E0 /
      DATA BIFCS( 5) /    .0000000449 3290701779E0 /
      DATA BIFCS( 6) /    .0000000001 0698207143E0 /
      DATA BIFCS( 7) /    .0000000000 0017480643E0 /
      DATA BIFCS( 8) /    .0000000000 0000020810E0 /
      DATA BIFCS( 9) /    .0000000000 0000000018E0 /
      DATA BIGCS( 1) /    .0224662232 4857452E0 /
      DATA BIGCS( 2) /    .0373647754 5301955E0 /
      DATA BIGCS( 3) /    .0004447621 8957212E0 /
      DATA BIGCS( 4) /    .0000024708 0756363E0 /
      DATA BIGCS( 5) /    .0000000079 1913533E0 /
      DATA BIGCS( 6) /    .0000000000 1649807E0 /
      DATA BIGCS( 7) /    .0000000000 0002411E0 /
      DATA BIGCS( 8) /    .0000000000 0000002E0 /
      DATA BIF2CS( 1) /   0.0998457269 3816041E0 /
      DATA BIF2CS( 2) /    .4786249778 63005538E0 /
      DATA BIF2CS( 3) /    .0251552119 604330118E0 /
      DATA BIF2CS( 4) /    .0005820693 885232645E0 /
      DATA BIF2CS( 5) /    .0000074997 659644377E0 /
      DATA BIF2CS( 6) /    .0000000613 460287034E0 /
      DATA BIF2CS( 7) /    .0000000003 462753885E0 /
      DATA BIF2CS( 8) /    .0000000000 014288910E0 /
      DATA BIF2CS( 9) /    .0000000000 000044962E0 /
      DATA BIF2CS(10) /    .0000000000 000000111E0 /
      DATA BIG2CS( 1) /    .0333056621 45514340E0 /
      DATA BIG2CS( 2) /    .1613092151 23197068E0 /
      DATA BIG2CS( 3) /    .0063190073 096134286E0 /
      DATA BIG2CS( 4) /    .0001187904 568162517E0 /
      DATA BIG2CS( 5) /    .0000013045 345886200E0 /
      DATA BIG2CS( 6) /    .0000000093 741259955E0 /
      DATA BIG2CS( 7) /    .0000000000 474580188E0 /
      DATA BIG2CS( 8) /    .0000000000 001783107E0 /
      DATA BIG2CS( 9) /    .0000000000 000005167E0 /
      DATA BIG2CS(10) /    .0000000000 000000011E0 /
      DATA BIPCS( 1) /   -.0832204747 7943447E0 /
      DATA BIPCS( 2) /    .0114611892 7371174E0 /
      DATA BIPCS( 3) /    .0004289644 0718911E0 /
      DATA BIPCS( 4) /   -.0001490663 9379950E0 /
      DATA BIPCS( 5) /   -.0000130765 9726787E0 /
      DATA BIPCS( 6) /    .0000063275 9839610E0 /
      DATA BIPCS( 7) /   -.0000004222 6696982E0 /
      DATA BIPCS( 8) /   -.0000001914 7186298E0 /
      DATA BIPCS( 9) /    .0000000645 3106284E0 /
      DATA BIPCS(10) /   -.0000000078 4485467E0 /
      DATA BIPCS(11) /   -.0000000009 6077216E0 /
      DATA BIPCS(12) /    .0000000007 0004713E0 /
      DATA BIPCS(13) /   -.0000000001 7731789E0 /
      DATA BIPCS(14) /    .0000000000 2272089E0 /
      DATA BIPCS(15) /    .0000000000 0165404E0 /
      DATA BIPCS(16) /   -.0000000000 0185171E0 /
      DATA BIPCS(17) /    .0000000000 0059576E0 /
      DATA BIPCS(18) /   -.0000000000 0012194E0 /
      DATA BIPCS(19) /    .0000000000 0001334E0 /
      DATA BIPCS(20) /    .0000000000 0000172E0 /
      DATA BIPCS(21) /   -.0000000000 0000145E0 /
      DATA BIPCS(22) /    .0000000000 0000049E0 /
      DATA BIPCS(23) /   -.0000000000 0000011E0 /
      DATA BIPCS(24) /    .0000000000 0000001E0 /
      DATA BIP2CS( 1) /   -.1135967375 85988679E0 /
      DATA BIP2CS( 2) /    .0041381473 947881595E0 /
      DATA BIP2CS( 3) /    .0001353470 622119332E0 /
      DATA BIP2CS( 4) /    .0000104273 166530153E0 /
      DATA BIP2CS( 5) /    .0000013474 954767849E0 /
      DATA BIP2CS( 6) /    .0000001696 537405438E0 /
      DATA BIP2CS( 7) /   -.0000000100 965008656E0 /
      DATA BIP2CS( 8) /   -.0000000167 291194937E0 /
      DATA BIP2CS( 9) /   -.0000000045 815364485E0 /
      DATA BIP2CS(10) /    .0000000003 736681366E0 /
      DATA BIP2CS(11) /    .0000000005 766930320E0 /
      DATA BIP2CS(12) /    .0000000000 621812650E0 /
      DATA BIP2CS(13) /   -.0000000000 632941202E0 /
      DATA BIP2CS(14) /   -.0000000000 149150479E0 /
      DATA BIP2CS(15) /    .0000000000 078896213E0 /
      DATA BIP2CS(16) /    .0000000000 024960513E0 /
      DATA BIP2CS(17) /   -.0000000000 012130075E0 /
      DATA BIP2CS(18) /   -.0000000000 003740493E0 /
      DATA BIP2CS(19) /    .0000000000 002237727E0 /
      DATA BIP2CS(20) /    .0000000000 000474902E0 /
      DATA BIP2CS(21) /   -.0000000000 000452616E0 /
      DATA BIP2CS(22) /   -.0000000000 000030172E0 /
      DATA BIP2CS(23) /    .0000000000 000091058E0 /
      DATA BIP2CS(24) /   -.0000000000 000009814E0 /
      DATA BIP2CS(25) /   -.0000000000 000016429E0 /
      DATA BIP2CS(26) /    .0000000000 000005533E0 /
      DATA BIP2CS(27) /    .0000000000 000002175E0 /
      DATA BIP2CS(28) /   -.0000000000 000001737E0 /
      DATA BIP2CS(29) /   -.0000000000 000000010E0 /
      DATA ATR / 8.750690570 8484345 E0 /
      DATA BTR / -2.093836321 356054 E0 /
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  BIE
      IF (FIRST) THEN
         ETA = 0.1*R1MACH(3)
         NBIF = INITS (BIFCS, 9, ETA)
         NBIG = INITS (BIGCS, 8, ETA)
         NBIF2 = INITS (BIF2CS, 10, ETA)
         NBIG2 = INITS (BIG2CS, 10, ETA)
         NBIP  = INITS (BIPCS , 24, ETA)
         NBIP2 = INITS (BIP2CS, 29, ETA)
C
         X3SML = ETA**0.3333
         X32SML = 1.3104*X3SML**2
         XBIG = R1MACH(2)**0.6666
      ENDIF
      FIRST = .FALSE.
C
      IF (X.GE.(-1.0)) GO TO 20
      CALL R9AIMP (X, XM, THETA)
      BIE = XM * SIN(THETA)
      RETURN
C
 20   IF (X.GT.1.0) GO TO 30
      Z = 0.0
      IF (ABS(X).GT.X3SML) Z = X**3
      BIE = 0.625 + CSEVL (Z, BIFCS, NBIF) + X*(0.4375 +
     1  CSEVL (Z, BIGCS, NBIG))
      IF (X.GT.X32SML) BIE = BIE * EXP(-2.0*X*SQRT(X)/3.0)
      RETURN
C
 30   IF (X.GT.2.0) GO TO 40
      Z = (2.0*X**3 - 9.0) / 7.0
      BIE = EXP(-2.0*X*SQRT(X)/3.0) * (1.125 + CSEVL (Z, BIF2CS, NBIF2)
     1  + X*(0.625 + CSEVL (Z, BIG2CS, NBIG2)) )
      RETURN
C
 40   IF (X.GT.4.0) GO TO 50
      SQRTX = SQRT(X)
      Z = ATR/(X*SQRTX) + BTR
      BIE = (0.625 + CSEVL (Z, BIPCS, NBIP)) / SQRT(SQRTX)
      RETURN
C
 50   SQRTX = SQRT(X)
      Z = -1.0
      IF (X.LT.XBIG) Z = 16.0/(X*SQRTX) - 1.0
      BIE = (0.625 + CSEVL (Z, BIP2CS, NBIP2))/SQRT(SQRTX)
      RETURN
C
      END
      SUBROUTINE BILINR(Z,Y,X,N,Y2,X2,N2,IWRITE,Z2,
     1IBUGG3,ISUBRO,IERROR)
C
C     PURPOSE--COMPUTE BI-LINEAR INTERPOLATION OF A VARIABLE
C              (GENERATE INTERPOLATED POINTS).
C     INPUT  ARGUMENTS--Z      = SINGLE PRECISION VARIABLE
C                                CONTAINING THE ORIGINAL
C                                Z AXIS DATA POINTS.
C                     --Y      = SINGLE PRECISION VARIABLE
C                                CONTAINING THE ORIGINAL
C                                VERTICAL AXIS DATA POINTS.
C                     --X      = SINGLE PRECISION VARIABLE
C                                CONTAINING THE ORIGINAL
C                                HORIZONTAL AXIS DATA POINTS.
C                     --Y2     = SINGLE PRECISION VARIABLE
C                                CONTAINING THE DESIRED
C                                VERTICAL AXIS INTERPOLATION
C                     --X2     = SINGLE PRECISION VARIABLE
C                                CONTAINING THE DESIRED
C                                HORIZONTAL AXIS INTERPOLATION
C                                POINTS.
C     OUTPUT ARGUMENTS--Z2     = SINGLE PRECISION VARIABLE
C                                CONTAINING THE COMPUTED
C                                Z AXIS INTERPOLATION
C                                POINTS.
C     NOTE--IT IS PROBABLY NOT PERMISSIBLE TO HAVE THE OUTPUT VECTOR
C           Y2(.) BEING IDENTICAL TO THE INPUT VECTOR Y(.)
C     NOTE--THIS SUBROUTINE DOES NOT ASSUME THAT THE INPUT
C           DATA IS ALREADY SORTED ACCORDING TO THE
C           HORIZONTAL AXIS VARIABLE.
C           SUCH SORTING IS DOEN HEREIN.
C     NOTE--IT DOES ASSUME THAT THE ORIGINAL (Y,X) POINTS FORM A 
C           RECTANGULAR GRID (ALTHOUGH THE GRID DOES NOT HAVE TO BE
C           PRE-SORTED).
C     CAUTION--THE INPUT VECTORS Y AND X ARE SORTED HEREIN
C              AND SO MAY BE DIFFERENT UPON LEAVING THIS SUBROUTINE
C              THAN UPON ENTERING THIS SUBROUTINE.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--94/5
C     ORIGINAL VERSION--MAY       1994.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGG3
      CHARACTER*4 ISUBRO
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 ISTEPN
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOPA.INC'
C
      DIMENSION Z(*)
      DIMENSION Y(*)
      DIMENSION X(*)
      DIMENSION X2(*)
      DIMENSION Y2(*)
      DIMENSION Z2(*)
C
      DIMENSION YTEMP(MAXOBV)
      DIMENSION XTEMP(MAXOBV)
      DIMENSION YDIST(MAXOBV)
      DIMENSION XDIST(MAXOBV)
      DIMENSION ZDIST(MAXOBV)
      DIMENSION ZTEMP2(MAXOBV)
      DIMENSION ZTEMP(MAXOBV)
C
      INCLUDE 'DPCOZZ.INC'
      INCLUDE 'DPCOZ2.INC'
      EQUIVALENCE (G2RBAG(IGAR11),YTEMP(1))
      EQUIVALENCE (G2RBAG(IGAR12),YDIST(1))
      EQUIVALENCE (G2RBAG(IGAR13),XDIST(1))
      EQUIVALENCE (G2RBAG(IGAR14),ZDIST(1))
      EQUIVALENCE (G2RBAG(IGAR15),ZTEMP2(1))
      EQUIVALENCE (G2RBAG(IGAR16),ZTEMP(1))
      EQUIVALENCE (G2RBAG(IGAR17),XTEMP(1))
CCCCC END CHANGE
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='BILI'
      ISUBN2='NR  '
C
      IERROR='NO'
C
      IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'LINR')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF BILINR--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)N
   52 FORMAT('N = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO55I=1,N
      WRITE(ICOUT,56)I,Z(I),Y(I),X(I)
   56 FORMAT('I,Z(I),Y(I),X(I) = ',I8,3E15.7)
      CALL DPWRST('XXX','BUG ')
   55 CONTINUE
      WRITE(ICOUT,62)N2
   62 FORMAT('N2 = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO65I=1,N2
      WRITE(ICOUT,66)I,Y2(I),X2(I)
   66 FORMAT('I,Y2(I),X2(I) = ',I8,2E15.7)
      CALL DPWRST('XXX','BUG ')
   65 CONTINUE
   90 CONTINUE
C
C               ****************************************
C               **  STEP 11--                         **
C               **  SORT THE INPUT DATA ACCORDING     **
C               **  TO THE HORIZONTAL AXIS VARIABLE   **
C               ****************************************
C
      ISTEPN='11'
      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'LINR')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      DO1010,I=1,N
      XTEMP(I)=X(I)
 1010 CONTINUE
C
      CALL SORTC(X,Y,N,X,Y)
      CALL SORTC(XTEMP,Z,N,XTEMP,Z)
C
C               *******************************************************
C               **  STEP 12--                                        **
C               **  DETERMINE THE NUMBER OF DISTINCT X VALUES        **
C               *******************************************************
C
      ISTEPN='12'
      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'LINR')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      NDISTX=0
      DO1210I=1,N
      IF(NDISTX.EQ.0)GOTO1220
      DO1215I2=1,NDISTX
      IF(X(I).EQ.XDIST(I2))GOTO1210
 1215 CONTINUE
 1220 CONTINUE
      NDISTX=NDISTX+1
      XDIST(NDISTX)=X(I)
 1210 CONTINUE
C
      CALL SORT(XDIST,NDISTX,XDIST)
C
C               *******************************************************
C               **  STEP 13--                                        **
C               **  DETERMINE THE NUMBER OF DISTINCT Y VALUES        **
C               *******************************************************
C
      ISTEPN='13'
      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'LINR')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      NDISTY=0
      DO1310I=1,N
      IF(NDISTY.EQ.0)GOTO1320
      DO1315I2=1,NDISTY
      IF(Y(I).EQ.YDIST(I2))GOTO1310
 1315 CONTINUE
 1320 CONTINUE
      NDISTY=NDISTY+1
      YDIST(NDISTY)=Y(I)
 1310 CONTINUE
C
      CALL SORT(YDIST,NDISTY,YDIST)
C
C               *******************************************************
C               **  STEP 14--                                        **
C               **  SORT Y ASSOCIATED WITH EACH DISTINCT X VALUE     **
C               **  CHECK FOR REPLICATION OF POINTS                  **
C               **  IF ALL DISTINCT (THAT IS, NO REPLICATION),     **
C               **  (THAT IS, HAVE NO REPLICATION),                **
C               **  THEN COPY OVER Z VALUES.                       **
C               **  IF NOT ALL DISTINCT                            **
C               **  (THAT IS, HAVE SOME REPLICATION),              **
C               **  THEN COMPUTE A MEAN VALUE OVER THE REPLICATES  **
C               **  AND TREAT THAT AS THE COMMON VALUE.            **
C               **  THE CORE OF THE INTERPOLATION CODE             **
C               **  IS EXPECTING SORTED, DISTINCT X AND Y VALUES.   **
C               **  ALSO CHECK THAT X AND Y FORM A RECTANGULAR GRID.**
C               *******************************************************
C
      ISTEPN='14'
      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'LINR')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      NUMZ=0
      ISTART=1
      DO1410I=1,NDISTX
        XT=XDIST(I)
        ICOUNT=0
        DO1420J=ISTART,N
        IF(X(J).EQ.XT)THEN
          IF(ICOUNT.EQ.0)IFRST=J
          ICOUNT=ICOUNT+1
          YTEMP(ICOUNT)=Y(J)
          ZTEMP(ICOUNT)=Z(J)
          ILAST=J
        ELSEIF(X(J).GT.XT)THEN
          GOTO1421
        ENDIF
 1420   CONTINUE
 1421   CONTINUE
C
        ISTART=ILAST+1
        CALL SORTC(YTEMP,ZTEMP,ICOUNT,YTEMP,ZTEMP)
        DO1471K=1,NDISTY
          TAG=YDIST(K)
          J=0
          DO1472II=1,ICOUNT
            IF(YTEMP(II).EQ.TAG)THEN
              J=J+1
              ZTEMP2(J)=ZTEMP(II)
            END IF
 1472     CONTINUE
          NI=J
          IF(NI.EQ.1)THEN
            NUMZ=NUMZ+1
            ZDIST(NUMZ)=ZTEMP2(1)
          ELSE IF(NI.GT.1)THEN
            CALL MEAN(ZTEMP2,NI,IWRITE,ZMEAN,IBUGG3,IERROR)
            NUMZ=NUMZ+1
            ZDIST(NUMZ)=ZMEAN
          ELSE
            WRITE(ICOUT,999)
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,1491)
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,1492)
            CALL DPWRST('XXX','BUG ')
            IERROR='YES'
            GOTO9000
          ENDIF
 1471   CONTINUE
C
 1410 CONTINUE
C
 1491 FORMAT('******* ERROR FROM BILINR.  ORIGINAL X AND Y')
 1492 FORMAT('        DATA DO NOT FORM A RECTANGULAR GRID.  ******')
C
C               ********************************************
C               **  STEP 14--                             **
C               **  COMPUTE INTERPOLATED VALUES           **
C               ********************************************
C
      CALL BILIN2(ZDIST,YDIST,XDIST,NDISTX,NDISTY,Y2,X2,N2,Z2,
     1IBUGG3,ISUBRO,IERROR)
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'LINR')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF BILINR--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)N,N2
 9012 FORMAT('N,N2 = ',2I8)
      CALL DPWRST('XXX','BUG ')
      DO9042I=1,N2
      WRITE(ICOUT,9043)I,X2(I),Y2(I),Z2(I)
 9043 FORMAT('I,X2(I),Y2(I),Z2(I) = ',I8,3E15.7)
      CALL DPWRST('XXX','BUG ')
 9042 CONTINUE
      WRITE(ICOUT,9051)NDISTX,NDISTY
 9051 FORMAT('NDISTX,NDISTY = ',2I8)
      CALL DPWRST('XXX','BUG ')
      DO9052I=1,NDISTX
      DO9054J=1,NDISTY
      WRITE(ICOUT,9053)I,J,XDIST(I),YDIST(J),ZDIST((I-1)*NDISTY+J)
 9053 FORMAT('I,J,XDIST(I),YDIST(J),ZDIST = ',2I8,3E15.7)
      CALL DPWRST('XXX','BUG ')
 9054 CONTINUE
 9052 CONTINUE
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE BILIN2(Z,Y,X,NX,NY,Y2,X2,N2,Z2,IBUGG3,ISUBRO,IERROR)
C
C     PURPOSE--COMPUTE BI-LINEAR INTERPOLATION OF A VARIABLE
C              (GENERATE INTERPOLATED POINTS).
C     INPUT  ARGUMENTS--Z      = SINGLE PRECISION VARIABLE
C                                CONTAINING THE ORIGINAL
C                                Z AXIS DATA POINTS.
C                     --Y      = SINGLE PRECISION VARIABLE
C                                CONTAINING THE ORIGINAL
C                                VERTICAL AXIS DATA POINTS.
C                     --X      = SINGLE PRECISION VARIABLE
C                                CONTAINING THE ORIGINAL
C                                HORIZONTAL AXIS DATA POINTS.
C                     --Y2     = SINGLE PRECISION VARIABLE
C                                CONTAINING THE DESIRED
C                                VERTICAL AXIS INTERPOLATION
C                     --X2     = SINGLE PRECISION VARIABLE
C                                CONTAINING THE DESIRED
C                                HORIZONTAL AXIS INTERPOLATION
C                                POINTS.
C     OUTPUT ARGUMENTS--Z2     = SINGLE PRECISION VARIABLE
C                                CONTAINING THE COMPUTED
C                                VERTICAL AXIS INTERPOLATION
C                                POINTS.
C     NOTE--IT IS PROBABLY NOT PERMISSIBLE TO HAVE THE OUTPUT VECTOR 
C           Z2(.) BEING IDENTICAL TO THE INPUT VECTOR Z(.)
C     NOTE--THE X AND Y POINTS ARE ASSUMED TO LIE ON A RECTANGULAR GRID
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--94/5
C     ORIGINAL VERSION--MAY       1994.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IBUGG3
      CHARACTER*4 ISUBRO
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
C
      DIMENSION Z(*)
      DIMENSION Y(*)
      DIMENSION X(*)
      DIMENSION Z2(*)
      DIMENSION Y2(*)
      DIMENSION X2(*)
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='BILI'
      ISUBN2='N2  '
C
      IERROR='NO'
C
      DO10I=1,N2
      Z2(I)=0.0
 10   CONTINUE
C
      IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'LIN2')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF BILIN2--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)NX,NY
   52 FORMAT('NX, NY = ',2I8)
      CALL DPWRST('XXX','BUG ')
      DO54I=1,NX
      DO55J=1,NY
      INDX=(I-1)*NY+J
      WRITE(ICOUT,53)I,J,X(I),Y(J),Z(INDX)
      CALL DPWRST('XXX','BUG ')
 53   FORMAT('I,J,X(I),Y(J),Z = ',2I8,3E15.7)
      CALL DPWRST('XXX','BUG ')
 55   CONTINUE
 54   CONTINUE
      WRITE(ICOUT,62)N2
   62 FORMAT('N2 = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO65I=1,N2
      WRITE(ICOUT,66)I,Y2(I),X2(I)
   66 FORMAT('I,Y2(I),X2(I) = ',I8,2E15.7)
      CALL DPWRST('XXX','BUG ')
   65 CONTINUE
   90 CONTINUE
C
C               ****************************************
C               **  STEP 31--
C               **  COMPUTE INTERPOLATION VALUES
C               ****************************************
C
      DO3100J=1,N2
      XT=X2(J)
      IF(X(1).GT.XT.OR.XT.GT.X(NX))GOTO3110
      YT=Y2(J)
      IF(Y(1).GT.YT.OR.YT.GT.Y(NY))GOTO3120
      GOTO3129
C
 3110 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3111)
 3111 FORMAT('***** ERROR IN BILIN2--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3112)
 3112 FORMAT('      AN ATTEMPT WAS MADE TO COMPUTE')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3113)
 3113 FORMAT('      A SMOOTHED VALUE BEYOND THE X RANGE')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3114)
 3114 FORMAT('      OF THE DATA--SUCH EXTRAPOLATION')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3115)
 3115 FORMAT('      IS UNRELIABLE AND NOT PERMITTED.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3116)X(1)
 3116 FORMAT('         SMALLEST DATA POINT X(1)      = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3117)X(NX)
 3117 FORMAT('         LARGEST DATA POINT  X(NX)     = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3118)XT
 3118 FORMAT('         ATTEMPTED EXTRAPOLATION POINT = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
C
 3120 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3121)
 3121 FORMAT('***** ERROR IN BILIN2--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3122)
 3122 FORMAT('      AN ATTEMPT WAS MADE TO COMPUTE')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3123)
 3123 FORMAT('      A SMOOTHED VALUE BEYOND THE Y RANGE')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3124)
 3124 FORMAT('      OF THE DATA--SUCH EXTRAPOLATION')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3125)
 3125 FORMAT('      IS UNRELIABLE AND NOT PERMITTED.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3126)Y(1)
 3126 FORMAT('         SMALLEST DATA POINT Y(1)      = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3127)Y(NY)
 3127 FORMAT('         LARGEST DATA POINT  Y(NY)     = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3128)YT
 3128 FORMAT('         ATTEMPTED EXTRAPOLATION POINT = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
C
 3129 CONTINUE
C
      DO3200I=1,NX-1
      IF(XT.GE.X(I).AND.XT.LE.X(I+1))THEN
        IX1=I
        IX2=I+1
        GOTO3209
      ENDIF
 3200 CONTINUE
 3209 CONTINUE
C
      DO3210I=1,NY-1
      IF(YT.GE.Y(I).AND.YT.LE.Y(I+1))THEN
        IY1=I
        IY2=I+1
        GOTO3219
      ENDIF
 3210 CONTINUE
 3219 CONTINUE
C
      A1=Z(NX*(IX1-1)+IY1)
      A2=Z(NX*(IX2-1)+IY1)
      A3=Z(NX*(IX2-1)+IY2)
      A4=Z(NX*(IX1-1)+IY2)
      T=XT-X(IX1)/(X(IX2)-X(IX1))
      U=YT-Y(IY1)/(Y(IY2)-Y(IY1))
      Z2(J)=(1.0-T)*(1.0-U)*A1 + T*(1.0-U)*A2 + T*U*A3 + (1.0-T)*U*A4
C
 3100 CONTINUE
C
C               ****************************************
C               **  STEP 41--
C               **  IF CALLED FOR,
C               **  WRITE OUT INTERPOLATION VALUES
C               ****************************************
C
      IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'LIN2')GOTO4190
      DO4100J=1,N2
      WRITE(ICOUT,4110)X2(J),Y2(J),Z2(J)
      CALL DPWRST('XXX','BUG ')
 4110 FORMAT('X2(J),Y2(J),Z2(J) = ',3E15.7)
 4100 CONTINUE
 4190 CONTINUE
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'LIN2')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF BILIN2--')
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE BINCDF(X,P,N,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE AT THE SINGLE PRECISION VALUE X
C              FOR THE BINOMIAL DISTRIBUTION
C              WITH SINGLE PRECISION 'BERNOULLI PROBABILITY'
C              PARAMETER = P,
C              AND INTEGER 'NUMBER OF BERNOULLI TRIALS'
C              PARAMETER = N.
C              THE BINOMIAL DISTRIBUTION USED
C              HEREIN HAS MEAN = N*P
C              AND STANDARD DEVIATION = SQRT(N*P*(1-P)).
C              THIS DISTRIBUTION IS DEFINED FOR ALL
C              DISCRETE INTEGER X BETWEEN 0 (INCLUSIVELY)
C              AND N (INCLUSIVELY).
C              THIS DISTRIBUTION HAS THE PROBABILITY FUNCTION
C              F(X) = C(N,X) * P**X * (1-P)**(N-X).
C              WHERE C(N,X) IS THE COMBINATORIAL FUNCTION
C              EQUALING THE NUMBER OF COMBINATIONS OF N ITEMS
C              TAKEN X AT A TIME.
C              THE BINOMIAL DISTRIBUTION IS THE
C              DISTRIBUTION OF THE NUMBER OF
C              SUCCESSES IN N BERNOULLI (0,1)
C              TRIALS WHERE THE PROBABILITY OF SUCCESS
C              IN A SINGLE TRIAL = P.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE
C                                AT WHICH THE CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE INTEGRAL-VALUED,
C                                AND BETWEEN 0.0 (INCLUSIVELY)
C                                AND N (INCLUSIVELY).
C                     --P      = THE SINGLE PRECISION VALUE
C                                OF THE 'BERNOULLI PROBABILITY'
C                                PARAMETER FOR THE BINOMIAL
C                                DISTRIBUTION.
C                                P SHOULD BE BETWEEN
C                                0.0 (EXCLUSIVELY) AND
C                                1.0 (EXCLUSIVELY).
C                     --N      = THE INTEGER VALUE
C                                OF THE 'NUMBER OF BERNOULLI TRIALS'
C                                PARAMETER.
C                                N SHOULD BE A POSITIVE INTEGER.
C     OUTPUT ARGUMENTS--CDF    = THE SINGLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION
C             FUNCTION VALUE CDF
C             FOR THE BINOMIAL DISTRIBUTION
C             WITH 'BERNOULLI PROBABILITY' PARAMETER = P
C             AND 'NUMBER OF BERNOULLI TRIALS' PARAMETER = N.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE INTEGRAL-VALUED,
C                   AND BETWEEN 0.0 (INCLUSIVELY)
C                   AND N (INCLUSIVELY).
C                 --P SHOULD BE BETWEEN 0.0 (EXCLUSIVELY)
C                   AND 1.0 (EXCLUSIVELY).
C                 --N SHOULD BE A POSITIVE INTEGER.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--DSQRT, DATAN.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     COMMENT--NOTE THAT EVEN THOUGH THE INPUT
C              TO THIS CUMULATIVE
C              DISTRIBUTION FUNCTION SUBROUTINE
C              FOR THIS DISCRETE DISTRIBUTION
C              SHOULD (UNDER NORMAL CIRCUMSTANCES) BE A
C              DISCRETE INTEGER VALUE,
C              THE INPUT VARIABLE X IS SINGLE
C              PRECISION IN MODE.
C              X HAS BEEN SPECIFIED AS SINGLE
C              PRECISION SO AS TO CONFORM WITH THE DATAPAC
C              CONVENTION THAT ALL INPUT ****DATA****
C              (AS OPPOSED TO SAMPLE SIZE, FOR EXAMPLE)
C              VARIABLES TO ALL
C              DATAPAC SUBROUTINES ARE SINGLE PRECISION.
C              THIS CONVENTION IS BASED ON THE BELIEF THAT
C              1) A MIXTURE OF MODES (FLOATING POINT
C              VERSUS INTEGER) IS INCONSISTENT AND
C              AN UNNECESSARY COMPLICATION
C              IN A DATA ANALYSIS; AND
C              2) FLOATING POINT MACHINE ARITHMETIC
C              (AS OPPOSED TO INTEGER ARITHMETIC)
C              IS THE MORE NATURAL MODE FOR DOING
C              DATA ANALYSIS.
C     REFERENCES--HASTINGS AND PEACOCK, STATISTICAL
C                 DISTRIBUTIONS--A HANDBOOK FOR
C                 STUDENTS AND PRACTITIONERS, 1975,
C                 PAGE 38.
C               --NATIONAL BUREAU OF STANDARDS APPLIED MATHEMATICS
C                 SERIES 55, 1964, PAGE 945, FORMULAE 26.5.24 AND
C                 26.5.28, AND PAGE 929.
C               --JOHNSON AND KOTZ, DISCRETE
C                 DISTRIBUTIONS, 1969, PAGES 50-86,
C                 ESPECIALLY PAGES 63-64.
C               --FELLER, AN INTRODUCTION TO PROBABILITY
C                 THEORY AND ITS APPLICATIONS, VOLUME 1,
C                 EDITION 2, 1957, PAGES 135-142.
C               --KENDALL AND STUART, THE ADVANCED THEORY OF
C                 STATISTICS, VOLUME 1, EDITION 2, 1963, PAGES 120-125.
C               --MOOD AND GRABLE, INTRODUCTION TO THE THEORY
C                 OF STATISTICS, EDITION 2, 1963, PAGES 64-69.
C               --OWEN, HANDBOOK OF STATISTICAL
C                 TABLES, 1962, PAGES 264-272.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--82/7
C     ORIGINAL VERSION--NOVEMBER  1975.
C     UPDATED         --MAY       1977.
C     UPDATED         --DECEMBER  1981.
C     UPDATED         --MAY       1982.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX,PI,ANU1,ANU2,Z,SUM,TERM,AI,COEF1,COEF2,ARG
      DOUBLE PRECISION COEF
      DOUBLE PRECISION THETA,SINTH,COSTH,A,B
      DOUBLE PRECISION DSQRT,DATAN
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----DATA STATEMENTS-------------------------------------------------
C
      DATA PI/3.14159265358979D0/
C
C-----START POINT-----------------------------------------------------
C
      B=0.0
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      AN=N
      IF(P.LT.0.0.OR.P.GT.1.0)GOTO50
      IF(N.LT.1)GOTO55
      IF(X.LT.0.0.OR.X.GT.AN)GOTO60
      INTX=X+0.0001
      FINTX=INTX
      DEL=X-FINTX
      IF(DEL.LT.0.0)DEL=-DEL
      IF(DEL.GT.0.001)GOTO65
      GOTO90
   50 WRITE(ICOUT,11)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)P
      CALL DPWRST('XXX','BUG ')
      CDF=0.0
      RETURN
   55 WRITE(ICOUT,25)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,47)N
      CALL DPWRST('XXX','BUG ')
      CDF=0.0
      RETURN
   60 WRITE(ICOUT,4)N
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)X
      CALL DPWRST('XXX','BUG ')
      IF(X.LT.0.0)CDF=0.0
      IF(X.GT.AN)CDF=1.0
      RETURN
   65 WRITE(ICOUT,5)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)X
      CALL DPWRST('XXX','BUG ')
   90 CONTINUE
    4 FORMAT('***** NON-FATAL DIAGNOSTIC--THE 1ST INPUT ',
     1'ARGUMENT TO THE BINCDF SUBROUTINE IS OUTSIDE THE USUAL ',
     1'(0,N) = (0,',I8,') INTERVAL')
    5 FORMAT('***** NON-FATAL DIAGNOSTIC--THE 1ST INPUT ',
     1'ARGUMENT TO THE BINCDF SUBROUTINE IS NON-INTEGRAL *****')
   11 FORMAT('***** FATAL ERROR--THE 2ND INPUT ARGUMENT TO THE ',
     1' BINCDF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL')
   25 FORMAT('***** FATAL ERROR--THE 3RD INPUT ARGUMENT TO THE ',
     1' BINCDF SUBROUTINE IS NON-POSITIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
C
C     TREAT IMMEDIATELY THE SPECIAL CASE OF X = N,
C     IN WHICH CASE CDF = 1.0.
C     ALSO TREAT IMMEDIATELY THE SPECIAL CASE OF P = 0.0
C     IN WHICH CASE CDF = 1.0 FOR ALL X.
C     THIRDLY, TREAT THE SPECIAL CASE IN WHICH P = 1.0
C     IN WHICH CASE CDF = 0.0 FOR ALL X SMALLER THAN N
C     AND CDF = 1.0 FOR ALL X EQUAL TO OR LARGER
C     THAN N.
C
      INTX=X+0.0001
      CDF=1.0
      IF(INTX.EQ.N)RETURN
      IF(P.EQ.0.0)RETURN
      IF(P.EQ.1.0.AND.INTX.GE.N)RETURN
      IF(P.EQ.1.0.AND.INTX.LT.N)CDF=0.0
      IF(P.EQ.1.0.AND.INTX.LT.N)RETURN
C
C     EXPRESS THE BINOMIAL CUMULATIVE DISTRIBUTION
C     FUNCTION IN TERMS OF THE EQUIVALENT F
C     CUMULATIVE DISTRIBUTION FUNCTION,
C     AND THEN EVALUATE THE LATTER.
C
      AN=N
      DX=(P/(1.0-P))*((AN-X)/(X+1.0))
      NU1=2.0*(X+1.0)+0.1
      NU2=2.0*(AN-X)+0.1
      ANU1=NU1
      ANU2=NU2
      Z=ANU2/(ANU2+ANU1*DX)
C
C     DETERMINE IF NU1 AND NU2 ARE EVEN OR ODD
C
      IFLAG1=NU1-2*(NU1/2)
      IFLAG2=NU2-2*(NU2/2)
      IF(IFLAG1.EQ.0)GOTO120
      IF(IFLAG2.EQ.0)GOTO150
      GOTO250
C
C     DO THE NU1 EVEN AND NU2 EVEN OR ODD CASE
C
  120 SUM=0.0D0
      TERM=1.0D0
      IMAX=(NU1-2)/2
      IF(IMAX.LE.0)GOTO110
      DO100I=1,IMAX
      AI=I
      COEF1=2.0D0*(AI-1.0D0)
      COEF2=2.0D0*AI
      TERM=TERM*((ANU2+COEF1)/COEF2)*(1.0D0-Z)
      SUM=SUM+TERM
  100 CONTINUE
C
  110 SUM=SUM+1.0D0
      SUM=(Z**(ANU2/2.0D0))*SUM
      CDF=SUM
      RETURN
C
C     DO THE NU1 ODD AND NU2 EVEN CASE
C
  150 SUM=0.0D0
      TERM=1.0D0
      IMAX=(NU2-2)/2
      IF(IMAX.LE.0)GOTO210
      DO200I=1,IMAX
      AI=I
      COEF1=2.0D0*(AI-1.0D0)
      COEF2=2.0D0*AI
      TERM=TERM*((ANU1+COEF1)/COEF2)*Z
      SUM=SUM+TERM
  200 CONTINUE
C
  210 SUM=SUM+1.0D0
      CDF=1.0D0-((1.0D0-Z)**(ANU1/2.0D0))*SUM
      RETURN
C
C     DO THE NU1 ODD AND NU2 ODD CASE
C
  250 SUM=0.0D0
      TERM=1.0D0
      ARG=DSQRT((ANU1/ANU2)*DX)
      THETA=DATAN(ARG)
      SINTH=ARG/DSQRT(1.0D0+ARG*ARG)
      COSTH=1.0D0/DSQRT(1.0D0+ARG*ARG)
      IF(NU2.EQ.1)GOTO320
      IF(NU2.EQ.3)GOTO310
      IMAX=NU2-2
      DO300I=3,IMAX,2
      AI=I
      COEF1=AI-1.0D0
      COEF2=AI
      TERM=TERM*(COEF1/COEF2)*(COSTH*COSTH)
      SUM=SUM+TERM
  300 CONTINUE
C
  310 SUM=SUM+1.0D0
      SUM=SUM*SINTH*COSTH
C
  320 A=(2.0D0/PI)*(THETA+SUM)
      SUM=0.0D0
      TERM=1.0D0
      IF(NU1.EQ.1)B=0.0D0
      IF(NU1.EQ.1)GOTO450
      IF(NU1.EQ.3)GOTO410
      IMAX=NU1-3
      DO400I=1,IMAX,2
      AI=I
      COEF1=AI
      COEF2=AI+2.0D0
      TERM=TERM*((ANU2+COEF1)/COEF2)*(SINTH*SINTH)
      SUM=SUM+TERM
  400 CONTINUE
C
  410 SUM=SUM+1.0D0
      SUM=SUM*SINTH*(COSTH**N)
      COEF=1.0D0
      IEVODD=NU2-2*(NU2/2)
      IMIN=3
      IF(IEVODD.EQ.0)IMIN=2
      IF(IMIN.GT.NU2)GOTO420
      DO430I=IMIN,NU2,2
      AI=I
      COEF=((AI-1.0D0)/AI)*COEF
  430 CONTINUE
C
  420 COEF=COEF*ANU2
      IF(IEVODD.EQ.0)GOTO440
      COEF=COEF*(2.0D0/PI)
C
  440 B=COEF*SUM
C
  450 CDF=1.0D0-(A-B)
      RETURN
C
      END
      REAL FUNCTION BINFUN(P)
C
C     PURPOSE--DPMLBI CALLS FZERO TO FIND A ROOT FOR ONE OF
C              THE FOLLOWING FUNCTIONS:
C
C                 BINCDF(X;P,N) - (1 - ALPHA/2) = 0
C                 BINCDF(X;P,N) - (ALPHA/2)     = 0
C
C              WITH X, P, N, AND ALPHA DENOTING THE NUMBER OF
C              SUCCESSES, THE PROBABILITY OF SUCCESS PARAMETER,
C              THE NUMBER OF TRIALS, AND DESIRED SIGNIFICANCE
C              LEVEL RESPECTIVELY.  DPMLBI IS TRYING TO DETERMINE
C              AN EXACT CONFIDENCE INTERVAL FOR P.  THE VALUES
C              FOR X, N, AND (1 - ALPHA/2) (OR ALPHA/2) ARE PASSED
C              IN VIA A COMMON BLOCK.
C
C     INPUT  ARGUMENTS--P      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C     OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE BINFUN.
C     PRINTING--NONE.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--BINCDF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--KARL BURY (1999). "STATISTICAL DISTRIBUTIONS IN
C                 ENGINEERING", CAMBRIDGE UNIVERSITY PRESS, P. 74.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2005.8
C     ORIGINAL VERSION--AUGUST    2005.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      COMMON/BINCOM/N,X,CONST
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      CALL BINCDF(X,P,N,CDF)
      BINFUN=CDF - CONST
C
 9999 CONTINUE
      RETURN
      END
      FUNCTION BINOM(N,M)
C***BEGIN PROLOGUE  BINOM
C***DATE WRITTEN   770701   (YYMMDD)
C***REVISION DATE  820801   (YYMMDD)
C***CATEGORY NO.  C1
C***KEYWORDS  BINOMIAL COEFFICIENTS,SPECIAL FUNCTION
C***AUTHOR  FULLERTON, W., (LANL)
C***PURPOSE  Computes the binomial coefficients.
C***DESCRIPTION
C
C BINOM(N,M) calculates the binomial coefficient (N!)/((M!)*(N-M)!).
C***REFERENCES  (NONE)
C***ROUTINES CALLED  ALNREL,R1MACH,R9LGMC,XERROR
C***END PROLOGUE  BINOM
      DOUBLE PRECISION D9LGMC
      INCLUDE 'DPCOMC.INC'
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DATA SQ2PIL / 0.9189385332 0467274E0 /
      DATA BILNMX, FINTMX / 0.0, 0.0 /
C***FIRST EXECUTABLE STATEMENT  BINOM
      IF (BILNMX.NE.0.0) GO TO 10
      BILNMX = ALOG (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)*ALOG(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*ALOG(XNK/XK) - XN*ALNREL(-(XK-1.)/XN)
     1  - 0.5*ALOG(XN*XNK/XK) + 1.0 - SQ2PIL + CORR
C
      IF (BINOM.GT.BILNMX) THEN
C
        WRITE(ICOUT,41)
 41     FORMAT('***** ERROR: BINOM OVERFLOWS BECAUSE ONE (OR BOTH) OF ',
     1         'THE ARGUMENTS IS TOO LARGE.')
        CALL DPWRST('XXX','BUG')
        GOTO9000
      ENDIF
      BINOM = EXP (BINOM)
      IF (BINOM.LT.FINTMX) BINOM = AINT (BINOM+0.5)
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE BINPPF(P,PPAR,N,PPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE AT THE SINGLE PRECISION VALUE P
C              FOR THE BINOMIAL DISTRIBUTION
C              WITH SINGLE PRECISION 'BERNOULLI PROBABILITY'
C              PARAMETER = PPAR,
C              AND INTEGER 'NUMBER OF BERNOULLI TRIALS'
C              PARAMETER = N.
C              THE BINOMIAL DISTRIBUTION USED
C              HEREIN HAS MEAN = N*PPAR
C              AND STANDARD DEVIATION = SQRT(N*PPAR*(1-PPAR)).
C              THIS DISTRIBUTION IS DEFINED FOR ALL
C              DISCRETE INTEGER X BETWEEN 0 (INCLUSIVELY)
C              AND N (INCLUSIVELY).
C              THIS DISTRIBUTION HAS THE PROBABILITY FUNCTION
C              F(X) = C(N,X) * PPAR**X * (1-PPAR)**(N-X).
C              WHERE C(N,X) IS THE COMBINATORIAL FUNCTION
C              EQUALING THE NUMBER OF COMBINATIONS OF N ITEMS
C              TAKEN X AT A TIME.
C              THE BINOMIAL DISTRIBUTION IS THE
C              DISTRIBUTION OF THE NUMBER OF
C              SUCCESSES IN N BERNOULLI (0,1)
C              TRIALS WHERE THE PROBABILITY OF SUCCESS
C              IN A SINGLE TRIAL = PPAR.
C              NOTE THAT THE PERCENT POINT FUNCTION OF A DISTRIBUTION
C              IS IDENTICALLY THE SAME AS THE INVERSE CUMULATIVE
C              DISTRIBUTION FUNCTION OF THE DISTRIBUTION.
C     INPUT  ARGUMENTS--P      = THE SINGLE PRECISION VALUE
C                                (BETWEEN 0.0 (INCLUSIVELY)
C                                AND 1.0 (INCLUSIVELY))
C                                AT WHICH THE PERCENT POINT
C                                FUNCTION IS TO BE EVALUATED.
C                     --PPAR   = THE SINGLE PRECISION VALUE
C                                OF THE 'BERNOULLI PROBABILITY'
C                                PARAMETER FOR THE BINOMIAL
C                                DISTRIBUTION.
C                                PPAR SHOULD BE BETWEEN
C                                0.0 (EXCLUSIVELY) AND
C                                1.0 (EXCLUSIVELY).
C                     --N      = THE INTEGER VALUE
C                                OF THE 'NUMBER OF BERNOULLI TRIALS'
C                                PARAMETER.
C                                N SHOULD BE A POSITIVE INTEGER.
C     OUTPUT ARGUMENTS--PPF    = THE SINGLE PRECISION PERCENT
C                                POINT FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PERCENT POINT  .
C             FUNCTION VALUE PPF
C             FOR THE BINOMIAL DISTRIBUTION
C             WITH 'BERNOULLI PROBABILITY' PARAMETER = PPAR
C             AND 'NUMBER OF BERNOULLI TRIALS' PARAMETER = N.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--PPAR SHOULD BE BETWEEN 0.0 (EXCLUSIVELY)
C                   AND 1.0 (EXCLUSIVELY).
C                 --N SHOULD BE A POSITIVE INTEGER.
C                 --P SHOULD BE BETWEEN 0.0 (INCLUSIVELY)
C                   AND 1.0 (INCLUSIVELY).
C     OTHER DATAPAC   SUBROUTINES NEEDED--NORPPF, BINCDF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--SQRT.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION AND DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     COMMENT--NOTE THAT EVEN THOUGH THE OUTPUT
C              FROM THIS DISCRETE DISTRIBUTION
C              PERCENT POINT FUNCTION
C              SUBROUTINE MUST NECESSARILY BE A
C              DISCRETE INTEGER VALUE,
C              THE OUTPUT VARIABLE PPF IS SINGLE
C              PRECISION IN MODE.
C              PPF HAS BEEN SPECIFIED AS SINGLE
C              PRECISION SO AS TO CONFORM WITH THE DATAPAC
C              CONVENTION THAT ALL OUTPUT VARIABLES FROM ALL
C              DATAPAC SUBROUTINES ARE SINGLE PRECISION.
C              THIS CONVENTION IS BASED ON THE BELIEF THAT
C              1) A MIXTURE OF MODES (FLOATING POINT
C              VERSUS INTEGER) IS INCONSISTENT AND
C              AN UNNECESSARY COMPLICATION
C              IN A DATA ANALYSIS; AND
C              2) FLOATING POINT MACHINE ARITHMETIC
C              (AS OPPOSED TO INTEGER ARITHMETIC)
C              IS THE MORE NATURAL MODE FOR DOING
C              DATA ANALYSIS.
C     REFERENCES--JOHNSON AND KOTZ, DISCRETE
C                 DISTRIBUTIONS, 1969, PAGES 50-86,
C                 ESPECIALLY PAGE 64, FORMULA 36.
C               --HASTINGS AND PEACOCK, STATISTICAL
C                 DISTRIBUTIONS--A HANDBOOK FOR
C                 STUDENTS AND PRACTITIONERS, 1975,
C                 PAGES 36-41.
C               --NATIONAL BUREAU OF STANDARDS APPLIED MATHEMATICS
C                 SERIES 55, 1964, PAGE 929.
C               --FELLER, AN INTRODUCTION TO PROBABILITY
C                 THEORY AND ITS APPLICATIONS, VOLUME 1,
C                 EDITION 2, 1957, PAGES 135-142.
C               --KENDALL AND STUART, THE ADVANCED THEORY OF
C                 STATISTICS, VOLUME 1, EDITION 2, 1963, PAGES 120-125.
C               --MOOD AND GRABLE, INTRODUCTION TO THE THEORY
C                 OF STATISTICS, EDITION 2, 1963, PAGES 64-69.
C               --OWEN, HANDBOOK OF STATISTICAL
C                 TABLES, 1962, PAGES 264-272.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--82/7
C     ORIGINAL VERSION--NOVEMBER  1975.
C     UPDATED         --OCTOBER   1978.
C     UPDATED         --DECEMBER  1981.
C     UPDATED         --MAY       1982.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DPPAR
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(P.LT.0.0.OR.P.GT.1.0)GOTO50
      IF(PPAR.LE.0.0.OR.PPAR.GE.1.0)GOTO55
      IF(N.LT.1)GOTO60
      GOTO90
   50 WRITE(ICOUT,1)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)P
      CALL DPWRST('XXX','BUG ')
      PPF=0.0
      RETURN
   55 WRITE(ICOUT,11)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)PPAR
      CALL DPWRST('XXX','BUG ')
      PPF=0.0
      RETURN
   60 WRITE(ICOUT,25)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,47)N
      CALL DPWRST('XXX','BUG ')
      PPF=0.0
      RETURN
   90 CONTINUE
    1 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ',
     1' BINPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL')
   11 FORMAT('***** FATAL ERROR--THE 2ND INPUT ARGUMENT TO THE ',
     1' BINPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL')
   25 FORMAT('***** FATAL ERROR--THE 3RD INPUT ARGUMENT TO THE ',
     1' BINPPF SUBROUTINE IS NON-POSITIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
C
      AN=N
      DPPAR=PPAR
      PPF=0.0
      IX0=0
      IX1=0
      IX2=0
      P0=0.0
      P1=0.0
      P2=0.0
C
C     TREAT CERTAIN SPECIAL CASES IMMEDIATELY--
C     1) P = 0.0 OR 1.0
C     2) P = 0.5 AND PPAR = 0.5
C     3) PPF = 0 OR N
C
      IF(P.EQ.0.0)GOTO110
      IF(P.EQ.1.0)GOTO120
      IF(P.EQ.0.5.AND.PPAR.EQ.0.5)GOTO130
      PF0=(1.0D0-DPPAR)**N
      QFN=1.0D0-(DPPAR**N)
      IF(P.LE.PF0)GOTO110
      IF(P.GT.QFN)GOTO120
      GOTO190
  110 PPF=0.0
      RETURN
  120 PPF=N
      RETURN
  130 PPF=N/2
      RETURN
  190 CONTINUE
C
C     DETERMINE AN INITIAL APPROXIMATION TO THE BINOMIAL
C     PERCENT POINT BY USE OF THE NORMAL APPROXIMATION
C     TO THE BINOMIAL.
C     (SEE JOHNSON AND KOTZ, DISCRETE DISTRIBUTIONS,
C     PAGE 64, FORMULA 36).
C
      AMEAN=AN*PPAR
      SD=SQRT(AN*PPAR*(1.0-PPAR))
      CALL NORPPF(P,ZPPF)
      X2=AMEAN-0.5+ZPPF*SD
      IX2=X2
C
C     CHECK AND MODIFY (IF NECESSARY) THIS INITIAL
C     ESTIMATE OF THE PERCENT POINT
C     TO ASSURE THAT IT BE IN THE CLOSED INTERVAL 0 TO N.
C
      IF(IX2.LT.0)IX2=0
      IF(IX2.GT.N)IX2=N
C
C     DETERMINE UPPER AND LOWER BOUNDS ON THE DESIRED
C     PERCENT POINT BY ITERATING OUT (BOTH BELOW AND ABOVE)
C     FROM THE ORIGINAL APPROXIMATION AT STEPS
C     OF 1 STANDARD DEVIATION.
C     THE RESULTING BOUNDS WILL BE AT MOST
C     1 STANDARD DEVIATION APART.
C
      IX0=0
      IX1=N
      ISD=SD+1.0
      X2=IX2
      CALL BINCDF(X2,PPAR,N,P2)
C
      IF(P2.LT.P)GOTO210
      GOTO250
C
  210 CONTINUE
      IX0=IX2
      I=1
  215 CONTINUE
      IX2=IX0+ISD
      IF(IX2.GE.IX1)GOTO275
      X2=IX2
      CALL BINCDF(X2,PPAR,N,P2)
      IF(P2.GE.P)GOTO230
      IX0=IX2
  220 CONTINUE
      I=I+1
      IF(I.LE.1000000)GOTO215
      WRITE(ICOUT,249)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,222)
      CALL DPWRST('XXX','BUG ')
      GOTO950
  230 IX1=IX2
      GOTO275
C
  250 CONTINUE
      IX1=IX2
      I=1
  255 CONTINUE
      IX2=IX1-ISD
      IF(IX2.LE.IX0)GOTO275
      X2=IX2
      CALL BINCDF(X2,PPAR,N,P2)
      IF(P2.LT.P)GOTO270
      IX1=IX2
  260 CONTINUE
      I=I+1
      IF(I.LE.1000000)GOTO255
      WRITE(ICOUT,249)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,262)
      CALL DPWRST('XXX','BUG ')
      GOTO950
  270 IX0=IX2
C
  275 IF(IX0.EQ.IX1)GOTO280
      GOTO295
  280 IF(IX0.EQ.0)GOTO285
      IF(IX0.EQ.N)GOTO290
      WRITE(ICOUT,249)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,282)
      CALL DPWRST('XXX','BUG ')
      GOTO950
  285 IX1=IX1+1
      GOTO295
  290 IX0=IX0-1
  295 CONTINUE
C
C     COMPUTE BINOMIAL PROBABILITIES FOR THE
C     DERIVED LOWER AND UPPER BOUNDS.
C
      X0=IX0
      X1=IX1
      CALL BINCDF(X0,PPAR,N,P0)
      CALL BINCDF(X1,PPAR,N,P1)
C
C     CHECK THE PROBABILITIES FOR PROPER ORDERING
C
      IF(P0.LT.P.AND.P.LE.P1)GOTO490
      IF(P0.EQ.P)GOTO410
      IF(P1.EQ.P)GOTO420
      IF(P0.GT.P1)GOTO430
      IF(P0.GT.P)GOTO440
      IF(P1.LT.P)GOTO450
      WRITE(ICOUT,249)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,401)
      CALL DPWRST('XXX','BUG ')
      GOTO950
  410 PPF=IX0
      RETURN
  420 PPF=IX1
      RETURN
  430 WRITE(ICOUT,249)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,431)
      CALL DPWRST('XXX','BUG ')
      GOTO950
  440 WRITE(ICOUT,249)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,441)
      CALL DPWRST('XXX','BUG ')
      GOTO950
  450 WRITE(ICOUT,249)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,451)
      CALL DPWRST('XXX','BUG ')
      GOTO950
  490 CONTINUE
C
C     THE STOPPING CRITERION IS THAT THE LOWER BOUND
C     AND UPPER BOUND ARE EXACTLY 1 UNIT APART.
C     CHECK TO SEE IF IX1 = IX0 + 1;
C     IF SO, THE ITERATIONS ARE COMPLETE;
C     IF NOT, THEN BISECT, COMPUTE PROBABILIIES,
C     CHECK PROBABILITIES, AND CONTINUE ITERATING
C     UNTIL IX1 = IX0 + 1.
C
  300 IX0P1=IX0+1
      IF(IX1.EQ.IX0P1)GOTO690
      IX2=(IX0+IX1)/2
      IF(IX2.EQ.IX0)GOTO610
      IF(IX2.EQ.IX1)GOTO620
      X2=IX2
      CALL BINCDF(X2,PPAR,N,P2)
      IF(P0.LT.P2.AND.P2.LT.P1)GOTO630
      IF(P2.LE.P0)GOTO640
      IF(P2.GE.P1)GOTO650
  610 WRITE(ICOUT,249)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,611)
      CALL DPWRST('XXX','BUG ')
      GOTO950
  620 WRITE(ICOUT,249)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,611)
      CALL DPWRST('XXX','BUG ')
      GOTO950
  630 IF(P2.LE.P)GOTO635
      IX1=IX2
      P1=P2
      GOTO300
  635 IX0=IX2
      P0=P2
      GOTO300
  640 WRITE(ICOUT,249)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,641)
      CALL DPWRST('XXX','BUG ')
      GOTO950
  650 WRITE(ICOUT,249)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,651)
      CALL DPWRST('XXX','BUG ')
      GOTO950
  690 PPF=IX1
      IF(P0.EQ.P)PPF=IX0
      RETURN
C
  950 WRITE(ICOUT,240)IX0,P0
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,241)IX1,P1
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,242)IX2,P2
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,244)P
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,245)PPAR,N
      CALL DPWRST('XXX','BUG ')
      RETURN
C
  222 FORMAT(43HNO UPPER BOUND FOUND AFTER 10**7 ITERATIONS)
  240 FORMAT(7HIX0  = ,I8,10X,5HP0 = ,F14.7)
  241 FORMAT(7HIX1  = ,I8,10X,5HP1 = ,F14.7)
  242 FORMAT(7HIX2  = ,I8,10X,5HP2 = ,F14.7)
  244 FORMAT(7HP    = ,F14.7)
  245 FORMAT(7HPPAR = ,F14.7,10X,5HN  = ,I8)
  249 FORMAT('***** INTERNAL ERROR IN BINPPF SUBROUTINE *****')
  262 FORMAT(43HNO LOWER BOUND FOUND AFTER 10**7 ITERATIONS)
  282 FORMAT(31HLOWER AND UPPER BOUND IDENTICAL)
  401 FORMAT(39HIMPOSSIBLE BRANCH CONDITION ENCOUNTERED)
  431 FORMAT(42HLOWER BOUND PROBABILITY (P0) GREATER THAN ,
     1 28HUPPER BOUND PROBABILITY (P1))
  441 FORMAT(42HLOWER BOUND PROBABILITY (P0) GREATER THAN ,
     1 21HINPUT PROBABILITY (P))
  451 FORMAT(42HUPPER BOUND PROBABILITY (P1) LESS    THAN ,
     1 21HINPUT PROBABILITY (P))
  611 FORMAT(39HBISECTION VALUE (X2) = LOWER BOUND (X0))
  621 FORMAT(39HBISECTION VALUE (X2) = UPPER BOUND (X1))
  641 FORMAT(33HBISECTION VALUE PROBABILITY (P2) ,
     1 38HLESS THAN LOWER BOUND PROBABILITY (P0))
  651 FORMAT(33HBISECTION VALUE PROBABILITY (P2) ,
     1 41HGREATER THAN UPPER BOUND PROBABILITY (P1))
C
      END
      SUBROUTINE BINRAN(N,P,NPAR,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE BINOMIAL DISTRIBUTION
C              WITH SINGLE PRECISION 'BERNOULLI PROBABILITY'
C              PARAMETER = P,
C              AND INTEGER 'NUMBER OF BERNOULLI TRIALS'
C              PARAMETER = NPAR.
C              THE BINOMIAL DISTRIBUTION USED
C              HEREIN HAS MEAN = NPAR*P
C              AND STANDARD DEVIATION = SQRT(NPAR*P*(1-P)).
C              THIS DISTRIBUTION IS DEFINED FOR ALL
C              DISCRETE INTEGER X BETWEEN 0 (INCLUSIVELY)
C              AND NPAR (INCLUSIVELY).
C              THIS DISTRIBUTION HAS THE PROBABILITY FUNCTION
C              F(X) = C(NPAR,X) * P**X * (1-P)**(NPAR-X).
C              WHERE C(NPAR,X) IS THE COMBINATORIAL FUNCTION
C              EQUALING THE NUMBER OF COMBINATIONS OF NPAR ITEMS
C              TAKEN X AT A TIME.
C              THE BINOMIAL DISTRIBUTION IS THE
C              DISTRIBUTION OF THE NUMBER OF
C              SUCCESSES IN NPAR BERNOULLI (0,1)
C              TRIALS WHERE THE PROBABILITY OF SUCCESS
C              IN A SINGLE TRIAL = P.
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --P      = THE SINGLE PRECISION VALUE
C                                OF THE 'BERNOULLI PROBABILITY'
C                                PARAMETER FOR THE BINOMIAL
C                                DISTRIBUTION.
C                                P SHOULD BE BETWEEN
C                                0.0 (EXCLUSIVELY) AND
C                                1.0 (EXCLUSIVELY).
C                     --NPAR   = THE INTEGER VALUE
C                                OF THE 'NUMBER OF BERNOULLI TRIALS'
C                                PARAMETER.
C                                NPAR SHOULD BE A POSITIVE INTEGER.
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST N)
C                                INTO WHICH THE GENERATED
C                                RANDOM SAMPLE WILL BE PLACED.
C     OUTPUT--A RANDOM SAMPLE OF SIZE N
C             FROM THE BINOMIAL DISTRIBUTION
C             WITH 'BERNOULLI PROBABILITY' PARAMETER = P
C             AND 'NUMBER OF BERNOULLI TRIALS' PARAMETER = NPAR.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C                 --P SHOULD BE BETWEEN 0.0 (EXCLUSIVELY)
C                   AND 1.0 (EXCLUSIVELY).
C                 --NPAR SHOULD BE A POSITIVE INTEGER.
C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN, GEORAN.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     COMMENT--NOTE THAT EVEN THOUGH THE OUTPUT
C              FROM THIS DISCRETE RANDOM NUMBER
C              GENERATOR MUST NECESSARILY BE A
C              SEQUENCE OF ***INTEGER*** VALUES,
C              THE OUTPUT VECTOR X IS SINGLE
C              PRECISION IN MODE.
C              X HAS BEEN SPECIFIED AS SINGLE
C              PRECISION SO AS TO CONFORM WITH THE DATAPAC
C              CONVENTION THAT ALL OUTPUT VECTORS FROM ALL
C              DATAPAC SUBROUTINES ARE SINGLE PRECISION.
C              THIS CONVENTION IS BASED ON THE BELIEF THAT
C              1) A MIXTURE OF MODES (FLOATING POINT
C              VERSUS INTEGER) IS INCONSISTENT AND
C              AN UNNECESSARY COMPLICATION
C              IN A DATA ANALYSIS; AND
C              2) FLOATING POINT MACHINE ARITHMETIC
C              (AS OPPOSED TO INTEGER ARITHMETIC)
C              IS THE MORE NATURAL MODE FOR DOING
C              DATA ANALYSIS.
C     REFERENCES--JOHNSON AND KOTZ, DISCRETE
C                 DISTRIBUTIONS, 1969, PAGES 50-86.
C               --HASTINGS AND PEACOCK, STATISTICAL
C                 DISTRIBUTIONS--A HANDBOOK FOR
C                 STUDENTS AND PRACTITIONERS, 1975,
C                 PAGE 41.
C               --FELLER, AN INTRODUCTION TO PROBABILITY
C                 THEORY AND ITS APPLICATIONS, VOLUME 1,
C                 EDITION 2, 1957, PAGES 135-142.
C               --NATIONAL BUREAU OF STANDARDS APPLIED MATHEMATICS
C                 SERIES 55, 1964, PAGE 929.
C               --KENDALL AND STUART, THE ADVANCED THEORY OF
C                 STATISTICS, VOLUME 1, EDITION 2, 1963, PAGES 120-125.
C               --MOOD AND GRABLE, INTRODUCTION TO THE THEORY
C                 OF STATISTICS, EDITION 2, 1963, PAGES 64-69.
C               --TOCHER, THE ART OF SIMULATION,
C                 1963, PAGES 39-40.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--82/7
C     ORIGINAL VERSION--NOVEMBER  1975.
C     UPDATED         --DECEMBER  1981.
C     UPDATED         --MAY       1982.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
C
      DIMENSION U(2)
      DIMENSION G(2)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)GOTO50
      IF(P.LE.0.0.OR.P.GE.1.0)GOTO55
      IF(NPAR.LT.1)GOTO60
      GOTO90
   50 WRITE(ICOUT, 5)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,47)N
      CALL DPWRST('XXX','BUG ')
      RETURN
   55 WRITE(ICOUT,11)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)P
      CALL DPWRST('XXX','BUG ')
      RETURN
   60 WRITE(ICOUT,25)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,47)NPAR
      CALL DPWRST('XXX','BUG ')
      RETURN
   90 CONTINUE
    5 FORMAT('***** FATAL ERROR--THE FIRST  INPUT ARGUMENT TO THE ',
     1' BINRAN SUBROUTINE IS NON-POSITIVE *****')
   11 FORMAT('***** FATAL ERROR--THE 2ND INPUT ARGUMENT TO THE ',
     1' BINRAN SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL')
   25 FORMAT('***** FATAL ERROR--THE 3RD INPUT ARGUMENT TO THE ',
     1' BINRAN SUBROUTINE IS NON-POSITIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
C
C     CHECK ON THE MAGNITUDE OF P,
C     AND BRANCH TO THE FASTER
C     GENERATION METHOD ACCORDINGLY.
C
      IF(P.LT.0.1)GOTO450
C
C     IF P IS MODERATE OR LARGE,
C     GENERATE N BINOMIAL RANDOM NUMBERS
C     USING THE REJECTION METHOD.
C
      DO100I=1,N
      ISUM=0
      DO200J=1,NPAR
      CALL UNIRAN(1,ISEED,U)
      IF(U(1).LE.P)ISUM=ISUM+1
  200 CONTINUE
      X(I)=ISUM
  100 CONTINUE
      RETURN
C
C     IF P IS SMALL,
C     GENERATE N BINOMIAL NUMBERS
C     USING THE FACT THAT THE
C     WAITING TIME FOR 1 SUCCESS IN
C     BERNOULLI TRIALS HAS A
C     GEOMETRIC DISTRIBUTION.
C
  450 DO500I=1,N
      ISUM=0
      J=1
  550 CALL GEORAN(1,P,ISEED,G)
      IG=G(1)+0.5
      ISUM=ISUM+IG+1
      IF(ISUM.GT.NPAR)GOTO650
      J=J+1
      GOTO550
  650 X(I)=J-1
  500 CONTINUE
      RETURN
C
      END
      SUBROUTINE BINTK(X,Y,T,N,K,BCOEF,Q,WORK)
C***BEGIN PROLOGUE  BINTK
C***DATE WRITTEN   800901   (YYMMDD)
C***REVISION DATE  820801   (YYMMDD)
C***CATEGORY NO.  E1A
C***KEYWORDS  B-SPLINE,DATA FITTING,INTERPOLATION,SPLINE
C***AUTHOR  AMOS, D. E., (SNLA)
C***PURPOSE  Produces the B-spline coefficients, BCOEF, of the
C            B-spline of order K with knots T(I), I=1,...,N+K, which
C            takes on the value Y(I) at X(I), I=1,...,N.
C***DESCRIPTION
C
C     Written by Carl de Boor and modified by D. E. Amos
C
C     References
C
C          A Practical Guide to Splines by C. de Boor, Applied
C          Mathematics Series 27, Springer, 1979.
C
C     Abstract
C
C         BINTK is the SPLINT routine of the reference.
C
C         BINTK produces the B-spline coefficients, BCOEF, of the
C         B-spline of order K with knots T(I), I=1,...,N+K, which
C         takes on the value Y(I) at X(I), I=1,...,N.  The spline or
C         any of its derivatives can be evaluated by calls to BVALU.
C         The I-th equation of the linear system A*BCOEF = B for the
C         coefficients of the interpolant enforces interpolation at
C         X(I)), I=1,...,N.  Hence, B(I) = Y(I), all I, and A is
C         a band matrix with 2K-1 bands if A is invertible. The matrix
C         A is generated row by row and stored, diagonal by diagonal,
C         in the rows of Q, with the main diagonal going into row K.
C         The banded system is then solved by a call to BNFAC (which
C         constructs the triangular factorization for A and stores it
C         again in Q), followed by a call to BNSLV (which then
C         obtains the solution BCOEF by substitution). BNFAC does no
C         pivoting, since the total positivity of the matrix A makes
C         this unnecessary.  The linear system to be solved is
C         (theoretically) invertible if and only if
C                 T(I) .LT. X(I)) .LT. T(I+K),        all I.
C         Equality is permitted on the left for I=1 and on the right
C         for I=N when K knots are used at X(1) or X(N).  Otherwise,
C         violation of this condition is certain to lead to an error.
C
C         BINTK calls BSPVN, BNFAC, BNSLV, XERROR
C
C     Description of Arguments
C         Input
C           X       - vector of length N containing data point abscissa
C                     in strictly increasing order.
C           Y       - corresponding vector of length N containing data
C                     point ordinates.
C           T       - knot vector of length N+K
C                     since T(1),..,T(K) .LE. X(1) and T(N+1),..,T(N+K)
C                     .GE. X(N), this leaves only N-K knots (not nec-
C                     essarily X(I)) values) interior to (X(1),X(N))
C           N       - number of data points, N .GE. K
C           K       - order of the spline, K .GE. 1
C
C         Output
C           BCOEF   - a vector of length N containing the B-spline
C                     coefficients
C           Q       - a work vector of length (2*K-1)*N, containing
C                     the triangular factorization of the coefficient
C                     matrix of the linear system being solved.  The
C                     coefficients for the interpolant of an
C                     additional data set (X(I)),YY(I)), I=1,...,N
C                     with the same abscissa can be obtained by loading
C                     YY into BCOEF and then executing
C                         call BNSLV(Q,2K-1,N,K-1,K-1,BCOEF)
C           WORK    - work vector of length 2*K
C
C     Error Conditions
C         Improper  input is a fatal error
C         Singular system of equations is a fatal error
C***REFERENCES  D.E. AMOS, *COMPUTATION WITH SPLINES AND B-SPLINES*,
C                 SAND78-1968,SANDIA LABORATORIES,MARCH,1979.
C               C. DE BOOR, *PACKAGE FOR CALCULATING WITH B-SPLINES*,
C                 SIAM JOURNAL ON NUMERICAL ANALYSIS, VOLUME 14, NO. 3,
C                 JUNE 1977, PP. 441-472.
C               C. DE BOOR, *A PRACTICAL GUIDE TO SPLINES*, APPLIED
C                 MATHEMATICS SERIES 27, SPRINGER, 1979.
C***ROUTINES CALLED  BNFAC,BNSLV,BSPVN,XERROR
C***END PROLOGUE  BINTK
C
C
      INTEGER IFLAG, IWORK, K, N, I, ILP1MX, J, JJ, KM1, KPKM2, LEFT,
     1 LENQ, NP1
      REAL BCOEF(N), Y(N), Q(1), T(1), X(N), XI, WORK(1)
C     DIMENSION Q(2*K-1,N), T(N+K)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C***FIRST EXECUTABLE STATEMENT  BINTK
      IF(K.LT.1) GO TO 100
      IF(N.LT.K) GO TO 105
      JJ = N - 1
      IF(JJ.EQ.0) GO TO 6
      DO 5 I=1,JJ
      IF(X(I).GE.X(I+1)) GO TO 110
    5 CONTINUE
    6 CONTINUE
      NP1 = N + 1
      KM1 = K - 1
      KPKM2 = 2*KM1
      LEFT = K
C                ZERO OUT ALL ENTRIES OF Q
      LENQ = N*(K+KM1)
      DO 10 I=1,LENQ
        Q(I) = 0.0E0
   10 CONTINUE
C
C  ***   LOOP OVER I TO CONSTRUCT THE  N  INTERPOLATION EQUATIONS
      DO 50 I=1,N
        XI = X(I)
        ILP1MX = MIN0(I+K,NP1)
C        *** FIND  LEFT  IN THE CLOSED INTERVAL (I,I+K-1) SUCH THAT
C                T(LEFT) .LE. X(I) .LT. T(LEFT+1)
C        MATRIX IS SINGULAR IF THIS IS NOT POSSIBLE
        LEFT = MAX0(LEFT,I)
        IF (XI.LT.T(LEFT)) GO TO 80
   20   IF (XI.LT.T(LEFT+1)) GO TO 30
        LEFT = LEFT + 1
        IF (LEFT.LT.ILP1MX) GO TO 20
        LEFT = LEFT - 1
        IF (XI.GT.T(LEFT+1)) GO TO 80
C        *** THE I-TH EQUATION ENFORCES INTERPOLATION AT XI, HENCE
C        A(I,J) = B(J,K,T)(XI), ALL J. ONLY THE  K  ENTRIES WITH  J =
C        LEFT-K+1,...,LEFT ACTUALLY MIGHT BE NONZERO. THESE  K  NUMBERS
C        ARE RETURNED, IN  BCOEF (USED FOR TEMP.STORAGE HERE), BY THE
C        FOLLOWING
   30   CALL BSPVN(T, K, K, 1, XI, LEFT, BCOEF, WORK, IWORK)
C        WE THEREFORE WANT  BCOEF(J) = B(LEFT-K+J)(XI) TO GO INTO
C        A(I,LEFT-K+J), I.E., INTO  Q(I-(LEFT+J)+2*K,(LEFT+J)-K) SINCE
C        A(I+J,J)  IS TO GO INTO  Q(I+K,J), ALL I,J,  IF WE CONSIDER  Q
C        AS A TWO-DIM. ARRAY , WITH  2*K-1  ROWS (SEE COMMENTS IN
C        BNFAC). IN THE PRESENT PROGRAM, WE TREAT  Q  AS AN EQUIVALENT
C        ONE-DIMENSIONAL ARRAY (BECAUSE OF FORTRAN RESTRICTIONS ON
C        DIMENSION STATEMENTS) . WE THEREFORE WANT  BCOEF(J) TO GO INTO
C        ENTRY
C            I -(LEFT+J) + 2*K + ((LEFT+J) - K-1)*(2*K-1)
C                   =  I-LEFT+1 + (LEFT -K)*(2*K-1) + (2*K-2)*J
C        OF  Q .
        JJ = I - LEFT + 1 + (LEFT-K)*(K+KM1)
        DO 40 J=1,K
          JJ = JJ + KPKM2
          Q(JJ) = BCOEF(J)
   40   CONTINUE
   50 CONTINUE
C
C     ***OBTAIN FACTORIZATION OF  A  , STORED AGAIN IN  Q.
      CALL BNFAC(Q, K+KM1, N, KM1, KM1, IFLAG)
      GO TO (60, 90), IFLAG
C     *** SOLVE  A*BCOEF = Y  BY BACKSUBSTITUTION
   60 DO 70 I=1,N
        BCOEF(I) = Y(I)
   70 CONTINUE
      CALL BNSLV(Q, K+KM1, N, KM1, KM1, BCOEF)
      RETURN
C
C
   80 CONTINUE
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,81)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,82)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,83)
      CALL DPWRST('XXX','BUG ')
   81 FORMAT('***** FROM BINTK,  SOME ABSCISSA WAS NOT IN THE SUPPORT')
   82 FORMAT('      OF THE CORRESPONDING BASIS FUNCTION AND THE')
   83 FORMAT('      SYSTEM IS SINGULAR.                         *****')
      RETURN
   90 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,91)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,92)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,93)
      CALL DPWRST('XXX','BUG ')
   91 FORMAT('***** FROM BINTK,  THE SYSTEM OF SOLVER DETECTS A')
   92 FORMAT('      SINGULAR SYSTEM ALTHOUGH THE THEORETICAL')
   93 FORMAT('      CONDITIONS FOR A SOLUTION WERE SATISFIED.  *****')
      RETURN
  100 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,101)
      CALL DPWRST('XXX','BUG ')
  101 FORMAT('***** FROM BINTK,  K DOES NOT SATISFY K.GE.1 *****')
      RETURN
  105 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,106)
      CALL DPWRST('XXX','BUG ')
  106 FORMAT('***** FROM BINTK,  N DOES NOT SATISFY N.GE.K *****')
      RETURN
  110 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,111)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,112)
      CALL DPWRST('XXX','BUG ')
  111 FORMAT('***** FROM BINTK, X(I) DOES NOT SATISFY ')
  112 FORMAT('      X(I).LT.X(I+1) FOR SOME I         *****')
      RETURN
      END
      DOUBLE PRECISION FUNCTION BIRINT(XVALUE)
C
C   DESCRIPTION:
C      This function calculates the integral of the Airy function Bi, defined
C
C          BIRINT(x) = integral{0 to x} Bi(t) dt
C
C      The program uses Chebyshev expansions, the coefficients of which
C      are given to 20 decimal places.
C
C
C   ERROR RETURNS:
C
C      If the function is too large and positive the correct
C      value would overflow. An error message is printed and the
C      program returns the value XMAX.
C
C      If the argument is too large and negative, it is impossible
C      to accurately compute the necessary SIN and COS functions,
C      for the asymptotic expansion.
C      An error message is printed, and the program returns the
C      value 0 (the value at -infinity).
C
C
C   MACHINE-DEPENDENT CONSTANTS:
C
C      NTERM1 - INTEGER - The no. of terms to be used from the array
C                          ABINT1. The recommended value is such that
C                             ABS(ABINT1(NTERM1)) < EPS/100,
C                          subject to 1 <= NTERM1 <= 36.
C
C      NTERM2 - INTEGER - The no. of terms to be used from the array
C                          ABINT2. The recommended value is such that
C                             ABS(ABINT2(NTERM2)) < EPS/100,
C                          subject to 1 <= NTERM2 <= 37.
C
C      NTERM3 - INTEGER - The no. of terms to be used from the array
C                          ABINT3. The recommended value is such that
C                             ABS(ABINT3(NTERM3)) < EPS/100,
C                          subject to 1 <= NTERM3 <= 37.
C 
C      NTERM4 - INTEGER - The no. of terms to be used from the array
C                          ABINT4. The recommended value is such that
C                             ABS(ABINT4(NTERM4)) < EPS/100,
C                          subject to 1 <= NTERM4 <= 20.
C
C      NTERM5 - INTEGER - The no. of terms to be used from the array
C                          ABINT5. The recommended value is such that
C                             ABS(ABINT5(NTERM5)) < EPS/100,
C                          subject to 1 <= NTERM5 <= 20.
C
C      XLOW1 - DOUBLE PRECISION - The value such that, if |x| < XLOW1,
C                          BIRINT(x) = x * Bi(0) 
C                     to machine precision. The recommended value is
C                          2 * EPSNEG.
C
C      XHIGH1 - DOUBLE PRECISION - The value such that, if x > XHIGH1,
C                      the function value would overflow.
C                      The recommended value is computed as
C                          z = ln(XMAX) + 0.5ln(ln(XMAX)),
C                          XHIGH1 = (3z/2)^(2/3)
C
C      XNEG1 - DOUBLE PRECISION - The value such that, if x < XNEG1,
C                     the trigonometric functions in the asymptotic
C                     expansion cannot be calculated accurately.
C                     The recommended value is
C                          -(1/((EPS)**2/3))
C
C      XMAX - DOUBLE PRECISION - The value of the largest positive floating-pt
C                    number. Used in giving a value to the function
C                    if x > XHIGH1.
C
C      For values of EPS, EPSNEG, and XMAX see the file MACHCON.TXT.
C
C
C     The machine-dependent constants are computed internally by
C     using the D1MACH subroutine.
C
C
C   INTRINSIC FUNCTIONS USED:
C                            COS, EXP, LOG, SIN, SQRT
C
C
C   OTHER MISCFUN SUBROUTINES USED:
C
C          CHEVAL , ERRPRN, D1MACH
C
C
C   AUTHOR: Dr. Allan J. MacLeod,
C           Dept. of Mathematics and Statistics,
C           Univ. of Paisley,
C           High St.,
C           Paisley,
C           SCOTLAND.
C           PA1 2BE
C 
C           (e-mail: macl_ms0@paisley.ac.uk )
C
C
C   LATEST REVISION:  23 January, 1996
C
      INTEGER NTERM1,NTERM2,NTERM3,NTERM4,NTERM5
      DOUBLE PRECISION ABINT1(0:36),ABINT2(0:37),ABINT3(0:37),
     1     ABINT4(0:20),ABINT5(0:20),
     2     ARG,BIRZER,CHEVAL,EIGHT,FOUR,F1,F2,NINE,NINHUN,
     3     ONE,ONEHUN,ONEPT5,PIBY4,RT2B3P,SIXTEN,SEVEN,T,TEMP,
     4     THREE,THR644,X,XLOW1,XHIGH1,XMAX,XNEG1,XVALUE,
     5     Z,ZERO
CCCCC CHARACTER FNNAME*6,ERMSG1*31,ERMSG2*31
CCCCC DATA FNNAME/'BIRINT'/
CCCCC DATA ERMSG1/'ARGUMENT TOO LARGE AND POSITIVE'/
CCCCC DATA ERMSG2/'ARGUMENT TOO LARGE AND NEGATIVE'/
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DATA ABINT1(0)/  0.38683 35244 50385 43350  D    0/
      DATA ABINT1(1)/ -0.88232 13550 88890 8821   D   -1/
      DATA ABINT1(2)/  0.21463 93744 03554 29239  D    0/
      DATA ABINT1(3)/ -0.42053 47375 89131 5126   D   -1/
      DATA ABINT1(4)/  0.59324 22547 49608 6771   D   -1/
      DATA ABINT1(5)/ -0.84078 70811 24270 210    D   -2/
      DATA ABINT1(6)/  0.87182 47727 78487 955    D   -2/
      DATA ABINT1(7)/ -0.12191 60019 96134 55     D   -3/
      DATA ABINT1(8)/  0.44024 82178 60232 34     D   -3/
      DATA ABINT1(9)/  0.27894 68666 63866 78     D   -3/
      DATA ABINT1(10)/-0.70528 04689 78553 7      D   -4/
      DATA ABINT1(11)/ 0.59010 80066 77010 0      D   -4/
      DATA ABINT1(12)/-0.13708 62587 98214 2      D   -4/
      DATA ABINT1(13)/ 0.50596 25737 49073        D   -5/
      DATA ABINT1(14)/-0.51598 83776 6735         D   -6/
      DATA ABINT1(15)/ 0.39751 13123 49           D   -8/
      DATA ABINT1(16)/ 0.95249 85978 055          D   -7/
      DATA ABINT1(17)/-0.36814 35887 321          D   -7/
      DATA ABINT1(18)/ 0.12483 91688 136          D   -7/
      DATA ABINT1(19)/-0.24909 76191 37           D   -8/
      DATA ABINT1(20)/ 0.31775 24555 1            D   -9/
      DATA ABINT1(21)/ 0.54343 65270              D  -10/
      DATA ABINT1(22)/-0.40245 66915              D  -10/
      DATA ABINT1(23)/ 0.13938 55527              D  -10/
      DATA ABINT1(24)/-0.30381 7509               D  -11/
      DATA ABINT1(25)/ 0.40809 511                D  -12/
      DATA ABINT1(26)/ 0.16341 16                 D  -13/
      DATA ABINT1(27)/-0.26838 09                 D  -13/
      DATA ABINT1(28)/ 0.89664 1                  D  -14/
      DATA ABINT1(29)/-0.18308 9                  D  -14/
      DATA ABINT1(30)/ 0.21333                    D  -15/
      DATA ABINT1(31)/ 0.1108                     D  -16/
      DATA ABINT1(32)/-0.1276                     D  -16/
      DATA ABINT1(33)/ 0.363                      D  -17/
      DATA ABINT1(34)/-0.62                       D  -18/
      DATA ABINT1(35)/ 0.5                        D  -19/
      DATA ABINT1(36)/ 0.1                        D  -19/
      DATA ABINT2(0)/  2.04122 07860 25161 35181  D    0/
      DATA ABINT2(1)/  0.21241 33918 62122 1230   D   -1/
      DATA ABINT2(2)/  0.66617 59976 67062 76     D   -3/
      DATA ABINT2(3)/  0.38420 47982 80825 4      D   -4/
      DATA ABINT2(4)/  0.36231 03660 20439        D   -5/
      DATA ABINT2(5)/  0.50351 99011 5074         D   -6/
      DATA ABINT2(6)/  0.79616 48702 253          D   -7/
      DATA ABINT2(7)/  0.71780 84423 36           D   -8/
      DATA ABINT2(8)/ -0.26777 01591 04           D   -8/
      DATA ABINT2(9)/ -0.16848 95146 99           D   -8/
      DATA ABINT2(10)/-0.36811 75725 5            D   -9/
      DATA ABINT2(11)/ 0.47571 28727              D  -10/
      DATA ABINT2(12)/ 0.52636 21945              D  -10/
      DATA ABINT2(13)/ 0.77897 3500               D  -11/
      DATA ABINT2(14)/-0.46054 6143               D  -11/
      DATA ABINT2(15)/-0.18343 3736               D  -11/
      DATA ABINT2(16)/ 0.32191 249                D  -12/
      DATA ABINT2(17)/ 0.29352 060                D  -12/
      DATA ABINT2(18)/-0.16579 35                 D  -13/
      DATA ABINT2(19)/-0.44838 08                 D  -13/
      DATA ABINT2(20)/ 0.27907                    D  -15/
      DATA ABINT2(21)/ 0.71192 1                  D  -14/
      DATA ABINT2(22)/-0.1042                     D  -16/
      DATA ABINT2(23)/-0.11959 1                  D  -14/
      DATA ABINT2(24)/ 0.4606                     D  -16/
      DATA ABINT2(25)/ 0.20884                    D  -15/
      DATA ABINT2(26)/-0.2416                     D  -16/
      DATA ABINT2(27)/-0.3638                     D  -16/
      DATA ABINT2(28)/ 0.863                      D  -17/
      DATA ABINT2(29)/ 0.591                      D  -17/
      DATA ABINT2(30)/-0.256                      D  -17/
      DATA ABINT2(31)/-0.77                       D  -18/
      DATA ABINT2(32)/ 0.66                       D  -18/
      DATA ABINT2(33)/ 0.3                        D  -19/
      DATA ABINT2(34)/-0.15                       D  -18/
      DATA ABINT2(35)/ 0.2                        D  -19/
      DATA ABINT2(36)/ 0.3                        D  -19/
      DATA ABINT2(37)/-0.1                        D  -19/
      DATA ABINT3(0)/  0.31076 96159 86403 49251  D    0/
      DATA ABINT3(1)/ -0.27528 84588 74525 42718  D    0/
      DATA ABINT3(2)/  0.17355 96570 61365 43928  D    0/
      DATA ABINT3(3)/ -0.55440 17909 49284 3130   D   -1/
      DATA ABINT3(4)/ -0.22512 65478 29595 0941   D   -1/
      DATA ABINT3(5)/  0.41073 47447 81252 1894   D   -1/
      DATA ABINT3(6)/  0.98476 12754 64262 480    D   -2/
      DATA ABINT3(7)/ -0.15556 18141 66604 1932   D   -1/
      DATA ABINT3(8)/ -0.56087 18707 30279 234    D   -2/
      DATA ABINT3(9)/  0.24601 77833 22230 475    D   -2/
      DATA ABINT3(10)/ 0.16574 03922 92336 978    D   -2/
      DATA ABINT3(11)/-0.32775 87501 43540 2      D   -4/
      DATA ABINT3(12)/-0.24434 68086 05149 25     D   -3/
      DATA ABINT3(13)/-0.50353 05196 15232 1      D   -4/
      DATA ABINT3(14)/ 0.16302 64722 24785 4      D   -4/
      DATA ABINT3(15)/ 0.85191 40577 80934        D   -5/
      DATA ABINT3(16)/ 0.29790 36300 4664         D   -6/
      DATA ABINT3(17)/-0.64389 70789 6401         D   -6/
      DATA ABINT3(18)/-0.15046 98814 5803         D   -6/
      DATA ABINT3(19)/ 0.15870 13535 823          D   -7/
      DATA ABINT3(20)/ 0.12767 66299 622          D   -7/
      DATA ABINT3(21)/ 0.14057 85341 99           D   -8/
      DATA ABINT3(22)/-0.46564 73974 1            D   -9/
      DATA ABINT3(23)/-0.15682 74879 1            D   -9/
      DATA ABINT3(24)/-0.40389 3560               D  -11/
      DATA ABINT3(25)/ 0.66670 8192               D  -11/
      DATA ABINT3(26)/ 0.12886 9380               D  -11/
      DATA ABINT3(27)/-0.69686 63                 D  -13/
      DATA ABINT3(28)/-0.62543 19                 D  -13/
      DATA ABINT3(29)/-0.71839 2                  D  -14/
      DATA ABINT3(30)/ 0.11529 6                  D  -14/
      DATA ABINT3(31)/ 0.42276                    D  -15/
      DATA ABINT3(32)/ 0.2493                     D  -16/
      DATA ABINT3(33)/-0.971                      D  -17/
      DATA ABINT3(34)/-0.216                      D  -17/
      DATA ABINT3(35)/-0.2                        D  -19/
      DATA ABINT3(36)/ 0.6                        D  -19/
      DATA ABINT3(37)/ 0.1                        D  -19/
      DATA ABINT4(0)/  1.99507 95931 33520 47614  D    0/
      DATA ABINT4(1)/ -0.27373 63759 70692 738    D   -2/
      DATA ABINT4(2)/ -0.30897 11308 12858 50     D   -3/
      DATA ABINT4(3)/ -0.35501 01982 79857 7      D   -4/
      DATA ABINT4(4)/ -0.41217 92715 20133        D   -5/
      DATA ABINT4(5)/ -0.48235 89231 6833         D   -6/
      DATA ABINT4(6)/ -0.56787 30727 927          D   -7/
      DATA ABINT4(7)/ -0.67187 48103 65           D   -8/
      DATA ABINT4(8)/ -0.79811 64985 7            D   -9/
      DATA ABINT4(9)/ -0.95142 71478              D  -10/
      DATA ABINT4(10)/-0.11374 68966              D  -10/
      DATA ABINT4(11)/-0.13635 9969               D  -11/
      DATA ABINT4(12)/-0.16381 418                D  -12/
      DATA ABINT4(13)/-0.19725 75                 D  -13/
      DATA ABINT4(14)/-0.23784 4                  D  -14/
      DATA ABINT4(15)/-0.28752                    D  -15/
      DATA ABINT4(16)/-0.3475                     D  -16/
      DATA ABINT4(17)/-0.422                      D  -17/
      DATA ABINT4(18)/-0.51                       D  -18/
      DATA ABINT4(19)/-0.6                        D  -19/
      DATA ABINT4(20)/-0.1                        D  -19/
      DATA ABINT5(0)/  1.12672 08196 17825 66017  D    0/
      DATA ABINT5(1)/ -0.67140 55675 25561 198    D   -2/
      DATA ABINT5(2)/ -0.69812 91801 78329 69     D   -3/
      DATA ABINT5(3)/ -0.75616 89886 42527 6      D   -4/
      DATA ABINT5(4)/ -0.83498 55745 10207        D   -5/
      DATA ABINT5(5)/ -0.93630 29823 2480         D   -6/
      DATA ABINT5(6)/ -0.10608 55629 6250         D   -6/
      DATA ABINT5(7)/ -0.12131 28916 741          D   -7/
      DATA ABINT5(8)/ -0.13963 11297 65           D   -8/
      DATA ABINT5(9)/ -0.16178 91805 4            D   -9/
      DATA ABINT5(10)/-0.18823 07907              D  -10/
      DATA ABINT5(11)/-0.22027 2985               D  -11/
      DATA ABINT5(12)/-0.25816 189                D  -12/
      DATA ABINT5(13)/-0.30479 64                 D  -13/
      DATA ABINT5(14)/-0.35837 0                  D  -14/
      DATA ABINT5(15)/-0.42831                    D  -15/
      DATA ABINT5(16)/-0.4993                     D  -16/
      DATA ABINT5(17)/-0.617                      D  -17/
      DATA ABINT5(18)/-0.68                       D  -18/
      DATA ABINT5(19)/-0.10                       D  -18/
      DATA ABINT5(20)/-0.1                        D  -19/
      DATA ZERO,ONE,ONEPT5/ 0.0 D 0 , 1.0 D 0 , 1.5 D 0 /
      DATA THREE,FOUR,SEVEN/ 3.0 D 0 , 4.0 D 0 , 7.0 D 0 /
      DATA EIGHT,NINE,SIXTEN/ 8.0 D 0 , 9.0 D 0 , 16.0 D 0 /
      DATA ONEHUN,NINHUN,THR644/100.0 D 0 , 900.0 D 0 , 3644.0 D 0 /
      DATA PIBY4/0.78539 81633 97448 30962 D 0/
      DATA RT2B3P/0.46065 88659 61780 63902 D 0/
      DATA BIRZER/0.61492 66274 46000 73515 D 0/
C
C   Start computation
C
      X = XVALUE
C
C   Compute the machine-dependent constants.
C
      T = D1MACH(3)
      F2 = ONE + ONE
      XNEG1 = -ONE/(T**(F2/THREE))
      XMAX = D1MACH(2)
      F1 = LOG(XMAX)
      TEMP = F1 + LOG(F1)/F2
      XHIGH1 = (THREE*TEMP/F2)**(F2/THREE)
C
C   Error test
C
      IF ( X .GT. XHIGH1 ) THEN
CCCCC    CALL ERRPRN(FNNAME,ERMSG1)
         WRITE(ICOUT,999)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,101)X
         CALL DPWRST('XXX','BUG ')
         BIRINT = XMAX
         RETURN
      ENDIF
  999 FORMAT(1X)
  101 FORMAT('***** ERROR FROM BIRINT--ARGUMENT TOO LARGE AND ',
     1        'POSITIVE, ARGUMENT = ',G15.7)
      IF ( X .LT. XNEG1 ) THEN
CCCCc    CALL ERRPRN(FNNAME,ERMSG2)
         WRITE(ICOUT,999)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,201)X
         CALL DPWRST('XXX','BUG ')
         BIRINT = ZERO
         RETURN
      ENDIF
  201 FORMAT('***** ERROR FROM BIRINT--ARGUMENT TOO LARGE AND ',
     1        'NEGATIVE, ARGUMENT = ',G15.7)
CCCCC DATA ERMSG2/'ARGUMENT TOO LARGE AND NEGATIVE'/
C
C  continue with machine-dependent constants
C
      XLOW1 = F2 * T
      T = T / ONEHUN
      IF ( X .GE. ZERO ) THEN
         DO 10 NTERM1 = 36 , 0 , -1
            IF ( ABS(ABINT1(NTERM1)) .GT. T ) GOTO 19
 10      CONTINUE
 19      DO 20 NTERM2 = 37 , 0 , -1
            IF ( ABS(ABINT2(NTERM2)) .GT. T ) GOTO 29
 20      CONTINUE
 29      CONTINUE
      ELSE
         DO 30 NTERM3 = 37 , 0 , -1
            IF ( ABS(ABINT3(NTERM3)) .GT. T ) GOTO 39
 30      CONTINUE
 39      DO 40 NTERM4 = 20 , 0 , -1
            IF ( ABS(ABINT4(NTERM4)) .GT. T ) GOTO 49
 40      CONTINUE
 49      DO 50 NTERM5 = 20 , 0 , -1
            IF ( ABS(ABINT5(NTERM5)) .GT. T ) GOTO 59
 50      CONTINUE
 59   ENDIF
C
C   Code for x >= 0.0
C
      IF ( X .GE. ZERO ) THEN
         IF ( X .LT. XLOW1 ) THEN
            BIRINT = BIRZER * X
         ELSE
            IF ( X .LE. EIGHT ) THEN
               T = X / FOUR - ONE
               BIRINT = X * EXP(ONEPT5*X) * CHEVAL(NTERM1,ABINT1,T)
            ELSE
               T = SIXTEN * SQRT(EIGHT/X) / X - ONE
               Z = ( X + X ) * SQRT(X) / THREE
               TEMP = RT2B3P * CHEVAL(NTERM2,ABINT2,T) / SQRT(Z)
               TEMP = Z + LOG(TEMP)
               BIRINT = EXP(TEMP)
            ENDIF
         ENDIF
      ELSE
C
C   Code for x < 0.0
C
         IF ( X .GE. -SEVEN ) THEN
            IF ( X .GT. -XLOW1 ) THEN
               BIRINT = BIRZER * X
            ELSE
               T = - ( X + X ) / SEVEN - ONE
               BIRINT = X * CHEVAL(NTERM3,ABINT3,T)
            ENDIF 
         ELSE
            Z = - ( X + X ) * SQRT(-X) / THREE
            ARG = Z + PIBY4
            TEMP = NINE * Z * Z
            T = (THR644 - TEMP ) / ( NINHUN + TEMP )
            F1 = CHEVAL(NTERM4,ABINT4,T) * SIN(ARG)
            F2 = CHEVAL(NTERM5,ABINT5,T) * COS(ARG) / Z
            BIRINT = ( F2 - F1 ) * RT2B3P / SQRT(Z)
         ENDIF
      ENDIF
      RETURN
      END
      SUBROUTINE BIVAR(Z,Y,X,N,Y2,X2,N2,IWRITE,Z2,
     1IBUGG3,ISUBRO,IERROR)
C
C     PURPOSE--COMPUTE BI-VARIATE INTERPOLATION OF A VARIABLE
C              (GENERATE INTERPOLATED POINTS).  THIS ROUTINE USES THE
C              B2INK AND B@VAL ROUTINES FROM CMLIB WRITTEN BY
C              RON BOISVERT OF NIST.
C     INPUT  ARGUMENTS--Z      = SINGLE PRECISION VARIABLE
C                                CONTAINING THE ORIGINAL
C                                Z AXIS DATA POINTS.
C                     --Y      = SINGLE PRECISION VARIABLE
C                                CONTAINING THE ORIGINAL
C                                VERTICAL AXIS DATA POINTS.
C                     --X      = SINGLE PRECISION VARIABLE
C                                CONTAINING THE ORIGINAL
C                                HORIZONTAL AXIS DATA POINTS.
C                     --Y2     = SINGLE PRECISION VARIABLE
C                                CONTAINING THE DESIRED
C                                VERTICAL AXIS INTERPOLATION
C                     --X2     = SINGLE PRECISION VARIABLE
C                                CONTAINING THE DESIRED
C                                HORIZONTAL AXIS INTERPOLATION
C                                POINTS.
C     OUTPUT ARGUMENTS--Z2     = SINGLE PRECISION VARIABLE
C                                CONTAINING THE COMPUTED
C                                Z AXIS INTERPOLATION
C                                POINTS.
C     NOTE--IT IS PROBABLY NOT PERMISSIBLE TO HAVE THE OUTPUT VECTOR
C           Y2(.) BEING IDENTICAL TO THE INPUT VECTOR Y(.)
C     NOTE--THIS SUBROUTINE DOES NOT ASSUME THAT THE INPUT
C           DATA IS ALREADY SORTED ACCORDING TO THE
C           HORIZONTAL AXIS VARIABLE.
C           SUCH SORTING IS DOEN HEREIN.
C     NOTE--IT DOES ASSUME THAT THE ORIGINAL (Y,X) POINTS FORM A 
C           RECTANGULAR GRID (ALTHOUGH THE GRID DOES NOT HAVE TO BE
C           PRE-SORTED).
C     CAUTION--THE INPUT VECTORS Y AND X ARE SORTED HEREIN
C              AND SO MAY BE DIFFERENT UPON LEAVING THIS SUBROUTINE
C              THAN UPON ENTERING THIS SUBROUTINE.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--94/5
C     ORIGINAL VERSION--MAY       1994.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGG3
      CHARACTER*4 ISUBRO
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 ISTEPN
C
      CHARACTER*4 IHP
      CHARACTER*4 IHP2
      CHARACTER*4 IHWUSE
      CHARACTER*4 MESSAG
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOPA.INC'
C
      DIMENSION Z(*)
      DIMENSION Y(*)
      DIMENSION X(*)
      DIMENSION X2(*)
      DIMENSION Y2(*)
      DIMENSION Z2(*)
C
      DIMENSION YTEMP(MAXOBV)
      DIMENSION XTEMP(MAXOBV)
      DIMENSION YDIST(MAXOBV)
      DIMENSION XDIST(MAXOBV)
      DIMENSION ZDIST(MAXOBV)
      DIMENSION ZTEMP2(MAXOBV)
      DIMENSION ZTEMP(MAXOBV)
      DIMENSION TX(MAXOBV)
      DIMENSION TY(MAXOBV)
      DIMENSION WORK(10*MAXOBV)
C
      INCLUDE 'DPCOZZ.INC'
      INCLUDE 'DPCOZ2.INC'
      EQUIVALENCE (G2RBAG(IGAR11),YTEMP(1))
      EQUIVALENCE (G2RBAG(IGAR12),YDIST(1))
      EQUIVALENCE (G2RBAG(IGAR13),XDIST(1))
      EQUIVALENCE (G2RBAG(IGAR14),ZDIST(1))
      EQUIVALENCE (G2RBAG(IGAR15),ZTEMP2(1))
      EQUIVALENCE (G2RBAG(IGAR16),ZTEMP(1))
      EQUIVALENCE (G2RBAG(IGAR17),XTEMP(1))
      EQUIVALENCE (G2RBAG(IGAR18),TX(1))
      EQUIVALENCE (G2RBAG(IGAR19),TY(1))
      EQUIVALENCE (G2RBAG(IGAR20),WORK(1))
CCCCC END CHANGE
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
      INCLUDE 'DPCOHK.INC'
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='BIVA'
      ISUBN2='R   '
C
      IERROR='NO'
C
      IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'IVAR')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF BIVAR--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)N
   52 FORMAT('N = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO55I=1,N
      WRITE(ICOUT,56)I,Z(I),Y(I),X(I)
   56 FORMAT('I,Z(I),Y(I),X(I) = ',I8,3E15.7)
      CALL DPWRST('XXX','BUG ')
   55 CONTINUE
      WRITE(ICOUT,62)N2
   62 FORMAT('N2 = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO65I=1,N2
      WRITE(ICOUT,66)I,Y2(I),X2(I)
   66 FORMAT('I,Y2(I),X2(I) = ',I8,2E15.7)
      CALL DPWRST('XXX','BUG ')
   65 CONTINUE
   90 CONTINUE
C
C               ****************************************
C               **  STEP 11--                         **
C               **  SORT THE INPUT DATA ACCORDING     **
C               **  TO THE HORIZONTAL AXIS VARIABLE   **
C               ****************************************
C
      ISTEPN='11'
      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'IVAR')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      DO1010,I=1,N
      XTEMP(I)=X(I)
 1010 CONTINUE
C
      CALL SORTC(X,Y,N,X,Y)
      CALL SORTC(XTEMP,Z,N,XTEMP,Z)
C
C               *******************************************************
C               **  STEP 12--                                        **
C               **  DETERMINE THE NUMBER OF DISTINCT X VALUES        **
C               *******************************************************
C
      ISTEPN='12'
      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'IVAR')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      NDISTX=0
      DO1210I=1,N
      IF(NDISTX.EQ.0)GOTO1220
      DO1215I2=1,NDISTX
      IF(X(I).EQ.XDIST(I2))GOTO1210
 1215 CONTINUE
 1220 CONTINUE
      NDISTX=NDISTX+1
      XDIST(NDISTX)=X(I)
 1210 CONTINUE
C
      CALL SORT(XDIST,NDISTX,XDIST)
C
C               *******************************************************
C               **  STEP 13--                                        **
C               **  DETERMINE THE NUMBER OF DISTINCT Y VALUES        **
C               *******************************************************
C
      ISTEPN='13'
      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'IVAR')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      NDISTY=0
      DO1310I=1,N
      IF(NDISTY.EQ.0)GOTO1320
      DO1315I2=1,NDISTY
      IF(Y(I).EQ.YDIST(I2))GOTO1310
 1315 CONTINUE
 1320 CONTINUE
      NDISTY=NDISTY+1
      YDIST(NDISTY)=Y(I)
 1310 CONTINUE
C
      CALL SORT(YDIST,NDISTY,YDIST)
C
C               *******************************************************
C               **  STEP 14--                                        **
C               **  SORT Y ASSOCIATED WITH EACH DISTINCT X VALUE     **
C               **  CHECK FOR REPLICATION OF POINTS                  **
C               **  IF ALL DISTINCT (THAT IS, NO REPLICATION),     **
C               **  (THAT IS, HAVE NO REPLICATION),                **
C               **  THEN COPY OVER Z VALUES.                       **
C               **  IF NOT ALL DISTINCT                            **
C               **  (THAT IS, HAVE SOME REPLICATION),              **
C               **  THEN COMPUTE A MEAN VALUE OVER THE REPLICATES  **
C               **  AND TREAT THAT AS THE COMMON VALUE.            **
C               **  THE CORE OF THE INTERPOLATION CODE             **
C               **  IS EXPECTING SORTED, DISTINCT X AND Y VALUES.   **
C               **  ALSO CHECK THAT X AND Y FORM A RECTANGULAR GRID.**
C               *******************************************************
C
      ISTEPN='14'
      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'IVAR')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      NUMZ=0
      ISTART=1
      DO1410I=1,NDISTX
        XT=XDIST(I)
        ICOUNT=0
        DO1420J=ISTART,N
        IF(X(J).EQ.XT)THEN
          IF(ICOUNT.EQ.0)IFRST=J
          ICOUNT=ICOUNT+1
          YTEMP(ICOUNT)=Y(J)
          ZTEMP(ICOUNT)=Z(J)
          ILAST=J
        ELSEIF(X(J).GT.XT)THEN
          GOTO1421
        ENDIF
 1420   CONTINUE
 1421   CONTINUE
C
        ISTART=ILAST+1
        CALL SORTC(YTEMP,ZTEMP,ICOUNT,YTEMP,ZTEMP)
        DO1471K=1,NDISTY
          TAG=YDIST(K)
          J=0
          DO1472II=1,ICOUNT
            IF(YTEMP(II).EQ.TAG)THEN
              J=J+1
              ZTEMP2(J)=ZTEMP(II)
            END IF
 1472     CONTINUE
          NI=J
          IF(NI.EQ.1)THEN
            NUMZ=NUMZ+1
            ZDIST(NUMZ)=ZTEMP2(1)
          ELSE IF(NI.GT.1)THEN
            CALL MEAN(ZTEMP2,NI,IWRITE,ZMEAN,IBUGG3,IERROR)
            NUMZ=NUMZ+1
            ZDIST(NUMZ)=ZMEAN
          ELSE
            WRITE(ICOUT,999)
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,1491)
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,1492)
            CALL DPWRST('XXX','BUG ')
            IERROR='YES'
            GOTO9000
          ENDIF
 1471   CONTINUE
C
 1410 CONTINUE
C
 1491 FORMAT('******* ERROR FROM BIVAR.  ORIGINAL X AND Y')
 1492 FORMAT('        DATA DO NOT FORM A RECTANGULAR GRID.  ******')
C
C               ********************************************
C               **  STEP 15--                             **
C               **  CHECK FOR USER PARAMETERS XDEGREE AND **
C               **  YDEGREE FOR ORDER OF POLYNOMIALS      **
C               ********************************************
C
 1500 CONTINUE
      IXDEG=4
      IYDEG=4
C
      XDEG=3.0
      IHP='XDEG'
      IHP2='REE '
      IHWUSE='P'
      MESSAG='NO'
      CALL CHECKN(IHP,IHP2,IHWUSE,
     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
     1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR)
      IF(IERROR.EQ.'YES')GOTO1510
      XDEG=VALUE(ILOCP)
 1510 CONTINUE
C
      IXDEG=INT(XDEG+0.5)
      IF(IXDEG.GE.1.AND.IXDEG.LE.3)GOTO1519
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1511)
 1511 FORMAT('***** ERROR IN BIVAR--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1512)
 1512 FORMAT('      THE POLYNOMIAL DEGREE FOR THE B-SPLINE IN THE')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1514)
 1514 FORMAT('      X DIRECTION MUST BE BETWEEN 1 AND 3 INCLUSIVE;')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1515)
 1515 FORMAT('      SUCH WAS NOT THE CASE HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1516)XDEG
 1516 FORMAT('      THE CURRENT VALUE OF XDEGREE IS ',E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1517)
 1517 FORMAT('      A VALUE OF 3.0 WILL BE USED')
      CALL DPWRST('XXX','BUG ')
      IXDEG=3
 1519 CONTINUE
      IXDEG=IXDEG+1
C
      YDEG=3.0
      IHP='YDEG'
      IHP2='REE '
      IHWUSE='P'
      MESSAG='NO'
      CALL CHECKN(IHP,IHP2,IHWUSE,
     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
     1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR)
      IF(IERROR.EQ.'YES')GOTO1610
      YDEG=VALUE(ILOCP)
 1610 CONTINUE
C
      IYDEG=INT(YDEG+0.5)
      IF(IYDEG.GE.1.AND.IYDEG.LE.3)GOTO1619
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1611)
 1611 FORMAT('***** ERROR IN BIVAR--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1612)
 1612 FORMAT('      THE POLYNOMIAL DEGREE FOR THE B-SPLINE IN THE')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1614)
 1614 FORMAT('      Y DIRECTION MUST BE BETWEEN 1 AND 3 INCLUSIVE;')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1615)
 1615 FORMAT('      SUCH WAS NOT THE CASE HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1616)YDEG
 1616 FORMAT('      THE CURRENT VALUE OF YDEGREE IS ',E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1617)
 1617 FORMAT('      A VALUE OF 3.0 WILL BE USED')
      CALL DPWRST('XXX','BUG ')
      IYDEG=3
 1619 CONTINUE
      IYDEG=IYDEG+1
C
C
C               ********************************************
C               **  STEP 15--                             **
C               **  COMPUTE INTERPOLATED VALUES           **
C               ********************************************
C
      CALL BIVAR2(ZDIST,YDIST,XDIST,NDISTX,NDISTY,Y2,X2,N2,Z2,
     1IXDEG,IYDEG,
     1TX,TY,WORK,
     1IBUGG3,ISUBRO,IERROR)
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'IVAR')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF BIVAR--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)N,N2
 9012 FORMAT('N,N2 = ',2I8)
      CALL DPWRST('XXX','BUG ')
      DO9042I=1,N2
      WRITE(ICOUT,9043)I,X2(I),Y2(I),Z2(I)
 9043 FORMAT('I,X2(I),Y2(I),Z2(I) = ',I8,3E15.7)
      CALL DPWRST('XXX','BUG ')
 9042 CONTINUE
      WRITE(ICOUT,9051)NDISTX,NDISTY
 9051 FORMAT('NDISTX,NDISTY = ',2I8)
      CALL DPWRST('XXX','BUG ')
      DO9052I=1,NDISTX
      DO9054J=1,NDISTY
      WRITE(ICOUT,9053)I,J,XDIST(I),YDIST(J),ZDIST((I-1)*NDISTY+J)
 9053 FORMAT('I,J,XDIST(I),YDIST(J),ZDIST = ',2I8,3E15.7)
      CALL DPWRST('XXX','BUG ')
 9054 CONTINUE
 9052 CONTINUE
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE BIVAR2(Z,Y,X,NX,NY,Y2,X2,N2,Z2,
     1IXDEG,IYDEG,
     1TX,TY,WORK,
     1IBUGG3,ISUBRO,IERROR)
C
C     PURPOSE--COMPUTE BI-LINEAR INTERPOLATION OF A VARIABLE
C              (GENERATE INTERPOLATED POINTS).  THIS ROUTINE USES THE
C              B2INK AND B2VAL ROUTINES FROM CMLIB WRITTEN BY
C              RON BOISVERT OF NIST.
C     INPUT  ARGUMENTS--Z      = SINGLE PRECISION VARIABLE
C                                CONTAINING THE ORIGINAL
C                                Z AXIS DATA POINTS.
C                     --Y      = SINGLE PRECISION VARIABLE
C                                CONTAINING THE ORIGINAL
C                                VERTICAL AXIS DATA POINTS.
C                     --X      = SINGLE PRECISION VARIABLE
C                                CONTAINING THE ORIGINAL
C                                HORIZONTAL AXIS DATA POINTS.
C                     --Y2     = SINGLE PRECISION VARIABLE
C                                CONTAINING THE DESIRED
C                                VERTICAL AXIS INTERPOLATION
C                     --X2     = SINGLE PRECISION VARIABLE
C                                CONTAINING THE DESIRED
C                                HORIZONTAL AXIS INTERPOLATION
C                                POINTS.
C     OUTPUT ARGUMENTS--Z2     = SINGLE PRECISION VARIABLE
C                                CONTAINING THE COMPUTED
C                                VERTICAL AXIS INTERPOLATION
C                                POINTS.
C     NOTE--IT IS PROBABLY NOT PERMISSIBLE TO HAVE THE OUTPUT VECTOR 
C           Z2(.) BEING IDENTICAL TO THE INPUT VECTOR Z(.)
C     NOTE--THE X AND Y POINTS ARE ASSUMED TO LIE ON A RECTANGULAR GRID
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--94/5
C     ORIGINAL VERSION--MAY       1994.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IBUGG3
      CHARACTER*4 ISUBRO
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
C
      DIMENSION Z(*)
      DIMENSION Y(*)
      DIMENSION X(*)
      DIMENSION Z2(*)
      DIMENSION Y2(*)
      DIMENSION X2(*)
      DIMENSION TX(*)
      DIMENSION TY(*)
      DIMENSION WORK(*)
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='BILI'
      ISUBN2='N2  '
C
      IERROR='NO'
C
      DO10I=1,N2
      Z2(I)=0.0
 10   CONTINUE
C
      IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'VAR2')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF BIVAR2--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)NX,NY
   52 FORMAT('NX, NY = ',2I8)
      CALL DPWRST('XXX','BUG ')
      DO54I=1,NX
      DO55J=1,NY
      INDX=(I-1)*NY+J
      WRITE(ICOUT,53)I,J,X(I),Y(J),Z(INDX)
      CALL DPWRST('XXX','BUG ')
 53   FORMAT('I,J,X(I),Y(J),Z = ',2I8,3E15.7)
      CALL DPWRST('XXX','BUG ')
 55   CONTINUE
 54   CONTINUE
      WRITE(ICOUT,62)N2
   62 FORMAT('N2 = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO65I=1,N2
      WRITE(ICOUT,66)I,Y2(I),X2(I)
   66 FORMAT('I,Y2(I),X2(I) = ',I8,2E15.7)
      CALL DPWRST('XXX','BUG ')
   65 CONTINUE
   90 CONTINUE
C
C               ****************************************
C               **  STEP 31--
C               **  COMPUTE INTERPOLATION VALUES
C               ****************************************
C
      DO3100J=1,N2
      XT=X2(J)
      IF(X(1).GT.XT.OR.XT.GT.X(NX))GOTO3110
      YT=Y2(J)
      IF(Y(1).GT.YT.OR.YT.GT.Y(NY))GOTO3120
      GOTO3129
C
 3110 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3111)
 3111 FORMAT('***** ERROR IN BIVAR2--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3112)
 3112 FORMAT('      AN ATTEMPT WAS MADE TO COMPUTE')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3113)
 3113 FORMAT('      A SMOOTHED VALUE BEYOND THE X RANGE')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3114)
 3114 FORMAT('      OF THE DATA--SUCH EXTRAPOLATION')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3115)
 3115 FORMAT('      IS UNRELIABLE AND NOT PERMITTED.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3116)X(1)
 3116 FORMAT('         SMALLEST DATA POINT X(1)      = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3117)X(NX)
 3117 FORMAT('         LARGEST DATA POINT  X(NX)     = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3118)XT
 3118 FORMAT('         ATTEMPTED EXTRAPOLATION POINT = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
C
 3120 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3121)
 3121 FORMAT('***** ERROR IN BIVAR2--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3122)
 3122 FORMAT('      AN ATTEMPT WAS MADE TO COMPUTE')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3123)
 3123 FORMAT('      A SMOOTHED VALUE BEYOND THE Y RANGE')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3124)
 3124 FORMAT('      OF THE DATA--SUCH EXTRAPOLATION')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3125)
 3125 FORMAT('      IS UNRELIABLE AND NOT PERMITTED.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3126)Y(1)
 3126 FORMAT('         SMALLEST DATA POINT Y(1)      = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3127)Y(NY)
 3127 FORMAT('         LARGEST DATA POINT  Y(NY)     = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3128)YT
 3128 FORMAT('         ATTEMPTED EXTRAPOLATION POINT = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
C
 3129 CONTINUE
 3100 CONTINUE
C
      IFLAG=0
      CALL B2INK(X,NX,Y,NY,Z,NX,IXDEG,IYDEG,TX,TY,Z,WORK,IFLAG)
      IF(IFLAG.EQ.1)GOTO3199
      IERROR='YES'
      WRITE(ICOUT,3130)IFLAG
      CALL DPWRST('XXX','BUG ')
 3130 FORMAT('***** B2INK RETURNED ERROR CODE ',I2)
      WRITE(ICOUT,3131)
      CALL DPWRST('XXX','BUG ')
 3131 FORMAT('      NO INTERPOLATION PERFORMED.     *****')
      GOTO9000
C
 3199 CONTINUE
C
      IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'VAR2')GOTO3190
      DO3191J=1,NX+IXDEG
      WRITE(ICOUT,3192)J,TX(J)
      CALL DPWRST('XXX','BUG ')
 3192 FORMAT('J,TX(J) = ',I5,1X,E15.7)
 3191 CONTINUE
      DO3193J=1,NY+IYDEG
      WRITE(ICOUT,3194)J,TY(J)
      CALL DPWRST('XXX','BUG ')
 3194 FORMAT('J,TY(J) = ',I5,1X,E15.7)
 3193 CONTINUE
 3190 CONTINUE
C
      IDX=0
      IDY=0
      DO3200I=1,N2
        XVAL=X2(I)
        YVAL=Y2(I)
        Z2(I)=B2VAL(XVAL,YVAL,IDX,IDY,TX,TY,NX,NY,IXDEG,IYDEG,
     1             Z,WORK)
 3200 CONTINUE
C
C               ****************************************
C               **  STEP 41--
C               **  IF CALLED FOR,
C               **  WRITE OUT INTERPOLATION VALUES
C               ****************************************
C
      IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'VAR2')GOTO4190
      DO4100J=1,N2
      WRITE(ICOUT,4110)X2(J),Y2(J),Z2(J)
      CALL DPWRST('XXX','BUG ')
 4110 FORMAT('X2(J),Y2(J),Z2(J) = ',3E15.7)
 4100 CONTINUE
 4190 CONTINUE
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'VAR2')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF BIVAR2--')
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE BIWMCV(X,Y,N,IWRITE,XTEMP,XTEMP2,MAXNXT,XBWCOV,
     1IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE
C              SAMPLE BIWEIGHT MID-COVARIANCE ESTIMATOR
C              OF THE DATA IN THE INPUT VECTOR X.
C              THE SAMPLE BIWEIGHT MID-COVARIANCE ESTIMATE IS DEFINED AS:
C                 s(bxy)**2 = SUM'[{a(i)*(x-x')**2*(1-u**2)**2}*
C                             {b(i)*(y-y')**2*(1-v**2)**2}]/
C                            {SUM'[a(i)*(1-u**2)*(1-5*u**2)]*
C                            SUM'[b(i)*(1-v**2)*(1-5*v**2)]}
C              WHERE
C                 y' = MEDIAN OF Y
C                 x' = MEDIAN OF X
C                 MAD = MEDIAN ABSOLUTE DEVIATION
C                 u(i) = (X(i) - x')/(9*MAD)
C                 v(i) = (Y(i) - y')/(9*MAD)
C                 a(i) = 1 if |u(i)| <= 1, 0 otherwise
C                 b(i) = 1 if |v(i)| <= 1, 0 otherwise
C                 SUM' means the summation is for u**2 < 1 or v**2 < 1
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR OF
C                                (UNSORTED OR SORTED) OBSERVATIONS.
C                     --Y      = THE SINGLE PRECISION VECTOR OF
C                                (UNSORTED OR SORTED) OBSERVATIONS.
C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTORS X AND Y.
C     OUTPUT ARGUMENTS--XBWCOV    = THE SINGLE PRECISION VALUE OF THE
C                                COMPUTED SAMPLE BIWEIGHT MID-COVARIANCE
C                                ESTIMATE.
C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
C             SAMPLE BIWEIGHT LOCATION ESTIMATE.
C     OTHER DATAPLOT  SUBROUTINES NEEDED--MEDIAN, MAD 
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--MOSTELLER AND TUKEY, 'DATA ANALYSIS AND REGRESSION'
C                 ADDISON AND WESLEY, 1977, PP. 204-206.
C     REFERENCES--RAND R. WILCOX, 'INTORIDUCTION TO ROBUST ESTIMATION
C                 AND HYPOTHESIS TESTING'
C                 ACADEMIC PRESS, 1997. PP. 196-197.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2899
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2002/7
C     ORIGINAL VERSION--JULY      2002.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 IWRIT2
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
C
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DSUM2
      DOUBLE PRECISION DSUM3
      DOUBLE PRECISION DUI
      DOUBLE PRECISION DSBI
C
      DIMENSION X(*)
      DIMENSION Y(*)
      DIMENSION XTEMP(*)
      DIMENSION XTEMP2(*)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='BIWM'
      ISUBN2='CV  '
      XBWCOV=0.0
C
      IERROR='NO'
C
      IF(IBUGA3.EQ.'OFF')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF BIWMCV--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)IBUGA3
   52 FORMAT('IBUGA3 = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)N
   53 FORMAT('N = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO55I=1,N
      WRITE(ICOUT,56)I,X(I)
   56 FORMAT('I,X(I) = ',I8,E15.7)
      CALL DPWRST('XXX','BUG ')
   55 CONTINUE
   90 CONTINUE
C
C               ********************************************
C               **  COMPUTE BIWEIGHT MID-COVARIANCE ESTIMATE **
C               ********************************************
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      AN=N
C
      IF(N.GT.1)GOTO119
      IERROR='YES'
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,111)
  111 FORMAT('***** ERROR IN BIWMCV--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,112)
  112 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,113)
  113 FORMAT('      IN THE VARIABLE FOR WHICH')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,114)
  114 FORMAT('      THE BIWEIGHT MID-COVARIANCE ESTIMATE IS TO BE')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,115)
  115 FORMAT('      COMPUTED, MUST BE 2 OR LARGER.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,116)
  116 FORMAT('      SUCH WAS NOT THE CASE HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,117)N
  117 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8,
     1'.')
      CALL DPWRST('XXX','BUG ')
      GOTO9000
  119 CONTINUE
C
      HOLD=X(1)
      DO135I=2,N
      IF(X(I).NE.HOLD)GOTO139
  135 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,136)HOLD
  136 FORMAT('***** NON-FATAL DIAGNOSTIC IN BIWMCV--',
     1'THE FIRST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      XBWCOV=0.0
      GOTO9000
  139 CONTINUE
C
  190 CONTINUE
C
C               ******************************************************
C               **  STEP 2--                                        **
C               **  COMPUTE THE BIWEIGHT MID-COVARIANCE ESTIMATE.   **
C               ******************************************************
C
      IWRIT2='OFF'
      CALL MEDIAN(X,N,IWRIT2,XTEMP,MAXNXT,XMED,IBUGA3,IERROR)
      DO205I=1,N
        XTEMP2(I)=X(I)
  205 CONTINUE
      CALL MAD(X,N,IWRIT2,XTEMP,MAXNXT,XMAD,IBUGA3,IERROR)
      DO215I=1,N
        X(I)=XTEMP2(I)
  215 CONTINUE
C
      IWRIT2='OFF'
      CALL MEDIAN(Y,N,IWRIT2,XTEMP,MAXNXT,YMED,IBUGA3,IERROR)
      DO225I=1,N
        XTEMP2(I)=Y(I)
  225 CONTINUE
      CALL MAD(Y,N,IWRIT2,XTEMP,MAXNXT,YMAD,IBUGA3,IERROR)
      DO235I=1,N
        Y(I)=XTEMP2(I)
  235 CONTINUE
C
      DSUM1=0.0D0
      DSUM2=0.0D0
      DSUM3=0.0D0
      DO300I=1,N
        DUI=DBLE((X(I) - XMED)/(9.0*XMAD))
        DVI=DBLE((Y(I) - YMED)/(9.0*YMAD))
        IF(DUI*DUI.LE.1.0D0)THEN
          DTERM1=DBLE(X(I)-XMED)*(1.0D0 - DUI**2)**2
          DSUM2=DSUM2 + (1.0D0 - DUI**2)*(1.0D0 - 5.0D0*DUI**2)
        ELSE
          DTERM1=0.0D0
        ENDIF
        IF(DVI*DVI.LE.1.0D0)THEN
          DTERM2=DBLE(Y(I)-YMED)*(1.0D0 - DVI**2)**2
          DSUM3=DSUM3 + (1.0D0 - DVI**2)*(1.0D0 - 5.0D0*DVI**2)
        ELSE
          DTERM2=0.0D0
        ENDIF
        DSUM1=DSUM1 + DTERM1*DTERM2
  300 CONTINUE
      DSBI=DBLE(N)*DSUM1/(DSUM2*DSUM3)
      XBWCOV=REAL(DSBI)
C
C               *******************************
C               **  STEP 3--                 **
C               **  WRITE OUT A LINE         **
C               **  OF SUMMARY INFORMATION.  **
C               *******************************
C
      IF(IFEEDB.EQ.'OFF')GOTO890
      IF(IWRITE.EQ.'OFF')GOTO890
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,811)N,XBWCOV
  811 FORMAT('THE BIWEIGHT MID-COVARIANCE ESTIMATE OF THE ',I8,
     1' OBSERVATIONS = ',E15.7)
      CALL DPWRST('XXX','BUG ')
  890 CONTINUE
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'OFF')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF BIWMCV--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IBUGA3,IERROR
 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)N
 9013 FORMAT('N = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9015)XBWCOV
 9015 FORMAT('XBWCOV = ',E15.7)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE BIWEIG(RES,N,IWRITE,WEIGHT,IBUGA3,IERROR)
C     PURPOSE--DETERMINE THE N VERTICAL (ROBUST) WEIGHTS WEIGHT(.)
C              BASED ON A BIWEIGHT WEIGHTING SCHEME OF
C              THE RESIDUALS IN RES(.).
C     NOTE--IF ALL INPUT RESIDUALS ARE ZERO, THIS SUBROUTINE
C           WILL OUTPUT ALL WEIGHTS AS UNITY.
C     REFERENCE--CHAMBERS, ET AL.  GRAPHICAL METHODS FOR DATA ANALYSIS.
C                WADSWORTH, 11013, PAGES 98-101, 122-123.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--88/2
C     ORIGINAL VERSION--FEBRUARY   1988
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DIMENSION RES(*)
      DIMENSION WEIGHT(*)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='BIWE'
      ISUBN2='IG  '
C
      IERROR='NO'
C
      IF(IBUGA3.EQ.'OFF')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF BIWEIG--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)IBUGA3,IERROR
   52 FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)N
   53 FORMAT('N = ',I8)
      CALL DPWRST('XXX','BUG ')
      IF(N.LE.0)GOTO63
      DO61I=1,N
      WRITE(ICOUT,62)I,RES(I)
   62 FORMAT('I,RES(I) = ',I8,E15.7)
      CALL DPWRST('XXX','BUG ')
   61 CONTINUE
   63 CONTINUE
   90 CONTINUE
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      IF(N.GE.1)GOTO119
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,111)
  111 FORMAT('***** ERROR IN BIWEIG--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,112)
  112 FORMAT('      THE INPUT FULL SAMPLE SIZE,')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,113)
  113 FORMAT('      FOR WHICH BIWEIGHT WEIGHTS')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,114)
  114 FORMAT('      ARE TO BE COMPUTED, MUST BE 1 OR LARGER.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,115)
  115 FORMAT('      SUCH WAS NOT THE CASE HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,116)N
  116 FORMAT('      THE FULL SAMPLE SIZE N = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
  119 CONTINUE
C
C               ***********************************************
C               **  STEP 11--                                **
C               **  COMPUTE THE BIWEIGHT WEIGHTING           **
C               **     1) COMPUTE ABSOLUTE VALUE OF RESIDUALS
C               **     2) COMPUTE MEDIAN ABSOLUTE VALUE RESIDUAL
C               **     3) COMPUTE CUTOFF = +-6*M.A.R.
C               **     4) ASSIGN 0 WEIGHTS OUTSIDE OF REGION
C               **     5) ASSIGN BIWEIGHTS INSIDE OF REGION
C               ***********************************************
C
      DO1100I=1,N
      WEIGHT(I)=ABS(RES(I))
 1100 CONTINUE
C
      CALL SORT(WEIGHT,N,WEIGHT)
      IEVODD=N-(N/2)*2
      NMID=N/2
      NMIDP1=NMID+1
      IF(IEVODD.EQ.0)XMEDAR=(WEIGHT(NMID)+WEIGHT(NMIDP1))/2.0
      IF(IEVODD.EQ.1)XMEDAR=WEIGHT(NMIDP1)
C
      IF(XMEDAR.EQ.0.0)GOTO1110
      GOTO1120
C
 1110 CONTINUE
      CONST=(-999.0)
      DO1111I=1,N
      WEIGHT(I)=1.0
 1111 CONTINUE
      GOTO1190
C
 1120 CONTINUE
      CONST=6.0*XMEDAR
      DO1121I=1,N
      U=RES(I)/CONST
      WEIGHT(I)=0.0
      IF(-1.0.LE.U.AND.U.LE.1.0)WEIGHT(I)=(1.0-U**2)**2
 1121 CONTINUE
      GOTO1190
C
 1190 CONTINUE
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'OFF')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF BIWEIG--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IBUGA3,IERROR
 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)N
 9013 FORMAT('N = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9014)XMEDAR
 9014 FORMAT('XMEDAR = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      IF(N.LE.0)GOTO9023
      DO9021I=1,N
      WRITE(ICOUT,9022)I,RES(I),WEIGHT(I)
 9022 FORMAT('I,RES(I),WEIGHT(I) = ',I8,2E15.7)
      CALL DPWRST('XXX','BUG ')
 9021 CONTINUE
 9023 CONTINUE
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE BIWMDV(X,N,IWRITE,XTEMP,XTEMP2,MAXNXT,XBWMDV,
     1IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE
C              SAMPLE BIWEIGHT MIDVARIANCE ESTIMATOR
C              OF THE DATA IN THE INPUT VECTOR X.
C              THE SAMPLE BIWEIGHT MIDVARIANCE ESTIMATE IS DEFINED AS:
C                 s(bi)**2 = SUM'[(y-y')**2*(1-u**2)**4]/
C                            {SUM'[1-u**2)*(1-5*u**2)]**2}
C              WHERE
C                 y' = MEDIAN OF Y
C                 MAD = MEDIAN ABSOLUTE DEVIATION
C                 u(i) = (Y(i) - y')/(9*MAD)
C                 SUM' means the summation is for u**2 <= 1
C              NOTE THAT THIS IS A SLIGHT VARIATION OF THE
C                   BIWEIGHT SCALE ESTIMATE.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR OF
C                                (UNSORTED OR SORTED) OBSERVATIONS.
C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTOR X.
C     OUTPUT ARGUMENTS--XBWMDV    = THE SINGLE PRECISION VALUE OF THE
C                                COMPUTED SAMPLE BIWEIGHT MIDVARIANCE
C                                ESTIMATE.
C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
C             SAMPLE BIWEIGHT LOCATION ESTIMATE.
C     OTHER DATAPLOT  SUBROUTINES NEEDED--MEAN, MAD 
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--MOSTELLER AND TUKEY, 'DATA ANALYSIS AND REGRESSION'
C                 ADDISON AND WESLEY, 1977, PP. 204-206.
C     REFERENCES--RAND R. WILCOX, 'INTORIDUCTION TO ROBUST ESTIMATION
C                 AND HYPOTHESIS TESTING'
C                 ACADEMIC PRESS, 1997.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2899
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2002/7
C     ORIGINAL VERSION--JULY      2002.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 IWRIT2
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
C
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DSUM2
      DOUBLE PRECISION DUI
      DOUBLE PRECISION DSBI
C
      DIMENSION X(*)
      DIMENSION XTEMP(*)
      DIMENSION XTEMP2(*)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='BIWM'
      ISUBN2='DV  '
      XBWMDV=0.0
C
      IERROR='NO'
C
      IF(IBUGA3.EQ.'OFF')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF BIWMDV--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)IBUGA3
   52 FORMAT('IBUGA3 = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)N
   53 FORMAT('N = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO55I=1,N
      WRITE(ICOUT,56)I,X(I)
   56 FORMAT('I,X(I) = ',I8,E15.7)
      CALL DPWRST('XXX','BUG ')
   55 CONTINUE
   90 CONTINUE
C
C               ********************************************
C               **  COMPUTE BIWEIGHT MIDVARIANCE ESTIMATE **
C               ********************************************
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      AN=N
C
      IF(N.GT.1)GOTO119
      IERROR='YES'
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,111)
  111 FORMAT('***** ERROR IN BIWMDV--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,112)
  112 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,113)
  113 FORMAT('      IN THE VARIABLE FOR WHICH')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,114)
  114 FORMAT('      THE BIWEIGHT MIDVARIANCE ESTIMATE IS TO BE')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,115)
  115 FORMAT('      COMPUTED, MUST BE 2 OR LARGER.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,116)
  116 FORMAT('      SUCH WAS NOT THE CASE HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,117)N
  117 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8,
     1'.')
      CALL DPWRST('XXX','BUG ')
      GOTO9000
  119 CONTINUE
C
      HOLD=X(1)
      DO135I=2,N
      IF(X(I).NE.HOLD)GOTO139
  135 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,136)HOLD
  136 FORMAT('***** NON-FATAL DIAGNOSTIC IN BIWMDV--',
     1'THE FIRST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      XBWMDV=0.0
      GOTO9000
  139 CONTINUE
C
  190 CONTINUE
C
C               ***************************************************
C               **  STEP 2--                                     **
C               **  COMPUTE THE BIWEIGHT MIDVARIANCE ESTIMATE.   **
C               ***************************************************
C
      IWRIT2='OFF'
      CALL MEDIAN(X,N,IWRIT2,XTEMP,MAXNXT,XMED,IBUGA3,IERROR)
      DO205I=1,N
        XTEMP2(I)=X(I)
  205 CONTINUE
      CALL MAD(X,N,IWRIT2,XTEMP,MAXNXT,XMAD,IBUGA3,IERROR)
      DO215I=1,N
        X(I)=XTEMP2(I)
  215 CONTINUE
C
      DSUM1=0.0D0
      DSUM2=0.0D0
      DO300I=1,N
        DUI=DBLE((X(I) - XMED)/(9.0*XMAD))
        IF(DUI*DUI.LT.1.0D0)THEN
          DSUM1=DSUM1 + (DBLE(X(I)-XMED)**2)*(1.0D0 - DUI**2)**4
          DSUM2=DSUM2 + (1.0D0 - DUI**2)*(1.0D0 - 5.0D0*DUI**2)
        ENDIF
  300 CONTINUE
      DSBI=DBLE(N)*DSUM1/(DSUM2*DSUM2)
      XBWMDV=REAL(DSBI)
C
C               *******************************
C               **  STEP 3--                 **
C               **  WRITE OUT A LINE         **
C               **  OF SUMMARY INFORMATION.  **
C               *******************************
C
      IF(IFEEDB.EQ.'OFF')GOTO890
      IF(IWRITE.EQ.'OFF')GOTO890
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,811)N,XBWMDV
  811 FORMAT('THE BIWEIGHT MIDVARIANCE ESTIMATE OF THE ',I8,
     1' OBSERVATIONS = ',E15.7)
      CALL DPWRST('XXX','BUG ')
  890 CONTINUE
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'OFF')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF BIWMDV--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IBUGA3,IERROR
 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)N
 9013 FORMAT('N = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9015)XBWMDV
 9015 FORMAT('XBWMDV = ',E15.7)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE BIWLOC(X,N,IWRITE,XTEMP,XTEMP2,MAXNXT,XBW,
     1IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE
C              SAMPLE BIWEIGHT LOCATION ESTIMATOR
C              OF THE DATA IN THE INPUT VECTOR X.
C              THE SAMPLE BIWEIGHT LOCATION ESTIMATE IS DEFINED AS:
C                 y* = SUM[w(i)*y(i)]/SUM[w(i)]
C              WHERE
C                 w(i) = (1 - ((y(i) - y*)/(6*MAD))**2)**2
C                                    if (y(i) - y*)/(6*MAD))**2   < 1
C                      = 0           otherwise
C              WHERE MAD IS THE BIWEIGHT LOCATION ESTIMATE
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR OF
C                                (UNSORTED OR SORTED) OBSERVATIONS.
C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTOR X.
C     OUTPUT ARGUMENTS--XBW    = THE SINGLE PRECISION VALUE OF THE
C                                COMPUTED SAMPLE BIWEIGHT LOCATION
C                                ESTIMATE.
C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
C             SAMPLE BIWEIGHT LOCATION ESTIMATE.
C     OTHER DATAPLOT  SUBROUTINES NEEDED--MEAN, MAD 
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--MOSTELLER AND TUKEY, 'DATA ANALYSIS AND REGRESSION'
C                 ADDISON AND WESLEY, 1977, PP. 204-206.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2899
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2001/11
C     ORIGINAL VERSION--NOVEMBER  2001.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 IWRIT2
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
C
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DSUM2
      DOUBLE PRECISION DWT
C
      DIMENSION X(*)
      DIMENSION XTEMP(*)
      DIMENSION XTEMP2(*)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='BIWL'
      ISUBN2='OC  '
      XBW=0.0
C
      IERROR='NO'
C
      IF(IBUGA3.EQ.'OFF')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF BIWLOC--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)IBUGA3
   52 FORMAT('IBUGA3 = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)N
   53 FORMAT('N = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO55I=1,N
      WRITE(ICOUT,56)I,X(I)
   56 FORMAT('I,X(I) = ',I8,E15.7)
      CALL DPWRST('XXX','BUG ')
   55 CONTINUE
   90 CONTINUE
C
C               ******************************************
C               **  COMPUTE BIWEIGHT LOCATION ESTIMATE **
C               ******************************************
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      AN=N
C
      IF(N.GT.1)GOTO119
      IERROR='YES'
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,111)
  111 FORMAT('***** ERROR IN BIWLOC--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,112)
  112 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,113)
  113 FORMAT('      IN THE VARIABLE FOR WHICH')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,114)
  114 FORMAT('      THE BIWEIGHT LOCATION ESTIMATE IS TO BE')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,115)
  115 FORMAT('      COMPUTED, MUST BE 2 OR LARGER.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,116)
  116 FORMAT('      SUCH WAS NOT THE CASE HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,117)N
  117 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8,
     1'.')
      CALL DPWRST('XXX','BUG ')
      GOTO9000
  119 CONTINUE
C
      HOLD=X(1)
      DO135I=2,N
      IF(X(I).NE.HOLD)GOTO139
  135 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,136)HOLD
  136 FORMAT('***** NON-FATAL DIAGNOSTIC IN BIWLOC--',
     1'THE FIRST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      XBW=HOLD
      GOTO9000
  139 CONTINUE
C
  190 CONTINUE
C
C               ***********************************************
C               **  STEP 2--                                 **
C               **  COMPUTE THE BIWEIGHT LOCATION ESTIMATE.  **
C               ***********************************************
C
      IWRIT2='OFF'
C
      DO195I=1,N
        XTEMP2(I)=X(I)
  195 CONTINUE
C
      CALL MEAN(X,N,IWRIT2,XMEAN,IBUGA3,IERROR)
CCCCC CALL MAD(X,N,IWRIT2,XTEMP,MAXNXT,XMAD,IBUGA3,IERROR)
      ITER=0
C
      DO198I=1,N
        X(I)=XTEMP2(I)
  198 CONTINUE
C
  200 CONTINUE
C
      DO205I=1,N
        XTEMP2(I)=ABS(X(I)-XMEAN)
  205 CONTINUE
      CALL MEDIAN(XTEMP2,N,IWRIT2,XTEMP,MAXNXT,XMAD,IBUGA3,IERROR)
C
      XMEANO=XMEAN
      DSUM1=0.0D0
      DSUM2=0.0D0
      DO300I=1,N
      XTEMP(I)=((X(I) - XMEAN)/(6.0*XMAD))**2
      IF(XTEMP(I).LT.1.0)THEN
        DWT=DBLE(XTEMP(I))
        DWT=(1.0D0 - DWT)**2
        DSUM1=DSUM1 + DWT*DBLE(X(I))
        DSUM2=DSUM2 + DWT
      ENDIF
  300 CONTINUE
      IF(DSUM2.NE.0.0D0)THEN
        XMEAN=REAL(DSUM1/DSUM2)
      ELSE
       XMEAN=0.0
      ENDIF
      ITER=ITER+1
      IF(ABS(XMEAN-XMEANO).GT.0.00001 .AND. ITER.LE.10)GOTO200
      XBW=XMEAN
C
C               *******************************
C               **  STEP 3--                 **
C               **  WRITE OUT A LINE         **
C               **  OF SUMMARY INFORMATION.  **
C               *******************************
C
      IF(IFEEDB.EQ.'OFF')GOTO890
      IF(IWRITE.EQ.'OFF')GOTO890
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,811)N,XBW
  811 FORMAT('THE BIWEIGHT LOCATION ESTIMATE OF THE ',I8,
     1' OBSERVATIONS = ',E15.7)
      CALL DPWRST('XXX','BUG ')
  890 CONTINUE
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'OFF')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF BIWLOC--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IBUGA3,IERROR
 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)N
 9013 FORMAT('N = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9015)XBW
 9015 FORMAT('XBW = ',E15.7)
      CALL DPWRST('XXX','BUG ')
9090  CONTINUE
C
      RETURN
      END
      SUBROUTINE BIWSCA(X,N,IWRITE,XTEMP,XTEMP2,MAXNXT,XBS,
     1IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE
C              SAMPLE BIWEIGHT SCALE ESTIMATOR
C              OF THE DATA IN THE INPUT VECTOR X.
C              THE SAMPLE BIWEIGHT LOCATION ESTIMATE IS DEFINED AS:
C                 s(bi)**2= SUM'[(y-y')**2*(1-u**2)**4]/
C                           {SUM'[1-u**2)*(1-5*u**2)]*
C                           [-1 + SUM'[(1-u**2)*(1-5*u**2)]}
C              WHERE
C                 y' = MEDIAN OF Y
C                 MAD = MEDIAN ABSOLUTE DEVIATION
C                 u(i) = (Y(i) - y')/(9*MAD)
C                 SUM' means the summation is for u**2 <= 1
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR OF
C                                (UNSORTED OR SORTED) OBSERVATIONS.
C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTOR X.
C     OUTPUT ARGUMENTS--XBS    = THE SINGLE PRECISION VALUE OF THE
C                                COMPUTED SAMPLE BIWEIGHT LOCATION
C                                ESTIMATE.
C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
C             SAMPLE BIWEIGHT LOCATION ESTIMATE.
C     OTHER DATAPLOT  SUBROUTINES NEEDED--MEAN, MAD 
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--MOSTELLER AND TUKEY, 'DATA ANALYSIS AND REGRESSION'
C                 ADDISON AND WESLEY, 1977, PP. 204-206.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2899
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2001/11
C     ORIGINAL VERSION--NOVEMBER  2001.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 IWRIT2
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
C
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DSUM2
      DOUBLE PRECISION DUI
      DOUBLE PRECISION DSBI
C
      DIMENSION X(*)
      DIMENSION XTEMP(*)
      DIMENSION XTEMP2(*)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='BIWL'
      ISUBN2='OC  '
      XBS=0.0
C
      IERROR='NO'
C
      IF(IBUGA3.EQ.'OFF')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF BIWSCA--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)IBUGA3
   52 FORMAT('IBUGA3 = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)N
   53 FORMAT('N = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO55I=1,N
      WRITE(ICOUT,56)I,X(I)
   56 FORMAT('I,X(I) = ',I8,E15.7)
      CALL DPWRST('XXX','BUG ')
   55 CONTINUE
   90 CONTINUE
C
C               ******************************************
C               **  COMPUTE BIWEIGHT SCALE ESTIMATE     **
C               ******************************************
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      AN=N
C
      IF(N.GT.1)GOTO119
      IERROR='YES'
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,111)
  111 FORMAT('***** ERROR IN BIWSCA--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,112)
  112 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,113)
  113 FORMAT('      IN THE VARIABLE FOR WHICH')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,114)
  114 FORMAT('      THE BIWEIGHT SCALE ESTIMATE IS TO BE')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,115)
  115 FORMAT('      COMPUTED, MUST BE 2 OR LARGER.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,116)
  116 FORMAT('      SUCH WAS NOT THE CASE HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,117)N
  117 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8,
     1'.')
      CALL DPWRST('XXX','BUG ')
      GOTO9000
  119 CONTINUE
C
      HOLD=X(1)
      DO135I=2,N
      IF(X(I).NE.HOLD)GOTO139
  135 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,136)HOLD
  136 FORMAT('***** NON-FATAL DIAGNOSTIC IN BIWSCA--',
     1'THE FIRST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      XBS=0.0
      GOTO9000
  139 CONTINUE
C
  190 CONTINUE
C
C               ***********************************************
C               **  STEP 2--                                 **
C               **  COMPUTE THE BIWEIGHT SCALE ESTIMATE.     **
C               ***********************************************
C
      IWRIT2='OFF'
      CALL BIWLOC(X,N,IWRIT2,XTEMP,XTEMP2,MAXNXT,XBW,IBUGA3,IERROR)
      DO205I=1,N
        XTEMP2(I)=X(I)
  205 CONTINUE
      CALL MAD(X,N,IWRIT2,XTEMP,MAXNXT,XMAD,IBUGA3,IERROR)
      DO215I=1,N
        X(I)=XTEMP2(I)
  215 CONTINUE
C
      DSUM1=0.0D0
      DSUM2=0.0D0
      DO300I=1,N
        DUI=DBLE((X(I) - XBW)/(9.0*XMAD))
        IF(DUI*DUI.LE.1.0D0)THEN
          DSUM1=DSUM1 + (DBLE(X(I)-XBW)**2)*(1.0D0 - DUI**2)**4
          DSUM2=DSUM2 + (1.0D0 - DUI**2)*(1.0D0 - 5.0D0*DUI**2)
        ENDIF
  300 CONTINUE
      DSBI=DBLE(N)*DSUM1/(DSUM2*(-1.0D0 + DSUM2))
      XBS=REAL(DSBI)
C
C               *******************************
C               **  STEP 3--                 **
C               **  WRITE OUT A LINE         **
C               **  OF SUMMARY INFORMATION.  **
C               *******************************
C
      IF(IFEEDB.EQ.'OFF')GOTO890
      IF(IWRITE.EQ.'OFF')GOTO890
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,811)N,XBS
  811 FORMAT('THE BIWEIGHT SCALE ESTIMATE OF THE ',I8,
     1' OBSERVATIONS = ',E15.7)
      CALL DPWRST('XXX','BUG ')
  890 CONTINUE
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'OFF')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF BIWSCA--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IBUGA3,IERROR
 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)N
 9013 FORMAT('N = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9015)XBS
 9015 FORMAT('XBS = ',E15.7)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE BKNOT(X,N,K,T)
C***BEGIN PROLOGUE  BKNOT
C***REFER TO  B2INK,B3INK
C***ROUTINES CALLED  (NONE)
C***END PROLOGUE  BKNOT
C
C  --------------------------------------------------------------------
C  BKNOT CHOOSES A KNOT SEQUENCE FOR INTERPOLATION OF ORDER K AT THE
C  DATA POINTS X(I), I=1,..,N.  THE N+K KNOTS ARE PLACED IN THE ARRAY
C  T.  K KNOTS ARE PLACED AT EACH ENDPOINT AND NOT-A-KNOT END
C  CONDITIONS ARE USED.  THE REMAINING KNOTS ARE PLACED AT DATA POINTS
C  IF N IS EVEN AND BETWEEN DATA POINTS IF N IS ODD.  THE RIGHTMOST
C  KNOT IS SHIFTED SLIGHTLY TO THE RIGHT TO INSURE PROPER INTERPOLATION
C  AT X(N) (SEE PAGE 350 OF THE REFERENCE).
C  --------------------------------------------------------------------
C
C  ------------
C  DECLARATIONS
C  ------------
C
C  PARAMETERS
C
      INTEGER
     *        N, K
      REAL
     *     X(N), T(*)
C
C  LOCAL VARIABLES
C
      INTEGER
     *        I, J, IPJ, NPJ, IP1
      REAL
     *     RNOT
C
C
C  ----------------------------
C  PUT K KNOTS AT EACH ENDPOINT
C  ----------------------------
C
C     (SHIFT RIGHT ENPOINTS SLIGHTLY -- SEE PG 350 OF REFERENCE)
      RNOT = X(N) + 0.10E0*( X(N)-X(N-1) )
      DO 110 J=1,K
         T(J) = X(1)
         NPJ = N + J
         T(NPJ) = RNOT
  110 CONTINUE
C
C  --------------------------
C  DISTRIBUTE REMAINING KNOTS
C  --------------------------
C
      IF (MOD(K,2) .EQ. 1)  GO TO 150
C
C     CASE OF EVEN K --  KNOTS AT DATA POINTS
C
      I = (K/2) - K
      JSTRT = K+1
      DO 120 J=JSTRT,N
         IPJ = I + J
         T(J) = X(IPJ)
  120 CONTINUE
      GO TO 200
C
C     CASE OF ODD K --  KNOTS BETWEEN DATA POINTS
C
  150 CONTINUE
      I = (K-1)/2 - K
      IP1 = I + 1
      JSTRT = K + 1
      DO 160 J=JSTRT,N
         IPJ = I + J
         T(J) = 0.50E0*( X(IPJ) + X(IPJ+1) )
  160 CONTINUE
  200 CONTINUE
C
      RETURN
      END
      SUBROUTINE BNDRY(A,BOX,IMX,JMX,IB,JB,NB)
C
C     PURPOSE--XX
C
C     WRITTEN BY--DAVID W. BEHRINGER NOAA/AOML (MIAMI).
C                 AS PART OF NOAA'S CONCX V.3   MARCH 1988.
C     ORIGINAL VERSION (IN DATAPLOT)--AUGUST    1988.
C     UPDATED         --JANUARY   1989.  MORE CHANGES TO STANDARD FORTRAN 77--
C                                        BYTE TO CHARACTER*1,
C                                        DO WHILE/END DO (ALAN HECKERT).
C     UPDATED         --JULY      1990.  999.999 TO ANINE
C     UPDATED         --JULY      1990.  ( ) AROUND ALL EXPR. ANINE
C     UPDATED         --JULY      1990.  MAJOR CHANGES
C     UPDATED         --APRIL     1992.  JO TO J0 (ALAN)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOCP.INC'
C
C---------------------------------------------------------------------
C
CCCCC BYTE BOX(4,MAXIMX,MAXJMX),SBOX     AUGUST 1988
CCCCC DIMENSION A(IMX,JMX),IB(*),JB(*)   AUGUST 1988
C
CCCCC BYTE BOX                           JANUARY 1989
CCCCC BYTE SBOX                          JANUARY 1989
      CHARACTER*1 BOX
CCCCC CHARACTER*1 SBOX
C
      DIMENSION A(MAXIMX,MAXJMX)
      DIMENSION BOX(4,MAXIMX,MAXJMX)
      DIMENSION IB(*)
      DIMENSION JB(*)
C
C-----START POINT-----------------------------------------------------
C
CCCCC THE FOLLOWING LINE WAS ADDED JULY 1990
CCCCC AND ALL SUBSEQUENT OCCURRANCES OF 999.999   JULY 1990
CCCCC WERE CHANGED TO ANINE       JULY 1990
      ANINE=999.999
C
      DO100I=1,IMX
        DO110J=1,JMX
          DO120L=1,4
            BOX(L,I,J)='0'
 120      CONTINUE
 110    CONTINUE
 100  CONTINUE
      DO200I=1,IMX
        BOX(4,I,1)='2'
        BOX(2,I,JMX-1)='2'
        DO210L=1,4
          BOX(L,I,JMX)='2'
 210    CONTINUE
 200  CONTINUE
      DO300J=1,JMX
        BOX(1,1,J)='2'
        BOX(3,IMX-1,J)='2'
        DO310L=1,4
          BOX(L,IMX,J)='2'
 310    CONTINUE
 300  CONTINUE
      DO400I=1,IMX
        DO410J=1,JMX
          IF (A(I,J).EQ.ANINE) THEN
            DO420N=1,4
              II=MAX0(1,I-N/3)
              JJ=MAX0(1,J-MOD(N/2,2))
              DO430L=1,4
                BOX(L,II,JJ)='2'
 430          CONTINUE
              III=MIN0(IMX,MAX0(1,II+1-2*(N/3)))
              JJJ=MIN0(JMX,MAX0(1,JJ+MAX0(3-2*N,2*N-7)))
              L=1+2*(N/3)
              BOX(L,III,JJ)='2'
              L=MAX0(6-2*N,2*N-4)
              BOX(L,II,JJJ)='2'
 420        CONTINUE
          END IF
 410    CONTINUE
 400  CONTINUE
      I0=0
      J0=0
      I=0
CCCCC DO WHILE (I0.EQ.0.AND.I.LT.IMX)    JANUARY 1989
 500  CONTINUE
       IF(I0.NE.0.OR.I.GE.IMX)GOTO599
        I=I+1
        J=0
CCCCC   DO WHILE (J0.EQ.0.AND.J.LT.JMX)  JANUARY 1989
 600    CONTINUE
CCCCC THE FOLLOWING LINE WAS FIXED   APRIL 1992   (ALAN)
CCCCC    IF(JO.NE.0.OR.J.GE.JMX)GOTO699
         IF(J0.NE.0.OR.J.GE.JMX)GOTO699
          J=J+1
          IF (BOX(3,I,J).EQ.'0') THEN
            I0=I
            J0=J
          END IF
          GOTO600
 699    CONTINUE
        GOTO500
 599  CONTINUE
      I=I0
      J=J0
      NB=1
      IB(NB)=I
      JB(NB)=J
      IFLG=0
      IJD=1
CCCCC DO WHILE (IFLG.EQ.0)               JANUARY 1989
 700  CONTINUE
      IF(IFLG.NE.0)GOTO799
C
        IF (IJD.EQ.1) THEN
          AMM=ANINE
          AM0=ANINE
          AMP=ANINE
          A0M=ANINE
          A00=ANINE
          A0P=ANINE
          APM=ANINE
          AP0=ANINE
          APP=ANINE
          IF(I.GT.1.AND.J.GT.1)AMM=A(I-1,J-1)
          IF(I.GT.1.AND.J.GT.0)AM0=A(I-1,J)
          IF(I.GT.1.AND.J.LT.JMX)AMP=A(I-1,J+1)
          IF(I.GT.0.AND.J.GT.1)A0M=A(I,J-1)
          IF(I.GT.0.AND.J.GT.0)A00=A(I,J)
          IF(I.GT.0.AND.J.LT.JMX)A0P=A(I,J+1)
          IF(I.LT.IMX.AND.J.GT.1)APM=A(I+1,J-1)
          IF(I.LT.IMX.AND.J.GT.0)AP0=A(I+1,J)
          IF(I.LT.IMX.AND.J.LT.JMX)APP=A(I+1,J+1)
          IF ((AM0.NE.ANINE).AND.
     1        (((AMM.NE.ANINE)).OR.
     2          ((AMP.NE.ANINE)))) THEN
            I=I-1
            IJD=4
          ELSE IF ((A0P.NE.ANINE).AND.
     1        (((AMP.NE.ANINE)).OR.
     2          ((APP.NE.ANINE)))) THEN
            J=J+1
            IJD=1
          ELSE IF ((AP0.NE.ANINE).AND.
     1        (((APM.NE.ANINE)).OR.
     2          ((APM.NE.ANINE)))) THEN
            I=I+1
            IJD=2
          END IF
C
        ELSE IF (IJD.EQ.2) THEN
          AMM=ANINE
          AM0=ANINE
          AMP=ANINE
          A0M=ANINE
          A00=ANINE
          A0P=ANINE
          APM=ANINE
          AP0=ANINE
          APP=ANINE
          IF(I.GT.1.AND.J.GT.1)AMM=A(I-1,J-1)
          IF(I.GT.1.AND.J.GT.0)AM0=A(I-1,J)
          IF(I.GT.1.AND.J.LT.JMX)AMP=A(I-1,J+1)
          IF(I.GT.0.AND.J.GT.1)A0M=A(I,J-1)
          IF(I.GT.0.AND.J.GT.0)A00=A(I,J)
          IF(I.GT.0.AND.J.LT.JMX)A0P=A(I,J+1)
          IF(I.LT.IMX.AND.J.GT.1)APM=A(I+1,J-1)
          IF(I.LT.IMX.AND.J.GT.0)AP0=A(I+1,J)
          IF(I.LT.IMX.AND.J.LT.JMX)APP=A(I+1,J+1)
          IF ((A0P.NE.ANINE).AND.
     1        (((AMP.NE.ANINE)).OR.
     2          ((APP.NE.ANINE)))) THEN
            J=J+1
            IJD=1
          ELSE IF ((AP0.NE.ANINE).AND.
     1        (((APM.NE.ANINE)).OR.
     2          ((APM.NE.ANINE)))) THEN
            I=I+1
            IJD=2
          ELSE IF ((A0M.NE.ANINE).AND.
     1        (((AMM.NE.ANINE)).OR.
     2          ((APM.NE.ANINE)))) THEN
            J=J-1
            IJD=3
          END IF
C
        ELSE IF (IJD.EQ.3) THEN
          AMM=ANINE
          AM0=ANINE
          AMP=ANINE
          A0M=ANINE
          A00=ANINE
          A0P=ANINE
          APM=ANINE
          AP0=ANINE
          APP=ANINE
          IF(I.GT.1.AND.J.GT.1)AMM=A(I-1,J-1)
          IF(I.GT.1.AND.J.GT.0)AM0=A(I-1,J)
          IF(I.GT.1.AND.J.LT.JMX)AMP=A(I-1,J+1)
          IF(I.GT.0.AND.J.GT.1)A0M=A(I,J-1)
          IF(I.GT.0.AND.J.GT.0)A00=A(I,J)
          IF(I.GT.0.AND.J.LT.JMX)A0P=A(I,J+1)
          IF(I.LT.IMX.AND.J.GT.1)APM=A(I+1,J-1)
          IF(I.LT.IMX.AND.J.GT.0)AP0=A(I+1,J)
          IF(I.LT.IMX.AND.J.LT.JMX)APP=A(I+1,J+1)
          IF ((AP0.NE.ANINE).AND.
     1        (((APM.NE.ANINE)).OR.
     2          ((APM.NE.ANINE)))) THEN
            I=I+1
            IJD=2
          ELSE IF ((A0M.NE.ANINE).AND.
     1        (((AMM.NE.ANINE)).OR.
     2          ((APM.NE.ANINE)))) THEN
            J=J-1
            IJD=3
          ELSE IF ((AM0.NE.ANINE).AND.
     1        (((AMM.NE.ANINE)).OR.
     2          ((AMP.NE.ANINE)))) THEN
            I=I-1
            IJD=4
          END IF
C
        ELSE IF (IJD.EQ.4) THEN
          AMM=ANINE
          AM0=ANINE
          AMP=ANINE
          A0M=ANINE
          A00=ANINE
          A0P=ANINE
          APM=ANINE
          AP0=ANINE
          APP=ANINE
          IF(I.GT.1.AND.J.GT.1)AMM=A(I-1,J-1)
          IF(I.GT.1.AND.J.GT.0)AM0=A(I-1,J)
          IF(I.GT.1.AND.J.LT.JMX)AMP=A(I-1,J+1)
          IF(I.GT.0.AND.J.GT.1)A0M=A(I,J-1)
          IF(I.GT.0.AND.J.GT.0)A00=A(I,J)
          IF(I.GT.0.AND.J.LT.JMX)A0P=A(I,J+1)
          IF(I.LT.IMX.AND.J.GT.1)APM=A(I+1,J-1)
          IF(I.LT.IMX.AND.J.GT.0)AP0=A(I+1,J)
          IF(I.LT.IMX.AND.J.LT.JMX)APP=A(I+1,J+1)
          IF ((A0M.NE.ANINE).AND.
     1        (((AMM.NE.ANINE)).OR.
     2          ((APM.NE.ANINE)))) THEN
            J=J-1
            IJD=3
          ELSE IF ((AM0.NE.ANINE).AND.
     1        (((AMM.NE.ANINE)).OR.
     2          ((AMP.NE.ANINE)))) THEN
            I=I-1
            IJD=4
          ELSE IF ((A0P.NE.ANINE).AND.
     1        (((AMP.NE.ANINE)).OR.
     2          ((APP.NE.ANINE)))) THEN
            J=J+1
            IJD=1
          END IF
C
        END IF
        IBNB=I
        JBNB=J
        IF (NB.GT.1) THEN
          IF (IBNB.NE.IB(NB-1).AND.JBNB.NE.JB(NB-1)) NB=NB+1
        ELSE
          NB=NB+1
        END IF
        IB(NB)=I
        JB(NB)=J
        IF (IB(NB).EQ.IB(1).AND.JB(NB).EQ.JB(1)) IFLG=1
        GOTO700
 799  CONTINUE
      RETURN
      END
      SUBROUTINE BNFAC(W,NROWW,NROW,NBANDL,NBANDU,IFLAG)
C***BEGIN PROLOGUE  BNFAC
C***REFER TO  BINT4,BINTK
C
C  BNFAC is the BANFAC routine from
C        * A Practical Guide to Splines *  by C. de Boor
C
C  Returns in  W  the lu-factorization (without pivoting) of the banded
C  matrix  A  of order  NROW  with  (NBANDL + 1 + NBANDU) bands or diag-
C  onals in the work array  W .
C
C *****  I N P U T  ******
C  W.....Work array of size  (NROWW,NROW)  containing the interesting
C        part of a banded matrix  A , with the diagonals or bands of  A
C        stored in the rows of  W , while columns of  A  correspond to
C        columns of  W . This is the storage mode used in  LINPACK  and
C        results in efficient innermost loops.
C           Explicitly,  A  has  NBANDL  bands below the diagonal
C                            +     1     (main) diagonal
C                            +   NBANDU  bands above the diagonal
C        and thus, with    MIDDLE = NBANDU + 1,
C          A(I+J,J)  is in  W(I+MIDDLE,J)  for I=-NBANDU,...,NBANDL
C                                              J=1,...,NROW .
C        For example, the interesting entries of A (1,2)-banded matrix
C        of order  9  would appear in the first  1+1+2 = 4  rows of  W
C        as follows.
C                          13 24 35 46 57 68 79
C                       12 23 34 45 56 67 78 89
C                    11 22 33 44 55 66 77 88 99
C                    21 32 43 54 65 76 87 98
C
C        All other entries of  W  not identified in this way with an en-
C        try of  A  are never referenced .
C  NROWW.....Row dimension of the work array  W .
C        must be  .GE.  NBANDL + 1 + NBANDU  .
C  NBANDL.....Number of bands of  A  below the main diagonal
C  NBANDU.....Number of bands of  A  above the main diagonal .
C
C *****  O U T P U T  ******
C  IFLAG.....Integer indicating success( = 1) or failure ( = 2) .
C     If  IFLAG = 1, then
C  W.....contains the LU-factorization of  A  into a unit lower triangu-
C        lar matrix  L  and an upper triangular matrix  U (both banded)
C        and stored in customary fashion over the corresponding entries
C        of  A . This makes it possible to solve any particular linear
C        system  A*X = B  for  X  by A
C              CALL BNSLV ( W, NROWW, NROW, NBANDL, NBANDU, B )
C        with the solution X  contained in  B  on return .
C     If  IFLAG = 2, then
C        one of  NROW-1, NBANDL,NBANDU failed to be nonnegative, or else
C        one of the potential pivots was found to be zero indicating
C        that  A  does not have an LU-factorization. This implies that
C        A  is singular in case it is totally positive .
C
C *****  M E T H O D  ******
C     Gauss elimination  W I T H O U T  pivoting is used. The routine is
C  intended for use with matrices  A  which do not require row inter-
C  changes during factorization, especially for the  T O T A L L Y
C  P O S I T I V E  matrices which occur in spline calculations.
C     The routine should not be used for an arbitrary banded matrix.
C***ROUTINES CALLED  (NONE)
C***END PROLOGUE  BNFAC
C
      INTEGER IFLAG, NBANDL, NBANDU, NROW, NROWW, I, IPK, J, JMAX, K,
     1 KMAX, MIDDLE, MIDMK, NROWM1
      REAL W(NROWW,NROW), FACTOR, PIVOT
C
C***FIRST EXECUTABLE STATEMENT  BNFAC
      IFLAG = 1
      MIDDLE = NBANDU + 1
C                         W(MIDDLE,.) CONTAINS THE MAIN DIAGONAL OF  A .
      NROWM1 = NROW - 1
      IF (NROWM1) 120, 110, 10
   10 IF (NBANDL.GT.0) GO TO 30
C                A IS UPPER TRIANGULAR. CHECK THAT DIAGONAL IS NONZERO .
      DO 20 I=1,NROWM1
        IF (W(MIDDLE,I).EQ.0.0E0) GO TO 120
   20 CONTINUE
      GO TO 110
   30 IF (NBANDU.GT.0) GO TO 60
C              A IS LOWER TRIANGULAR. CHECK THAT DIAGONAL IS NONZERO AND
C                 DIVIDE EACH COLUMN BY ITS DIAGONAL .
      DO 50 I=1,NROWM1
        PIVOT = W(MIDDLE,I)
        IF (PIVOT.EQ.0.0E0) GO TO 120
        JMAX = MIN0(NBANDL,NROW-I)
        DO 40 J=1,JMAX
          W(MIDDLE+J,I) = W(MIDDLE+J,I)/PIVOT
   40   CONTINUE
   50 CONTINUE
      RETURN
C
C        A  IS NOT JUST A TRIANGULAR MATRIX. CONSTRUCT LU FACTORIZATION
   60 DO 100 I=1,NROWM1
C                                  W(MIDDLE,I)  IS PIVOT FOR I-TH STEP .
        PIVOT = W(MIDDLE,I)
        IF (PIVOT.EQ.0.0E0) GO TO 120
C                 JMAX  IS THE NUMBER OF (NONZERO) ENTRIES IN COLUMN  I
C                     BELOW THE DIAGONAL .
        JMAX = MIN0(NBANDL,NROW-I)
C              DIVIDE EACH ENTRY IN COLUMN  I  BELOW DIAGONAL BY PIVOT .
        DO 70 J=1,JMAX
          W(MIDDLE+J,I) = W(MIDDLE+J,I)/PIVOT
   70   CONTINUE
C                 KMAX  IS THE NUMBER OF (NONZERO) ENTRIES IN ROW  I  TO
C                     THE RIGHT OF THE DIAGONAL .
        KMAX = MIN0(NBANDU,NROW-I)
C                  SUBTRACT  A(I,I+K)*(I-TH COLUMN) FROM (I+K)-TH COLUMN
C                  (BELOW ROW  I ) .
        DO 90 K=1,KMAX
          IPK = I + K
          MIDMK = MIDDLE - K
          FACTOR = W(MIDMK,IPK)
          DO 80 J=1,JMAX
            W(MIDMK+J,IPK) = W(MIDMK+J,IPK) - W(MIDDLE+J,I)*FACTOR
   80     CONTINUE
   90   CONTINUE
  100 CONTINUE
C                                       CHECK THE LAST DIAGONAL ENTRY .
  110 IF (W(MIDDLE,NROW).NE.0.0E0) RETURN
  120 IFLAG = 2
      RETURN
      END
      SUBROUTINE BNOCDF(DX,DALPHA,DBETA,DCDF)
C
C     PURPOSE   --COMPUTE THE BETA-NORMAL CDF FUNCTION
C                 THIS CDF FUNCTION IS DEFINED AS:
C                    F(X;A,B) = (1/BETA(A,B)*INTERGRAL[0 TO G(X)]
C                               [W**(A-1)*(1-W)**(B-1)dw
C                               A, B > 0
C                 WITH G(X) DENOTING A FUNCTION.  IN THIS CASE,
C                 WE TAKE G(X) TO BE THE NORMAL CDF FUNCTION.
C                 THAT IS, THIS IS ESSENTIALLY A BETA CDF, BUT
C                 WITH THE UPPER LIMIT OF INTEGRATION REPLACED WITH
C                 THE NORMAL CDF VALUE OF X.
C     REFERENCE --"HANDBOOK OF BETA DISTRIBUTION AND ITS APPLICATIONS",
C                 EDITED BY ARJUN GUPTA AND SARALEES NADARAJAH,
C                 MARCEL DEKKER INC., 2004, PP. 146-152.
C               --"BETA-NORMAL DISTRIBUTION AND ITS APPLICATIONS",
C                 EUGENE, LEE, AND FAMOYE.  COMMUNICATIONS IN
C                 STATISTICS-THEORY AND METHODS, 2002, 31, PP. 497-512.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2006/3
C     ORIGINAL VERSION--MARCH     2006.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DOUBLE PRECISION DCDF
      DOUBLE PRECISION DNOCDF
      DOUBLE PRECISION DALPHA
      DOUBLE PRECISION DBETA
      DOUBLE PRECISION DX
      DOUBLE PRECISION DBETAI
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      IF(DALPHA.LE.0.0D0)THEN
        WRITE(ICOUT,101)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,103)DALPHA
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ELSEIF(DBETA.LE.0.0D0)THEN
        WRITE(ICOUT,102)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,103)DBETA
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
  101 FORMAT('***** ERROR--FOR BNOCDF, THE ALPHA SHAPE PARAMETER IS ',
     1       'NON-POSITIVE.')
  102 FORMAT('***** ERROR--FOR BNOCDF, THE BETA SHAPE PARAMETER IS ',
     1       'NON-POSITIVE.')
  103 FORMAT('***** THE VALUE IS ',G15.7)
C
      CALL NODCDF(DX,DNOCDF)
      DCDF=DBETAI(DNOCDF,DALPHA,DBETA)
C
 9999 CONTINUE
      RETURN
      END
      DOUBLE PRECISION FUNCTION BNOFU2(DX)
C
C     PURPOSE--BNOPPF CALLS DFZERO TO FIND A ROOT FOR THE PERCENT
C              POINT FUNCTION.  BNOFU2 IS THE FUNCTION FOR WHICH
C              THE ZERO IS FOUND.  IT IS:
C                 P - BNOCDF(X,ALPHA,BETA)
C              WHERE P IS THE DESIRED PERCENT POINT.
C     INPUT  ARGUMENTS--X      = THE DOUBLE PRECISION VALUE AT
C                                WHICH THE CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C     OUTPUT--THE DOUBLE PRECISION CUMULATIVE DISTRIBUTION
C             FUNCTION VALUE BNOFU2.
C     PRINTING--NONE.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--BNOCDF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCE --"HANDBOOK OF BETA DISTRIBUTION AND ITS APPLICATIONS",
C                 EDITED BY ARJUN GUPTA AND SARALEES NADARAJAH,
C                 MARCEL DEKKER INC., 2004, PP. 146-152.
C               --"BETA-NORMAL DISTRIBUTION AND ITS APPLICATIONS",
C                 EUGENE, LEE, AND FAMOYE.  COMMUNICATIONS IN
C                 STATISTICS-THEORY AND METHODS, 2002, 31, PP. 497-512.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2006.3
C     ORIGINAL VERSION--MARCH     2006.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DCDF
C
      DOUBLE PRECISION DP
      DOUBLE PRECISION DALPHA
      DOUBLE PRECISION DBETA
      COMMON/BNOCOM/DP,DALPHA,DBETA
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      CALL BNOCDF(DX,DALPHA,DBETA,DCDF)
      BNOFU2=DP - DCDF
C
      RETURN
      END
      SUBROUTINE BNOPDF(DX,DALPHA,DBETA,DPDF)
C
C     PURPOSE   --COMPUTE THE BETA-NORMAL PDF FUNCTION
C                 THIS PDF FUNCTION IS DEFINED AS:
C                    f(X;A,B) = (1/BETA(A,B)*NORCDF(X)**(A-1)*
C                               (1-NORCDF(X))**(B-1)*NORPDF(X)
C                               A, B > 0
C                 WITH A, B, AND BETA DENOTING THE SHAPE PARAMETERS
C                 ALPHA AND BETA AND THE BETA FUNCTION, RESPECTIVELY.
C     REFERENCE --"HANDBOOK OF BETA DISTRIBUTION AND ITS APPLICATIONS",
C                 EDITED BY ARJUN GUPTA AND SARALEES NADARAJAH,
C                 MARCEL DEKKER INC., 2004, PP. 146-152.
C               --"BETA-NORMAL DISTRIBUTION AND ITS APPLICATIONS",
C                 EUGENE, LEE, AND FAMOYE.  COMMUNICATIONS IN
C                 STATISTICS-THEORY AND METHODS, 2002, 31, PP. 497-512.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2006/3
C     ORIGINAL VERSION--MARCH     2006.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DPDF
      DOUBLE PRECISION DNOCDF
      DOUBLE PRECISION DNOCD2
      DOUBLE PRECISION DNOPDF
      DOUBLE PRECISION DALPHA
      DOUBLE PRECISION DBETA
      DOUBLE PRECISION DLBETA
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
      DOUBLE PRECISION DTERM4
      DOUBLE PRECISION DEPS
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DATA DEPS/0.1D-12/
C
C-----START POINT-----------------------------------------------------
C
      IF(DALPHA.LE.0.0D0)THEN
        WRITE(ICOUT,101)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,103)DALPHA
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ELSEIF(DBETA.LE.0.0D0)THEN
        WRITE(ICOUT,102)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,103)DBETA
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
  101 FORMAT('***** ERROR--FOR BNOPDF, THE ALPHA SHAPE PARAMETER IS ',
     1       'NON-POSITIVE.')
  102 FORMAT('***** ERROR--FOR BNOPDF, THE BETA SHAPE PARAMETER IS ',
     1       'NON-POSITIVE.')
  103 FORMAT('***** THE VALUE IS ',G15.7)
C
      CALL NODPDF(DX,DNOPDF)
      CALL NODCDF(DX,DNOCDF)
      CALL NODCDF(-DX,DNOCD2)
C
C  NOTE: PDF EFFECTIVELY ZERO IMPLIES BNOPDF ALSO EFFECTIVELY ZERO.
C        ALSO NEED TO CHECK FOR CDF = 0 OR 1 (CDF=1 PRESENTS THE
C        MORE SERIOUS PROBLEM IN PRACTICE SINCE NODCDF SINCE THE
C        ROUNDING TO 1 OCCURS AT A MUCH SMALLER ABSOLUTE VALUE THAN
C        DOES ROUNDING TO 0).  SOLUTION IS TO COMPUTE THE LOG OF A
C        VERY SMALL VALUE (SET BY DPES) FOR THAT TERM.
C
      IF(DNOPDF.LE.0.0D0)THEN
        DPDF=0.0D0
      ELSEIF(DNOCDF.LE.0.0D0)THEN
        DTERM1=DLBETA(DALPHA,DBETA)
        DTERM2=(DALPHA-1.0D0)*DLOG(DEPS)
        DTERM3=0.0D0
        DPDF=DTERM2 + DTERM3 + DLOG(DNOPDF) - DTERM1
        IF(DPDF.LE.-500.0D0)THEN
          DPDF=0.0D0
        ELSE
          DPDF=DEXP(DPDF)
        ENDIF
      ELSEIF(DNOCDF.GE.1.0D0)THEN
        DTERM1=DLBETA(DALPHA,DBETA)
        DTERM2=(DALPHA-1.0D0)*DLOG(DNOCDF)
        DTERM3=(DBETA-1.0D0)*DLOG(DNOCD2)
        DPDF=DTERM2 + DTERM3 + DLOG(DNOPDF) - DTERM1
        IF(DPDF.LE.-500.0D0)THEN
          DPDF=0.0D0
        ELSE
          DPDF=DEXP(DPDF)
        ENDIF
      ELSE
        DTERM1=DLBETA(DALPHA,DBETA)
        DTERM2=(DALPHA-1.0D0)*DLOG(DNOCDF)
        DTERM3=(DBETA-1.0D0)*DLOG(DNOCD2)
        DPDF=DTERM2 + DTERM3 + DLOG(DNOPDF) - DTERM1
        IF(DPDF.LE.-500.0D0)THEN
          DPDF=0.0D0
        ELSE
          DPDF=DEXP(DPDF)
        ENDIF
      ENDIF
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE BNOPPF(DP,DALPHA,DBETA,DPPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE BETA-NORMAL DISTRIBUTION
C              WITH SHAPE PARAMETERS ALPHA AND BETA.
C              THIS DISTRIBUTION IS DEFINED FOR REAL X AND THE
C              PERCENT POINT FUNCTION IS COMPUTED BY
C              NUMERICALLY INVERTING THE CDF FUNCTION.
C     INPUT  ARGUMENTS--DP     = THE DOUBLE PRECISION VALUE AT
C                                WHICH THE PERCENT POINT
C                                FUNCTION IS TO BE EVALUATED.
C                     --DALPHA = THE FIRST SHAPE PARAMETER
C                     --DBETA  = THE SECOND SHAPE PARAMETER
C     OUTPUT ARGUMENTS--DPPF   = THE DOUBLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION PERCENT POINT FUNCTION VALUE DPPF.
C     PRINTING--NONE.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--DFZERO.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCE --"HANDBOOK OF BETA DISTRIBUTION AND ITS APPLICATIONS",
C                 EDITED BY ARJUN GUPTA AND SARALEES NADARAJAH,
C                 MARCEL DEKKER INC., 2004, PP. 146-152.
C               --"BETA-NORMAL DISTRIBUTION AND ITS APPLICATIONS",
C                 EUGENE, LEE, AND FAMOYE.  COMMUNICATIONS IN
C                 STATISTICS-THEORY AND METHODS, 2002, 31, PP. 497-512.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     ORIGINAL VERSION--MARCH     2006.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DP
      DOUBLE PRECISION DALPHA
      DOUBLE PRECISION DBETA
      DOUBLE PRECISION DPPF
C
      DOUBLE PRECISION BNOFU2
      EXTERNAL BNOFU2
C
      DOUBLE PRECISION DP2
      DOUBLE PRECISION DALPH2
      DOUBLE PRECISION DBETA2
      COMMON/BNOCOM/DP2,DALPH2,DBETA2
C
      DOUBLE PRECISION XLOW
      DOUBLE PRECISION XLOW2
      DOUBLE PRECISION XUP
      DOUBLE PRECISION XUP2
      DOUBLE PRECISION PTEMPL
      DOUBLE PRECISION PTEMPU
      DOUBLE PRECISION AE
      DOUBLE PRECISION RE
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,ALPHAMBPC,ALPHAMCPW,ALPHAMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      DPPF=0.0D0
      IF(DALPHA.LE.0.0D0)THEN
        WRITE(ICOUT,101)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,102)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,104)DALPHA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
      IF(DBETA.LE.0.0D0)THEN
        WRITE(ICOUT,103)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,102)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,104)DBETA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
  101 FORMAT('***** ERROR--THE FIRST SHAPE PARAMETER, ALPHA, TO THE')
  102 FORMAT('      BNOPPF ROUTINE IS NON-POSITIVE.')
  103 FORMAT('***** ERROR--THE SECOND SHAPE PARAMETER, BETA, TO THE')
  104 FORMAT('      THE VALUE OF THE ARGUMENT IS ',E15.7,' ******')
C
      IF(DP.LE.0.0D0.OR.DP.GE.1.0D0)THEN
         WRITE(ICOUT,61)
   61    FORMAT('***** ERROR--THE FIRST  INPUT ARGUMENT ',
     1          'TO THE BNOPPF SUBROUTINE ')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,62)
   62    FORMAT('      IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,63)DP
   63    FORMAT('      VALUE OF ARGUMENT = ',G15.7)
         CALL DPWRST('XXX','BUG ')
         GOTO9000
      ENDIF
C
C  STEP 1: FIND BRACKETING INTERVAL.  START WITH (-5,5) AND
C          INCREMENT UNITL A BRACKETING INTERVAL IS FOUND.
C
      MAXIT=1000
      XLOW2=-5.0D0
      XUP2=5.0D0
  200 CONTINUE
        CALL BNOCDF(XLOW2,DALPHA,DBETA,PTEMPL)
        CALL BNOCDF(XUP2,DALPHA,DBETA,PTEMPU)
        IF(PTEMPL.LT.DP .AND. PTEMPU.GT.DP)THEN
          XUP=XUP2
          XLOW=XLOW2
          GOTO300
        ELSEIF(PTEMPL.LT.DP .AND. PTEMPU.LT.DP)THEN
          MAXIT=MAXIT+1
          XUP2=2.0D0*XUP2
          IF(MAXIT.LE.MAXIT)GOTO200
        ELSEIF(PTEMPL.GT.DP .AND. PTEMPU.GT.DP)THEN
          MAXIT=MAXIT+1
          XLOW2=2.0D0*XLOW2
          IF(MAXIT.LE.MAXIT)GOTO200
        ENDIF
C
        WRITE(ICOUT,201)
  201   FORMAT('***** ERROR FROM BNOPPF--UNABLE TO FIND A ',
     1         'BRACKETING INTERVAL')
        CALL DPWRST('XXX','BUG ')
        GOTO9000
C
  300 CONTINUE
      AE=1.0D-8
      RE=1.0D-8
      DP2=DP
      DALPH2=DALPHA
      DBETA2=DBETA
      CALL DFZERO(BNOFU2,XLOW,XUP,XUP,RE,AE,IFLAG)
C
      DPPF=XLOW
C
      IF(IFLAG.EQ.2)THEN
C
C  NOTE: SUPPRESS THIS MESSAGE FOR NOW.
CCCCC   WRITE(ICOUT,999)
  999   FORMAT(1X)
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   WRITE(ICOUT,121)
CC111   FORMAT('***** WARNING FROM BNOPPF--')
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   WRITE(ICOUT,113)
CC113   FORMAT('      PPF VALUE MAY NOT BE COMPUTED TO DESIRED ',
CCCCC1         'TOLERANCE.')
CCCCC   CALL DPWRST('XXX','BUG ')
      ELSEIF(IFLAG.EQ.3)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,121)
  121   FORMAT('***** WARNING FROM BNOPPF--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,123)
  123   FORMAT('      PPF VALUE MAY BE NEAR A SINGULAR POINT.')
        CALL DPWRST('XXX','BUG ')
      ELSEIF(IFLAG.EQ.4)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,131)
  131   FORMAT('***** ERROR FROM BNOPPF--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,133)
  133   FORMAT('      APPROPRIATE BRACKETING INTERVAL NOT FOUND.')
        CALL DPWRST('XXX','BUG ')
      ELSEIF(IFLAG.EQ.5)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,121)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,143)
  143   FORMAT('      MAXIMUM ITERATIONS EXCEEDED.')
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE BNORAN(N,ALPHA,BETA,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE BETA-NORMAL DISTRIBUTION WITH SHAPE
C              PARAMETERS ALPHA AND BETA.  THIS DISTRIBUTION IS
C              DEFINED FOR ALL X AND HAS THE PROBABILITY DENSITY
C              FUNCTION
C                    f(X;A,B) = (1/BETA(A,B)*NORCDF(X)**(A-1)*
C                               (1-NORCDF(X))**(B-1)*NORPDF(X)
C                               A, B > 0
C                 WITH A, B, AND BETA DENOTING THE SHAPE PARAMETERS
C                 ALPHA AND BETA AND THE BETA FUNCTION, RESPECTIVELY.
C
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --ALPHA  = THE FIRST SHAPE PARAMETER FOR THE
C                                BETA-NORMAL DISTRIBUTION
C                     --BETA   = THE SECOND SHAPE PARAMETER FOR THE
C                                BETA-NORMAL DISTRIBUTION
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST N)
C                                INTO WHICH THE GENERATED
C                                RANDOM SAMPLE WILL BE PLACED.
C     OUTPUT--A RANDOM SAMPLE OF SIZE N FROM THE BETA-NORMAL
C             DISTRIBUTION WITH SHAPE PARAMETERS ALPHA AND BETA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN, NBOPPF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCE --"HANDBOOK OF BETA DISTRIBUTION AND ITS APPLICATIONS",
C                 EDITED BY ARJUN GUPTA AND SARALEES NADARAJAH,
C                 MARCEL DEKKER INC., 2004, PP. 146-152.
C               --"BETA-NORMAL DISTRIBUTION AND ITS APPLICATIONS",
C                 EUGENE, LEE, AND FAMOYE.  COMMUNICATIONS IN
C                 STATISTICS-THEORY AND METHODS, 2002, 31, PP. 497-512.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2006.3
C     ORIGINAL VERSION--MARCH     2006.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DPPF
      DIMENSION X(*)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----DATA STATEMENTS-------------------------------------------------
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)THEN
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,6)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
    5 FORMAT('***** ERROR--FOR THE BETA-NORMAL DISTRIBUTION, ',
     1       'THE REQUESTED')
    6 FORMAT('      NUMBER OF RANDOM NUMBERS WAS NON-POSITIVE.')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,'.')
      IF(ALPHA.LE.0.0)THEN
        WRITE(ICOUT,7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,17)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,48)ALPHA
        CALL DPWRST('XXX','WRIT')
        GOTO9000
      ENDIF
    7 FORMAT('***** ERROR: VALUE OF FIRST SHAPE PARAMETER (ALPHA)',
     1       ' FOR BETA-NORMAL')
   17 FORMAT('      RANDOM NUMBERS IS NON-POSITIVE.')
      IF(BETA.LE.0.0)THEN
        WRITE(ICOUT,8)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,18)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,48)BETA
        CALL DPWRST('XXX','WRIT')
        GOTO9000
      ENDIF
    8 FORMAT('***** ERROR: VALUE OF SECOND SHAPE PARAMETER (BETA)',
     1       ' FOR BETA-NORMAL')
   18 FORMAT('      RANDOM NUMBERS IS NON-POSITIVE.')
   48 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7,'.')
C
C     COMPUTE THE BETA-NORMAL RANDOM NUMBERS USING THE
C     PERCENT POINT TRANSFORMATION OF UNIFORM RANDOM NUMBERS.
C
      CALL UNIRAN(N,ISEED,X)
      NTEMP=1
      DO100I=1,N
        ATEMP=X(I)
        CALL BNOPPF(DBLE(ATEMP),DBLE(ALPHA),DBLE(BETA),DPPF)
        X(I)=REAL(DPPF)
  100 CONTINUE
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE BNSLV(W,NROWW,NROW,NBANDL,NBANDU,B)
C***BEGIN PROLOGUE  BNSLV
C***REFER TO  BINT4,BINTK
C
C  BNSLV is the BANSLV routine from
C        * A Practical Guide to Splines *  by C. de Boor
C
C  Companion routine to  BNFAC . It returns the solution  X  of the
C  linear system  A*X = B  in place of  B , given the LU-factorization
C  for  A  in the work array  W from BNFAC.
C
C *****  I N P U T  ******
C  W, NROWW,NROW,NBANDL,NBANDU.....describe the LU-factorization of a
C        banded matrix  A  of order  NROW  as constructed in  BNFAC .
C        For details, see  BNFAC .
C  B.....Right side of the system to be solved .
C
C *****  O U T P U T  ******
C  B.....Contains the solution  X , of order  NROW .
C
C *****  M E T H O D  ******
C     (With  A = L*U, as stored in  W,) the unit lower triangular system
C  L(U*X) = B  is solved for  Y = U*X, and  Y  stored in  B . Then the
C  upper triangular system  U*X = Y  is solved for  X  . The calcul-
C  ations are so arranged that the innermost loops stay within columns.
C***ROUTINES CALLED  (NONE)
C***END PROLOGUE  BNSLV
C
      INTEGER NBANDL, NBANDU, NROW, NROWW, I, J, JMAX, MIDDLE, NROWM1
      REAL W(NROWW,NROW), B(NROW)
C***FIRST EXECUTABLE STATEMENT  BNSLV
      MIDDLE = NBANDU + 1
      IF (NROW.EQ.1) GO TO 80
      NROWM1 = NROW - 1
      IF (NBANDL.EQ.0) GO TO 30
C                                 FORWARD PASS
C            FOR I=1,2,...,NROW-1, SUBTRACT  RIGHT SIDE(I)*(I-TH COLUMN
C            OF  L )  FROM RIGHT SIDE  (BELOW I-TH ROW) .
      DO 20 I=1,NROWM1
        JMAX = MIN0(NBANDL,NROW-I)
        DO 10 J=1,JMAX
          B(I+J) = B(I+J) - B(I)*W(MIDDLE+J,I)
   10   CONTINUE
   20 CONTINUE
C                                 BACKWARD PASS
C            FOR I=NROW,NROW-1,...,1, DIVIDE RIGHT SIDE(I) BY I-TH DIAG-
C            ONAL ENTRY OF  U, THEN SUBTRACT  RIGHT SIDE(I)*(I-TH COLUMN
C            OF  U)  FROM RIGHT SIDE  (ABOVE I-TH ROW).
   30 IF (NBANDU.GT.0) GO TO 50
C                                A  IS LOWER TRIANGULAR .
      DO 40 I=1,NROW
        B(I) = B(I)/W(1,I)
   40 CONTINUE
      RETURN
   50 I = NROW
   60 B(I) = B(I)/W(MIDDLE,I)
      JMAX = MIN0(NBANDU,I-1)
      DO 70 J=1,JMAX
        B(I-J) = B(I-J) - B(I)*W(MIDDLE-J,I)
   70 CONTINUE
      I = I - 1
      IF (I.GT.1) GO TO 60
   80 B(1) = B(1)/W(MIDDLE,1)
      RETURN
      END
      SUBROUTINE BOOTSS(Y1,Y2,N1,IWRITE,
     1Y3,N3,IBUGA3,ISUBRO,IERROR)
C
C     PURPOSE--CONSTRUCT A BOOTSTRAP SAMPLE
C              OF THE DATA IN Y1(.) BASED ON THE INDICES IN Y2(.).
C
C     INPUT  ARGUMENTS--Y1     = ORIGINAL SAMPLE
C                     --Y2     = BOOTSTRAP INDEX
C     OUTPUT ARGUMENTS--Y3     = BOOTSTRAP SAMPLE
C
C     NOTE--IT IS PERMISSIBLE TO HAVE THE OUTPUT VECTOR Y3(.)
C           BEING IDENTICAL TO EITHER OF THE INPUT VECTORS Y1(.) OR Y2(.)
C      NOTE--IF AN ELEMENT OF THE INPUT INDEX (Y2) IS SMALLER THAN 1
C            OR LARGER THAN N1, THEN THIS WILL BE INTERPRETED AS
C            A NON-OPERATION--THIS WILL ALLOW ONE TO FORM JACKNIFE
C            SAMPLES BY SIMPLY SETTING SOME INDEX ELEMENT TO, SAY, 0.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--89/2
C     ORIGINAL VERSION--JANUARY  1987.
C     UPDATED         --JUNE      1990. TEMPORARY ARRAYS TO GARBAGE COMMON
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGA3
      CHARACTER*4 ISUBRO
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOPA.INC'
C
      DIMENSION Y1(*)
      DIMENSION Y2(*)
      DIMENSION Y3(*)
C
      DIMENSION TEMPY1(MAXOBV)
      DIMENSION TEMPY2(MAXOBV)
CCCCC FOLLOWING LINES ADDED JUNE, 1990
      INCLUDE 'DPCOZ2.INC'
      EQUIVALENCE (G2RBAG(IGAR44),TEMPY1(1))
      EQUIVALENCE (G2RBAG(IGAR45),TEMPY2(1))
CCCCC END CHANGE
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='BOOT'
      ISUBN2='SS  '
C
      IERROR='NO'
C
      IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'OTSS')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF BOOTSS--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)IBUGA3,ISUBRO,IWRITE
   52 FORMAT('IBUGA3,ISUBRO,IWRITE = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)N1
   53 FORMAT('N1 = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO55I=1,N1
      WRITE(ICOUT,56)I,Y1(I),Y2(I)
   56 FORMAT('I,Y1(I),Y2(I) = ',I8,2E13.5)
      CALL DPWRST('XXX','BUG ')
   55 CONTINUE
   90 CONTINUE
C
C               *************************************
C               **  CONSTRUCT A  BOOTSTRAP SAMPLE  **
C               *************************************
C
C               ********************************************
C               **  STEP 11--                             **
C               **  CHECK NUMBER OF INPUT OBSERVATIONS.   **
C               ********************************************
C
      IF(N1.LT.1)GOTO1100
      GOTO1190
C
 1100 CONTINUE
      IERROR='YES'
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1151)
 1151 FORMAT('***** ERROR IN BOOTSS--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1152)
 1152 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1153)
 1153 FORMAT('      IN THE VARIABLE FOR WHICH')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1154)
 1154 FORMAT('      THE BOOTSTRAP SAMPLE IS TO BE ',
     1'CONSTUCTED')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1155)
 1155 FORMAT('      MUST BE 1 OR LARGER.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1156)
 1156 FORMAT('      SUCH WAS NOT THE CASE HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1157)N1
 1157 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8,
     1'.')
      CALL DPWRST('XXX','BUG ')
      GOTO9000
C
 1190 CONTINUE
C
      DO1200I=1,N1
      TEMPY1(I)=Y1(I)
      TEMPY2(I)=Y2(I)
 1200 CONTINUE
C
      J=0
      DO1300I=1,N1
      INDEX=TEMPY2(I)+0.1
      IF(INDEX.LT.1.OR.INDEX.GT.N1)GOTO1300
      J=J+1
      Y3(J)=TEMPY1(INDEX)
 1300 CONTINUE
      N3=J
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
C
      IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'PARI')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF BOOTSS--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IBUGA3,ISUBRO,IWRITE
 9012 FORMAT('IBUGA3,ISUBRO,IWRITE = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)IERROR
 9013 FORMAT('IERROR = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9017)N1,N3
 9017 FORMAT('N1,N3 = ',2I8)
      CALL DPWRST('XXX','BUG ')
      IF(N1.LE.0)GOTO9023
      DO9021I=1,N1
      WRITE(ICOUT,9022)I,Y1(I),Y2(I)
 9022 FORMAT('I,Y1(I),Y2(I) = ',I8,2E13.5)
      CALL DPWRST('XXX','BUG ')
 9021 CONTINUE
 9023 CONTINUE
      IF(N3.LE.0)GOTO9033
      DO9031I=1,N3
      WRITE(ICOUT,9032)I,Y3(I)
 9032 FORMAT('I,Y3(I) = ',I8,E13.5)
      CALL DPWRST('XXX','BUG ')
 9031 CONTINUE
 9033 CONTINUE
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE BPADJU(IND1,IND2,L,NRANK,NCIRQ,KOUNT,
CCCCC RENAME TO HAVE 6-CHARACTER NAME
CCCCC SUBROUTINE BP_ADJUST(IND1,IND2,L,NRANK,NCIRQ,KOUNT,
     +           ALPHA,ANGLE,K,N,M,MAXNUM,KAND1,KAND2,D,X,Y)
C
C  Updates NCIRQ and NRANK, detects the special k-dividers and stores 
C  their angles and the constant terms of their equations.
C
      INTEGER NCIRQ(N),NRANK(N),IND1(M),IND2(M)
      INTEGER KAND1(MAXNUM),KAND2(MAXNUM)
      INTEGER KOUNT,K,L,N,IV,IV1,IV2,D1,D2
      double precision X(N),Y(N),ANGLE(M),D(M)
      double precision ALPHA(MAXNUM),DUM,PI,PI2
      PI=DACOS(DBLE(-1.0))
      PI2=PI/2.0
      D1=IND1(L)
      IV1=NRANK(D1)
      D2=IND2(L)
      IV2=NRANK(D2)
      IV=NCIRQ(IV1)
      NCIRQ(IV1)=NCIRQ(IV2)
      NCIRQ(IV2)=IV
      IV=IV1
      NRANK(D1)=IV2
      NRANK(D2)=IV
	 IF (((IV1.EQ.K).AND.(IV2.EQ.(K+1)))
     +      .OR.((IV2.EQ.K).AND.(IV1.EQ.(K+1)))
     +      .OR.((IV1.EQ.(N-K)).AND.(IV2.EQ.(N-K+1))) 
     +      .OR.((IV2.EQ.(N-K)).AND.(IV1.EQ.(N-K+1)))) THEN
	    IF (ANGLE(L).LT.PI2) THEN
	       DUM=ANGLE(L)+PI2
            ELSE
	       DUM=ANGLE(L)-PI2
            ENDIF
            IF (((IV1.EQ.K).AND.(IV2.EQ.(K+1)))
     +         .OR.((IV2.EQ.K).AND.(IV1.EQ.(K+1)))) THEN
	       IF (DUM.LE.PI2) THEN
		  ALPHA(KOUNT)=ANGLE(L)+PI
               ELSE
		  ALPHA(KOUNT)=ANGLE(L)
               ENDIF
            ENDIF
	    IF (((IV1.EQ.(N-K)).AND.(IV2.EQ.(N-K+1)))
     +        .OR.((IV2.EQ.(N-K)).AND.(IV1.EQ.(N-K+1)))) THEN
	       IF (DUM.LE.PI2) THEN
		  ALPHA(KOUNT)=ANGLE(L)
               ELSE
		  ALPHA(KOUNT)=ANGLE(L)+PI
               ENDIF
            ENDIF
	    KAND1(KOUNT)=IND1(L)
	    KAND2(KOUNT)=IND2(L)
	    D(KOUNT)=DSIN(ALPHA(KOUNT))*X(IND1(L))
     +                -DCOS(ALPHA(KOUNT))*Y(IND1(L))
            KOUNT=KOUNT+1
         ENDIF
      RETURN
      END
      SUBROUTINE BPDEPT(U,V,N,X,Y,BETA,F,DPF,JLV,JRV,HDEP)
CCCCC RENAME TO 6-CHARACTER NAME
CCCCC SUBROUTINE BP_DEPTH(U,V,N,X,Y,BETA,F,DPF,JLV,JRV,HDEP)
C
C  Computes the halfspace depth of a point. This subroutine was described
C  in: Rousseeuw, P.J. and Ruts, I. (1996). Algorithm AS 307: Bivariate 
C  location depth. Applied Statistics (JRSS-C) 45, 516-526.
C
      double precision U,V,BETA(N),X(N),Y(N),DPF(N)
      double precision P,P2,EPSI,D,XU,YU,ANG,ALPHK,BETAK
      INTEGER F(N),GI,HDEP
      integer JLV(N),JRV(N)
      NUMH=0
      HDEP=0
      IF (N.LT.1) RETURN
      P=DACOS(DBLE(-1.0))
      P2=P*2.0
      EPSI=0.000001
      NZ=0
C
C  Construct the array BETA.
C

      DO 10 I=1,N
          D=DSQRT((X(I)-U)*(X(I)-U)+(Y(I)-V)*(Y(I)-V))
          IF (D.LE.EPSI) THEN
              NZ=NZ+1
          ELSE
              XU=(X(I)-U)/D
              YU=(Y(I)-V)/D
              IF (DABS(XU).GT.DABS(YU)) THEN
                  IF (X(I).GE.U) THEN
                      BETA(I-NZ)=DASIN(YU)
                      IF(BETA(I-NZ).LT.0.0) THEN
                          BETA(I-NZ)=P2+BETA(I-NZ)
                      ENDIF
                  ELSE
                      BETA(I-NZ)=P-DASIN(YU)
                  ENDIF
              ELSE
                  IF (Y(I).GE.V) THEN
                      BETA(I-NZ)=DACOS(XU)
                  ELSE
                      BETA(I-NZ)=P2-DACOS(XU)
                  ENDIF
              ENDIF
              IF (BETA(I-NZ).GE.(P2-EPSI)) BETA(I-NZ)=0.0
          ENDIF
  10  CONTINUE
      NN=N-NZ
      IF (NN.LE.1) GOTO 60
C
C  Sort the array BETA.
C
      DO 15 I=1,NN
      DPF(I)=DBLE(F(I))
15    CONTINUE
      CALL BPSORT(BETA,F,F,DPF,NN,JLV,JRV)
C
C  Check whether Z=(U,V) lies outside the data cloud.
C
      ANG=BETA(1)-BETA(NN)+P2
      DO 20 I=2,NN
          ANG=DMAX1(ANG,(BETA(I)-BETA(I-1)))
  20  CONTINUE
      IF (ANG.GT.(P+EPSI)) GOTO 60
C
C  Make smallest BETA equal to zero,
C  and compute NU = number of BETA < PI.
C
      ANG=BETA(1)
      NU=0
      DO 30 I=1,NN
          BETA(I)=BETA(I)-ANG
          IF (BETA(I).LT.(P-EPSI)) NU=NU+1
  30  CONTINUE
      IF (NU.GE.NN) GOTO 60
C
C  Mergesort the BETA with their antipodal angles,
C  and at the same time update I, F(I), and NBAD.
C
      JA=1
      JB=1
      ALPHK=BETA(1)
      BETAK=BETA(NU+1)-P
      NN2=NN*2
      NBAD=0
      I=NU
      NF=NN
      DO 40 J=1,NN2
          IF ((ALPHK+EPSI).LT.BETAK) THEN
              NF=NF+1
              IF (JA.LT.NN) THEN
                  JA=JA+1
                  ALPHK=BETA(JA)
              ELSE
                  ALPHK=P2+1.0
              ENDIF
          ELSE
              I=I+1
              IF (I.EQ.(NN+1)) THEN
                  I=1
                  NF=NF-NN
              ENDIF
              F(I)=NF
              NBAD=NBAD+NBPK((NF-I),2)
              IF (JB.LT.NN) THEN
                  JB=JB+1
                  IF ((JB+NU).LE.NN) THEN
                      BETAK=BETA(JB+NU)-P
                  ELSE
                      BETAK=BETA(JB+NU-NN)+P
                  ENDIF
              ELSE
                  BETAK=P2+1.0
              ENDIF
          ENDIF
  40  CONTINUE
C
C  Computation of NUMH for halfspace depth.
C
      GI=0
      JA=1
      ANG=BETA(1)
      NUMH=MIN0(F(1),(NN-F(1)))
      DO 50 I=2,NN
          IF(BETA(I).LE.(ANG+EPSI)) THEN
              JA=JA+1
          ELSE
              GI=GI+JA
              JA=1
              ANG=BETA(I)
          ENDIF
          KI=F(I)-GI
          NUMH=MIN0(NUMH,MIN0(KI,(NN-KI)))
   50 CONTINUE
C
C  Adjust for the number NZ of data points equal to Z=(U,V).
C
   60 NUMH=NUMH+NZ
      HDEP=NUMH
      RETURN
      END
      SUBROUTINE BPISOD(N,M,X,Y,MAXN,MAXM,MAXNUM,NRANK,D,F,BETA,
CCCCC RENAME TO 6-CHARACTER NAME
CCCCC SUBROUTINE BP_ISODEPTH(N,M,X,Y,MAXN,MAXM,MAXNUM,NRANK,D,F,BETA,
     +  KAND1,KAND2,ALPHA,IND1,IND2,NCIRQ,MCIRQ,ANGLE,KORNR,L,
     +  JRV,JLV,DPF,NUM,K,EMPTY)
C
C     Computes the depth contour of depth k. This subroutine was described
C     in: Ruts, I. and Rousseeuw, P.J. (1996). Computing depth contours of
C     bivariate point clouds. CSDA 23, 153-168.
C
      INTEGER NCIRQ(N),MCIRQ(N),NRANK(N),F(N)
      integer JLV(M),JRV(M)
      INTEGER IND1(M),IND2(M)
      INTEGER KAND1(MAXNUM),KAND2(MAXNUM),KORNR(MAXNUM,4)
      INTEGER KON,KONTROL,NDATA,NDK,HALT,halt2,jj,JFULL,EMPTY
      INTEGER IV,IW1,IW2,NEXT,JFLAG,KOUNT,NUM,tel
      INTEGER HDEP1,HDEP2,HDEP3,HDEP4,HDEP5,I,J,K,L,M,N
      double precision X(N),Y(N),BETA(N)
      double precision ANGLE(M),D(M),ALPHA(MAXNUM),DPF(N)
      double precision PI,PI2,EPS
      double precision XCORD,YCORD,ANG1,xcord1,ycord1,m1,m2
      PI=DACOS(DBLE(-1.0))
      PI2=PI/2.0
      EPS=0.0000001
      empty=0
C
C   (Re)initialize NCIRQ and NRANK.
C
      DO 45 I=1,N
	 NCIRQ(I)=MCIRQ(I)
45    CONTINUE
      DO 50 I=1,N
	 IV=NCIRQ(I)
	 NRANK(IV)=I
 50   CONTINUE
C
C  Let the line rotate from zero to ANGLE(1).
C
      KOUNT=1
      HALT=0
      if (angle(1).gt.pi2) then
         l=1
	 CALL BPADJU(IND1,IND2,L,NRANK,NCIRQ,KOUNT,ALPHA,ANGLE,
     +	                  K,N,M,MAXNUM,KAND1,KAND2,D,X,Y)
         halt=1
      endif
      L=2
 60   KONTROL=0
      IF ((PI.LE.(ANGLE(L)+PI2)).AND.((ANGLE(L)-PI2).LT.ANGLE(1))) THEN
	 CALL BPADJU(IND1,IND2,L,NRANK,NCIRQ,KOUNT,ALPHA,ANGLE,
     +	                  K,N,M,MAXNUM,KAND1,KAND2,D,X,Y)
	 KONTROL=1
      ENDIF
      L=L+1
      IF (KONTROL.EQ.1) HALT=1
      IF ((L.EQ.M+1).AND.(KONTROL.EQ.1)) THEN
	 JFLAG=1
	 GOTO 79
      ENDIF
      IF (((HALT.EQ.1).AND.(KONTROL.EQ.0)).OR.(L.EQ.M+1)) THEN
	 GOTO 70
      ELSE
	 GOTO 60
      ENDIF
 70   if (l.gt.1) then
         JFLAG=L-1
      else
         jflag=m
      endif
      J=0
C
C  In case the first switch didn't occur between zero and ANGLE(1),
C  look for it between the following angles.
C
      IF ((L.EQ.M+1).AND.(KONTROL.EQ.0)) THEN
	 HALT=0
         halt2=0
 73      J=J+1
         if (j.eq.m+1) j=1
	 L=J+1
         if (l.eq.m+1) l=1
 75      KONTROL=0
	 IF ((ANGLE(L)+PI2).LT.PI) THEN
	    ANG1=ANGLE(L)+PI2
         ELSE
	    ANG1=ANGLE(L)-PI2
         ENDIF
         if (j.eq.m) then
            jj=1
            if (halt2.eq.0) angle(1)=angle(1)+pi
         else
            jj=j+1
         endif
	 IF ((ANGLE(J).LE.ANG1).AND.(ANG1.LT.ANGLE(jj))) THEN
            if (angle(1).gt.pi) angle(1)=angle(1)-pi
	    CALL BPADJU(IND1,IND2,L,NRANK,NCIRQ,KOUNT,ALPHA,ANGLE,
     +                       K,N,M,MAXNUM,KAND1,KAND2,D,X,Y)
	    KONTROL=1
         ENDIF
         if (angle(1).gt.pi) angle(1)=angle(1)-pi
	 IF (L.NE.M) THEN
	    L=L+1
         ELSE
	    L=1
         ENDIF
	 IF (KONTROL.EQ.1) HALT=1
	 IF ((HALT.EQ.1).AND.(KONTROL.EQ.0)) THEN
            if (halt2.eq.1) goto 101
            if (l.gt.1) then
               jflag=l-1
            else
               jflag=m
            endif
	    GOTO 79
         ELSE
            IF (L.EQ.jj) THEN
               if (jj.eq.1) halt2=1
               GOTO 73
            ELSE
	       GOTO 75
            ENDIF
         ENDIF
      ENDIF
C
C  The first switch has occurred. Now start looking for the next ones,
C  between the following angles.
C
79    DO 80 I=J+1,M-1
	 L=JFLAG
 90      KONTROL=0
	 IF ((ANGLE(L)+PI2).LT.PI) THEN
	    ANG1=ANGLE(L)+PI2
         ELSE
	    ANG1=ANGLE(L)-PI2
         ENDIF
	 IF ((ANGLE(I).LE.ANG1).AND.(ANG1.LT.ANGLE(I+1))) THEN
	    CALL BPADJU(IND1,IND2,L,NRANK,NCIRQ,KOUNT,ALPHA,
     +                  ANGLE,K,N,M,MAXNUM,KAND1,KAND2,D,X,Y)
	    KONTROL=1
         ENDIF
	 IF (KONTROL.EQ.0) THEN
	    JFLAG=L
         ELSE
	    IF (L.NE.M) THEN
	       L=L+1
            ELSE
	       L=1
            ENDIF
	    GOTO 90
         ENDIF
 80   CONTINUE
      L=JFLAG
C
C  Finally, look for necessary switches between the last angle and zero.
C
100   KONTROL=0
      IF ((ANGLE(L)+PI2).LT.PI) THEN
	 ANG1=ANGLE(L)+PI2
      ELSE
	 ANG1=ANGLE(L)-PI2
      ENDIF
      IF ((ANGLE(M).LE.ANG1).AND.(ANG1.LT.PI)) THEN
	 CALL BPADJU(IND1,IND2,L,NRANK,NCIRQ,KOUNT,ALPHA,
     +               ANGLE,K,N,M,MAXNUM,KAND1,KAND2,D,X,Y)
	 KONTROL=1
      ENDIF
      IF (KONTROL.EQ.1) THEN
         IF (L.NE.M) THEN
	     L=L+1
         ELSE
	     L=1
         ENDIF
         GOTO 100
      ENDIF 
101      NUM=KOUNT-1
C  
C  Sort the NUM special k-dividers. 
C  Permute KAND1, KAND2 and D in the same way.
C
      CALL BPSORT(ALPHA,KAND1,KAND2,D,NUM,JLV,JRV)
      IW1=1
      IW2=2
      JFULL=0
      NDK=0
      tel=0

120   NDATA=0
C
C  Compute the intersection point.
C
      IF (DABS(-DSIN(ALPHA(IW2))*DCOS(ALPHA(IW1))
     +         +DSIN(ALPHA(IW1))*DCOS(ALPHA(IW2))).LT.EPS) THEN
	 IW2=IW2+1
	 IF (IW2.EQ.NUM+1) IW2=1
	 GOTO 120
      ENDIF
      XCORD=(DCOS(ALPHA(IW2))*D(IW1)-DCOS(ALPHA(IW1))*D(IW2))
     + /(-DSIN(ALPHA(IW2))*DCOS(ALPHA(IW1))
     +                   +DSIN(ALPHA(IW1))*DCOS(ALPHA(IW2)))
      YCORD=(-DSIN(ALPHA(IW2))*D(IW1)+DSIN(ALPHA(IW1))*D(IW2))
     + /(-DSIN(ALPHA(IW1))*DCOS(ALPHA(IW2))
     +                   +DSIN(ALPHA(IW2))*DCOS(ALPHA(IW1)))
C 
C  Test whether the intersection point is a data point. 
C  If so, adjust IW1 and IW2.
C
      IF ((KAND1(IW1).EQ.KAND1(IW2)).OR.(KAND1(IW1).EQ.KAND2(IW2)))
     +     NDATA=KAND1(IW1)
      IF ((KAND2(IW1).EQ.KAND1(IW2)).OR.(KAND2(IW1).EQ.KAND2(IW2)))
     +     NDATA=KAND2(IW1)
      IF (NDATA.NE.0) THEN
         iv=0
 125     NEXT=IW2+1
         iv=iv+1
         IF (NEXT.EQ.(NUM+1)) NEXT=1
         if (next.ne.iw1) then
            IF ((NDATA.EQ.KAND1(NEXT)).OR.(NDATA.EQ.KAND2(NEXT))) THEN
               IW2=IW2+1
               IF (IW2.EQ.(NUM+1)) IW2=1
               GOTO 125
            ENDIF
         endif
         if (iv.eq.(num-1)) then
            num=1
            KORNR(1,1)=KAND1(IW1)
            KORNR(1,2)=KAND2(IW1)
            KORNR(1,3)=KAND1(IW2)
            KORNR(1,4)=KAND2(IW2)
            return
         endif
      ENDIF
      IF (IW2.EQ.NUM) THEN
         KON=1
      ELSE
         KON=IW2+1
      ENDIF
      if (kon.eq.iw1) kon=kon+1
      if (kon.eq.num+1) kon=1
C
C  Test whether the intersection point lies to the left of the special 
C  k-divider which corresponds to ALPHA(KON). If so, compute its depth.
C
      IF ((DSIN(ALPHA(KON))*XCORD-DCOS(ALPHA(KON))*YCORD
     +     -D(KON)).le.eps) THEN
         
         CALL BPDEPT(XCORD,YCORD,N,X,Y,BETA,F,DPF,JLV,JRV,HDEP1)
         
         IF (HDEP1.EQ.K) NDK=1
         IF (HDEP1.NE.K) THEN
         CALL BPDEPT(XCORD-EPS*10,YCORD-EPS*10,N,X,Y,BETA,F,DPF,
     +           JLV,JRV,HDEP2)
         CALL BPDEPT(XCORD+EPS*10,YCORD+EPS*10,N,X,Y,BETA,F,DPF,
     +        JLV,JRV,HDEP3)
         CALL BPDEPT(XCORD-EPS*10,YCORD+EPS*10,N,X,Y,BETA,F,DPF,
     +        JLV,JRV,HDEP4)
         CALL BPDEPT(XCORD+EPS*10,YCORD-EPS*10,N,X,Y,BETA,F,DPF,
     +        JLV,JRV,HDEP5)
         IF ((NDK.EQ.0).AND.
     +        ((HDEP1.ge.K).OR.(HDEP2.ge.K).OR.(HDEP3.ge.K)
     +        .OR.(HDEP4.ge.K).OR.(HDEP5.ge.K))) THEN 
            NDK=1
         ENDIF
         IF ((HDEP1.LT.K).AND.(HDEP2.LT.K)
     +        .AND.(HDEP3.LT.K).AND.(HDEP4.LT.K)
     +        .AND.(HDEP5.LT.K).AND.(NDK.EQ.1)) THEN
C     
C  The intersection point is not the correct one, 
C  try the next special k-divider.
C
            IW2=IW2+1
            IF (IW2.EQ.(NUM+1)) IW2=1
            GOTO 120
         ENDIF
      ENDIF
C
C  Store IW1 and IW2 in KORNR. If KORNR has already been filled, check whether 
C  we have encountered this intersection point before.
C
      IF ((IW2.GT.IW1).AND.(JFULL.EQ.0)) THEN
         DO 130 I=IW1,IW2-1
            KORNR(I,1)=KAND1(IW1)
            KORNR(I,2)=KAND2(IW1)
            KORNR(I,3)=KAND1(IW2)
            KORNR(I,4)=KAND2(IW2)
 130     CONTINUE
      ELSE
         IF (IW2.GT.IW1) THEN
            DO 140 I=IW1,IW2-1
               IF ((KORNR(I,1).EQ.KAND1(IW1)).AND.
     +              (KORNR(I,2).EQ.KAND2(IW1)).AND.
     +              (KORNR(I,3).EQ.KAND1(IW2)).AND.
     +              (KORNR(I,4).EQ.KAND2(IW2)))
     +              THEN
		  GOTO 170
               ELSE
                  tel=tel+1
                  if (tel.gt.num*num) then
                     ndk=1
                     goto 170
                  endif
                  m1=(y(kornr(i,2))-y(kornr(i,1)))/
     +                 (x(kornr(i,2))-x(kornr(i,1)))
                  m2=(y(kornr(i,4))-y(kornr(i,3)))/
     +                 (x(kornr(i,4))-x(kornr(i,3)))
                  if (m1.ne.m2) then
                     xcord1=(m1*x(kornr(i,1))-y(kornr(i,1))-
     +                    m2*x(kornr(i,3))-y(kornr(i,3)))/(m1-m2)
                     ycord1=(m2*(m1*x(kornr(i,1))-y(kornr(i,1)))-
     +                    m1*(m2*x(kornr(i,3))-y(kornr(i,3))))/(m1-m2)
                  endif
                  if ((dabs(xcord1-xcord).le.eps).and.
     +                 (dabs(ycord1-ycord).le.eps)) then
                     goto 170
                  endif
                  
		  KORNR(I,1)=KAND1(IW1)
		  KORNR(I,2)=KAND2(IW1)
		  KORNR(I,3)=KAND1(IW2)
		  KORNR(I,4)=KAND2(IW2)
               ENDIF
 140        CONTINUE
         ELSE
            JFULL=1
            DO 150 I=IW1,NUM
               KORNR(I,1)=KAND1(IW1)
               KORNR(I,2)=KAND2(IW1)
               KORNR(I,3)=KAND1(IW2)
               KORNR(I,4)=KAND2(IW2)
 150        CONTINUE
            DO 160 I=1,IW2-1
               IF ((KORNR(I,1).EQ.KAND1(IW1)).AND.
     +              (KORNR(I,2).EQ.KAND2(IW1)).AND.
     +              (KORNR(I,3).EQ.KAND1(IW2)).AND.
     +              (KORNR(I,4).EQ.KAND2(IW2)))
     +              THEN
		  GOTO 170
               ELSE
                  tel=tel+1
                  if (tel.gt.num*num) then
                     ndk=1
                     goto 170
                  endif
                  m1=(y(kornr(i,2))-y(kornr(i,1)))/
     +                 (x(kornr(i,2))-x(kornr(i,1)))
                  m2=(y(kornr(i,4))-y(kornr(i,3)))/
     +                 (x(kornr(i,4))-x(kornr(i,3)))
                  if (m1.ne.m2) then
                     xcord1=(m1*x(kornr(i,1))-y(kornr(i,1))-
     +                    m2*x(kornr(i,3))-y(kornr(i,3)))/(m1-m2)
                     ycord1=(m2*(m1*x(kornr(i,1))-y(kornr(i,1)))-
     +                    m1*(m2*x(kornr(i,3))-y(kornr(i,3))))/(m1-m2)
                  endif
                  if ((dabs(xcord1-xcord).le.eps).and.
     +                 (dabs(ycord1-ycord).le.eps)) then
                     goto 170
                  endif
                  
		  KORNR(I,1)=KAND1(IW1)
		  KORNR(I,2)=KAND2(IW1)
		  KORNR(I,3)=KAND1(IW2)
		  KORNR(I,4)=KAND2(IW2)
               ENDIF
 160        CONTINUE
         ENDIF
      ENDIF
      ELSE
C     
C  The intersection point is not the correct one, 
C  try the next special k-divider.
C
	 IW2=IW2+1
	 IF (IW2.EQ.(NUM+1)) IW2=1
	 GOTO 120
      ENDIF
C
C  Look for the next vertex of the convex figure.
C
      IW1=IW2
      IW2=IW2+1
      IF (IW2.EQ.(NUM+1)) IW2=1
      GOTO 120
170   if (ndk.eq.0) empty=1
      RETURN
      END
      subroutine bprdra(a,ntot,seed,n)
CCCCC RENAME TO 6-CHARACTER NAME
CCCCC subroutine bp_rdraw(a,ntot,seed,n)
C
C     Draws n elements out of a dataset of size ntot, such that
C     the selected case numbers are uniformly distributed from 1 to ntot.
C
	integer a(n)
	integer seed,nrand
        real xjunk(1)
        double precision urand
	jndex=0
	do 20 m=1,n
CCCCC     call bp_uniran(1,seed,urand)
          call uniran(1,seed,xjunk)
          urand=dble(xjunk(1))
	  nrand=int(urand*(ntot-jndex))+1 
	  jndex=jndex+1
	  if(jndex.eq.1) then
	    a(jndex)=nrand
	  else
	    a(jndex)=nrand+jndex-1
	    do 5 i=1,jndex-1
	      if(a(i).gt.nrand+i-1) then
	        do 6 j=jndex,i+1,-1
	          a(j)=a(j-1)
 6              continue
	        a(i)=nrand+i-1
	        goto 20
	      endif
 5          continue
	  endif
 20     continue
	return
	end
      SUBROUTINE BPSORT(B,I1,I2,R,N,JLV,JRV)
CCCCC RENAME TO USE 6 CHARACTER NAME
CCCCC SUBROUTINE BP_SORT(B,I1,I2,R,N,JLV,JRV)
C
C  Sorts a double precision  array B of length N and permutes two
C  integer arrays I1 and I2 and one double precision array R in the
C  same way.
C
      INTEGER N,I1(*),I2(*),H1,H2
      double precision B(*),XX,AMM
      double precision R(*),H3
      integer JLV(*),JRV(*)
      JSS=1
      JLV(1)=1
      JRV(1)=N
 10   JNDL=JLV(JSS)
      JR=JRV(JSS)
      JSS=JSS-1
 20   JNC=JNDL
      J=JR
      JTWE=(JNDL+JR)/2
      XX=B(JTWE)
 30   IF (B(JNC).GE.XX) GOTO 40
      JNC=JNC+1
      GOTO 30
 40   IF (XX.GE.B(J)) GOTO 50
      J=J-1
      GOTO 40
 50   IF (JNC.GT.J) GOTO 60
      AMM=B(JNC)
      H1=I1(JNC)
      H2=I2(JNC)
      H3=R(JNC) 
      B(JNC)=B(J)
      I1(JNC)=I1(J)
      I2(JNC)=I2(J)
      R(JNC)=R(J)
      B(J)=AMM
      I1(J)=H1
      I2(J)=H2
      R(J)=H3
      JNC=JNC+1
      J=J-1
 60   IF (JNC.LE.J) GOTO 30
      IF ((J-JNDL).LT.(JR-JNC)) GOTO 80
      IF (JNDL.GE.J) GOTO 70
      JSS=JSS+1
      JLV(JSS)=JNDL
      JRV(JSS)=J
 70   JNDL=JNC
      GOTO 100
 80   IF (JNC.GE.JR) GOTO 90
      JSS=JSS+1
      JLV(JSS)=JNC
      JRV(JSS)=JR
 90   JR=J
100   IF (JNDL.LT.JR) GOTO 20
      IF (JSS.NE.0) GOTO 10
      RETURN
      END
      SUBROUTINE BRACDF(X,BETA,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE BRADFORD
C              DISTRIBUTION WITH SINGLE PRECISION 
C              TAIL LENGTH PARAMETER = BETA.
C              THE BRADFORD DISTRIBUTION USED
C              HEREIN IS DEFINED FOR 0 < x < 1.
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C              F(X) = [BETA / LOG(1+BETA)]*(1/(1+BETA*X))
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE 
C                                AT WHICH THE CUMULATIVE DISTRIBUTION 
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE GREATER THAN
C                                OR EQUAL TO 1.
C                     --BETA  = THE SINGLE PRECISION VALUE 
C                                OF THE TAIL LENGTH PARAMETER.
C                                BETA SHOULD BE POSITIVE.
C     OUTPUT ARGUMENTS--CDF    = THE SINGLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE CDF FOR THE BRADFORD
C             DISTRIBUTION WITH TAIL LENGTH PARAMETER VALUE = BETA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 
C     RESTRICTIONS--BETA SHOULD BE POSITIVE.
C                 --X SHOULD BE POSITIVE AND LESS THAN 1.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN. 
C     REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--2, 2ND. ED., 1994, PAGE 347.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE:  301-975-2855
C     ORIGINAL VERSION--FEBRUARY  1995. 
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DB
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DCDF
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(X.LE.0.0.OR.X.GE.1.0)THEN
        WRITE(ICOUT,4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9999
      ENDIF
    4 FORMAT('***** FATAL DIAGNOSTIC--THE FIRST  INPUT ARGUMENT ',
     1'TO BRACDF IS OUTSIDE THE (0,1) INTERVAL')
      IF(BETA.LE.-1.0)THEN
        WRITE(ICOUT,15) 
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)BETA
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9999
      ENDIF
   15 FORMAT('***** FATAL DIAGNOSTIC--THE SECOND INPUT ARGUMENT ',
     1'TO BRACDF IS LESS THAN OR EQUAL TO -1')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
C-----START POINT-----------------------------------------------------
C
      DX=DBLE(X)
      DB=DBLE(BETA)
      IF(DB.LE.0.0D0)THEN
        DCDF=DLOG(1.0D0+DB*DX)/DLOG(1.0D0+DB)
        CDF=SNGL(DCDF)
      ELSE
        DTERM1=DLOG(DLOG(1.0D0+DB*DX))-DLOG(DLOG(1.0D0+DB))
        IF(DTERM1.GE.-65.0D0)THEN
          DCDF=DEXP(DTERM1)
          CDF=SNGL(DCDF)
        ELSE
          CDF=0.0
        ENDIF
      ENDIF
C
 9999 CONTINUE
      RETURN
      END 
      SUBROUTINE BRAPDF(X,BETA,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE BRADFORD
C              DISTRIBUTION WITH SINGLE PRECISION 
C              TAIL LENGTH PARAMETER = BETA.
C              THE BRADFORD DISTRIBUTION USED
C              HEREIN IS DEFINED FOR 0 < x < 1.
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C              F(X) = [BETA / LOG(1+BETA)]*(1/(1+BETA*X))
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE 
C                                AT WHICH THE PROBABILITY DENSITY 
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE GREATER THAN
C                                OR EQUAL TO 1.
C                     --BETA  = THE SINGLE PRECISION VALUE 
C                                OF THE TAIL LENGTH PARAMETER.
C                                BETA SHOULD BE POSITIVE.
C     OUTPUT ARGUMENTS--PDF    = THE SINGLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE PDF FOR THE BRADFORD
C             DISTRIBUTION WITH TAIL LENGTH PARAMETER VALUE = BETA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 
C     RESTRICTIONS--BETA SHOULD BE POSITIVE.
C                 --X SHOULD BE POSITIVE AND LESS THAN 1.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN. 
C     REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--2, 2ND. ED., 1994, PAGE 347.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE:  301-975-2855
C     ORIGINAL VERSION--FEBRUARY  1995. 
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DB
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DPDF
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(X.LE.0.0.OR.X.GE.1.0)THEN
        WRITE(ICOUT,4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ENDIF
    4 FORMAT('***** FATAL DIAGNOSTIC--THE FIRST  INPUT ARGUMENT ',
     1'TO BRAPDF IS OUTSIDE THE (0,1) INTERVAL')
      IF(BETA.LE.-1.0)THEN
        WRITE(ICOUT,15) 
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)BETA
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ENDIF
   15 FORMAT('***** FATAL DIAGNOSTIC--THE SECOND INPUT ARGUMENT ',
     1'TO BRAPDF IS LESS THAN OR EQUAL TO -1')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
C-----START POINT-----------------------------------------------------
C
      DX=DBLE(X)
      DB=DBLE(BETA)
      IF(DB.LE.0.0D0)THEN
        DPDF=DB/(DLOG(1.0D0+DB)*(1.0D0+DB*DX))
        PDF=SNGL(DPDF)
      ELSE
        DTERM1=DLOG(DB)-DLOG(DLOG(1.0D0+DB))-DLOG(1.0D0+DB*DX)
        IF(DTERM1.GE.-65.0D0)THEN
          DPDF=DEXP(DTERM1)
          PDF=SNGL(DPDF)
        ELSE
          PDF=0.0
        ENDIF
      ENDIF
C
 9999 CONTINUE
      RETURN
      END 
      SUBROUTINE BRAPPF(P,BETA,PPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE BRADFORD
C              DISTRIBUTION WITH SINGLE PRECISION 
C              TAIL LENGTH PARAMETER = BETA.
C              THE BRADFORD DISTRIBUTION USED
C              HEREIN IS DEFINED FOR 0 < x < 1.
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C              F(X) = [BETA / LOG(1+BETA)]*(1/(1+BETA*X))
C     INPUT  ARGUMENTS--P      = THE SINGLE PRECISION VALUE
C                                (BETWEEN 0.0 (INCLUSIVELY)
C                                AND 1.0 (EXCLUSIVELY))
C                                AT WHICH THE PERCENT POINT
C                                FUNCTION IS TO BE EVALUATED.
C                     --BETA  = THE SINGLE PRECISION VALUE
C                                OF THE TAIL LENGTH PARAMETER.
C                                BETA SHOULD BE POSITIVE.
C     OUTPUT ARGUMENTS--PPF    = THE SINGLE PRECISION PERCENT
C                                POINT FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PERCENT POINT FUNCTION .
C             VALUE PPF FOR THE BRADFORD DISTRIBUTION
C             WITH TAIL LENGTH PARAMETER VALUE = BETA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--BETA SHOULD BE POSITIVE.
C                 --P SHOULD BE BETWEEN 0.0 (INCLUSIVELY)
C                   AND 1.0 (EXCLUSIVELY).
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--2, 2ND. ED., 1994, PAGE 347.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--96.2
C     ORIGINAL VERSION--FEBRUARY  1996.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DP
      DOUBLE PRECISION DB
      DOUBLE PRECISION DPPF
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(P.LE.0.0.OR.P.GE.1.0)THEN
        WRITE(ICOUT,1)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)P
        CALL DPWRST('XXX','BUG ')
        PPF=0.0
        GOTO9999
      ENDIF
    1 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ',
     1'BRAPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL')
      IF(BETA.LE.-1.0)THEN
        WRITE(ICOUT,15) 
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)BETA
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ENDIF
   15 FORMAT('***** FATAL DIAGNOSTIC--THE SECOND INPUT ARGUMENT ',
     1'TO BRAPPF IS LESS THAN OR EQUAL TO -1')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
      DP=DBLE(P)
      DB=DBLE(BETA)
      DPPF=(DEXP(DLOG(1.0D0+DB)*DP)-1.0D0)/DB
      PPF=SNGL(DPPF)
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE BRARAN(N,BETA,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE BRADFORD DISTRIBUTION
C              WITH SHAPE PARAMETER VALUE = BETA.
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --BETA  = THE SINGLE PRECISION VALUE OF THE
C                                SHAPE PARAMETER.
C                                BETA SHOULD BE POSITIVE.
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST N)
C                                INTO WHICH THE GENERATED
C                                RANDOM SAMPLE WILL BE PLACED.
C     OUTPUT--A RANDOM SAMPLE OF SIZE N
C             FROM THE BRADFORD DISTRIBUTION
C             WITH SHAPE PARAMETER VALUE = BETA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C                 --BETA SHOULD BE POSITIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--XX
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2001.10
C     ORIGINAL VERSION--OCTOBER   2001.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)THEN
        WRITE(ICOUT, 5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
      IF(BETA.LE.0.0)THEN
        WRITE(ICOUT,15)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)BETA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
    5 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ',
     1'BRARAN SUBROUTINE IS NON-POSITIVE *****')
   15 FORMAT('***** FATAL ERROR--THE 2ND INPUT ARGUMENT TO THE ',
     1'BRARAN SUBROUTINE IS NON-POSITIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
C
C     GENERATE N UNIFORM (0,1) RANDOM NUMBERS;
C
      CALL UNIRAN(N,ISEED,X)
C
C     GENERATE N BRADFORD DISTRIBUTION RANDOM NUMBERS
C     USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD.
C
      DO100I=1,N
        CALL BRAPPF(X(I),BETA,XTEMP)
        X(I)=XTEMP
  100 CONTINUE
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE BSINIT(NDIM, W, LENRUL, G)
*
*     For initializing basic rule weights and symmetric sum parameters.
*
      INTEGER NDIM, LENRUL, RULPTS(6), I, J, NUMNUL, SDIM
      PARAMETER ( NUMNUL = 4, SDIM = 12 )
      DOUBLE PRECISION W(LENRUL,4), G(NDIM,LENRUL) 
      DOUBLE PRECISION LAM1, LAM2, LAM3, LAMP, RULCON
*
*     The following code determines rule parameters and weights for a
*      degree 7 rule (W(1,1),...,W(5,1)), two degree 5 comparison rules
*      (W(1,2),...,W(5,2) and W(1,3),...,W(5,3)) and a degree 3 
*      comparison rule (W(1,4),...W(5,4)).
*
*       If NDIM = 1, then LENRUL = 5 and total points = 9.
*       If NDIM < SDIM, then LENRUL = 6 and
*                      total points = 1+2*NDIM*(NDIM+2)+2**NDIM.
*       If NDIM > = SDIM, then LENRUL = 6 and
*                      total points = 1+2*NDIM*(1+2*NDIM).
*
      DO 100 I = 1,LENRUL
         DO 200 J = 1,NDIM
            G(J,I) = 0
  200    CONTINUE
         DO 300 J = 1,NUMNUL
            W(I,J) = 0
  300    CONTINUE
  100 CONTINUE
      RULPTS(5) = 2*NDIM*(NDIM-1)
      RULPTS(4) = 2*NDIM
      RULPTS(3) = 2*NDIM
      RULPTS(2) = 2*NDIM
      RULPTS(1) = 1
      LAMP = 0.85
      LAM3 = 0.4707
      LAM2 = 4/(15 - 5/LAM3)
      W(5,1) = ( 3 - 5*LAM3 )/( 180*(LAM2-LAM3)*LAM2**2 )
      IF ( NDIM .LT. SDIM ) THEN 
         LAM1 = 8*LAM3*(31*LAM3-15)/( (3*LAM3-1)*(5*LAM3-3)*35 )
         W(LENRUL,1) = 1/(3*LAM3)**3/2**NDIM
      ELSE
         LAM1 = ( LAM3*(15 - 21*LAM2) + 35*(NDIM-1)*(LAM2-LAM3)/9 )
     &       /  ( LAM3*(21 - 35*LAM2) + 35*(NDIM-1)*(LAM2/LAM3-1)/9 )
         W(6,1) = 1/(4*(3*LAM3)**3)
      ENDIF
      W(3,1) = ( 15 - 21*(LAM3+LAM1) + 35*LAM3*LAM1 )
     &     /( 210*LAM2*(LAM2-LAM3)*(LAM2-LAM1) ) - 2*(NDIM-1)*W(5,1)
      W(2,1) = ( 15 - 21*(LAM3+LAM2) + 35*LAM3*LAM2 )
     &     /( 210*LAM1*(LAM1-LAM3)*(LAM1-LAM2) )
      IF ( NDIM .LT. SDIM ) THEN
         RULPTS(LENRUL) = 2**NDIM
         LAM3 = SQRT(LAM3)
         DO 400 I = 1,NDIM
            G(I,LENRUL) = LAM3
  400    CONTINUE
      ELSE
         W(6,1) = 1/(4*(3*LAM3)**3)
         RULPTS(6) = 2*NDIM*(NDIM-1)
         LAM3 = SQRT(LAM3)
         DO 500 I = 1,2
            G(I,6) = LAM3
  500    CONTINUE
      ENDIF
      IF ( NDIM .GT. 1 ) THEN
         W(5,2) = 1/(6*LAM2)**2 
         W(5,3) = 1/(6*LAM2)**2 
      ENDIF
      W(3,2) = ( 3 - 5*LAM1 )/( 30*LAM2*(LAM2-LAM1) ) 
     &     - 2*(NDIM-1)*W(5,2) 
      W(2,2) = ( 3 - 5*LAM2 )/( 30*LAM1*(LAM1-LAM2) )
      W(4,3) = ( 3 - 5*LAM2 )/( 30*LAMP*(LAMP-LAM2) )
      W(3,3) = ( 3 - 5*LAMP )/( 30*LAM2*(LAM2-LAMP) ) 
     &     - 2*(NDIM-1)*W(5,3)
      W(2,4) = 1/(6*LAM1)
      LAMP = SQRT(LAMP)
      LAM2 = SQRT(LAM2)
      LAM1 = SQRT(LAM1)
      G(1,2) = LAM1
      G(1,3) = LAM2
      G(1,4) = LAMP
      IF ( NDIM .GT. 1 ) THEN
         G(1,5) = LAM2
         G(2,5) = LAM2
      ENDIF
      DO 600 J = 1, NUMNUL
         W(1,J) = 1
         DO 700 I = 2,LENRUL
            W(1,J) = W(1,J) - RULPTS(I)*W(I,J)
  700    CONTINUE
  600 CONTINUE
      RULCON = 2
      CALL RULNRM( LENRUL, NUMNUL, RULPTS, W, RULCON )
C
      RETURN
      END
      SUBROUTINE BSPVN(T,JHIGH,K,INDEX,X,ILEFT,VNIKX,WORK,IWORK)
C***BEGIN PROLOGUE  BSPVN
C***DATE WRITTEN   800901   (YYMMDD)
C***REVISION DATE  820801   (YYMMDD)
C***CATEGORY NO.  E3,K6
C***KEYWORDS  B-SPLINE,DATA FITTING,INTERPOLATION,SPLINE
C***AUTHOR  AMOS, D. E., (SNLA)
C***PURPOSE  Calculates the value of all (possibly) nonzero basis
C            functions at X.
C***DESCRIPTION
C
C     Written by Carl de Boor and modified by D. E. Amos
C
C     Reference
C         SIAM J. Numerical Analysis, 14, No. 3, June, 1977, pp.441-472.
C
C     Abstract
C         BSPVN is the BSPLVN routine of the reference.
C
C         BSPVN calculates the value of all (possibly) nonzero basis
C         functions at X of order MAX(JHIGH,(J+1)*(INDEX-1)), where
C         T(K) .LE. X .LE. T(N+1) and J=IWORK is set inside the routine
C         on the first call when INDEX=1.  ILEFT is such that T(ILEFT)
C         .LE. X .LT. T(ILEFT+1).  A call to INTRV(T,N+1,X,ILO,ILEFT,
C         MFLAG) produces the proper ILEFT.  BSPVN calculates using the
C         basic algorithm needed in BSPVD.  If only basis functions are
C         desired, setting JHIGH=K and INDEX=1 can be faster than
C         calling BSPVD, but extra coding is required for derivatives
C         (INDEX=2) and BSPVD is set up for this purpose.
C
C         Left limiting values are set up as described in BSPVD.
C
C     Description of Arguments
C         Input
C          T       - knot vector of length N+K, where
C                    N = number of B-spline basis functions
C                    N = sum of knot multiplicities-K
C          JHIGH   - order of B-spline, 1 .LE. JHIGH .LE. K
C          K       - highest possible order
C          INDEX   - INDEX = 1 gives basis functions of order JHIGH
C                          = 2 denotes previous entry with WORK, IWORK
C                              values saved for subsequent calls to
C                              BSPVN.
C          X       - argument of basis functions,
C                    T(K) .LE. X .LE. T(N+1)
C          ILEFT   - largest integer such that
C                    T(ILEFT) .LE. X .LT. T(ILEFT+1)
C
C         Output
C          VNIKX   - vector of length K for spline values.
C          WORK    - a work vector of length 2*K
C          IWORK   - a work parameter.  Both WORK and IWORK contain
C                    information necessary to continue for INDEX = 2.
C                    When INDEX = 1 exclusively, these are scratch
C                    variables and can be used for other purposes.
C
C     Error Conditions
C         Improper input is a fatal error.
C***REFERENCES  C. DE BOOR, *PACKAGE FOR CALCULATING WITH B-SPLINES*,
C                 SIAM JOURNAL ON NUMERICAL ANALYSIS, VOLUME 14, NO. 3,
C                 JUNE 1977, PP. 441-472.
C***ROUTINES CALLED  XERROR
C***END PROLOGUE  BSPVN
C
C
      INTEGER ILEFT, IMJP1, INDEX, IPJ, IWORK, JHIGH, JP1, JP1ML, K, L
      REAL T, VM, VMPREV, VNIKX, WORK, X
C     DIMENSION T(ILEFT+JHIGH)
      DIMENSION T(*), VNIKX(K), WORK(*)
C     CONTENT OF J, DELTAM, DELTAP IS EXPECTED UNCHANGED BETWEEN CALLS.
C     WORK(I) = DELTAP(I), WORK(K+I) = DELTAM(I), I = 1,K
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C***FIRST EXECUTABLE STATEMENT  BSPVN
      IF(K.LT.1) GO TO 90
      IF(JHIGH.GT.K .OR. JHIGH.LT.1) GO TO 100
      IF(INDEX.LT.1 .OR. INDEX.GT.2) GO TO 105
      IF(X.LT.T(ILEFT) .OR. X.GT.T(ILEFT+1)) GO TO 110
      GO TO (10, 20), INDEX
   10 IWORK = 1
      VNIKX(1) = 1.0E0
      IF (IWORK.GE.JHIGH) GO TO 40
C
   20 IPJ = ILEFT + IWORK
      WORK(IWORK) = T(IPJ) - X
      IMJP1 = ILEFT - IWORK + 1
      WORK(K+IWORK) = X - T(IMJP1)
      VMPREV = 0.0E0
      JP1 = IWORK + 1
      DO 30 L=1,IWORK
        JP1ML = JP1 - L
        VM = VNIKX(L)/(WORK(L)+WORK(K+JP1ML))
        VNIKX(L) = VM*WORK(L) + VMPREV
        VMPREV = VM*WORK(K+JP1ML)
   30 CONTINUE
      VNIKX(JP1) = VMPREV
      IWORK = JP1
      IF (IWORK.LT.JHIGH) GO TO 20
C
   40 RETURN
C
C
   90 CONTINUE
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,91)
      CALL DPWRST('XXX','BUG ')
   91 FORMAT('***** FROM BSPVN,  K DOES NOT SATISFY K.GE.1 *****')
      RETURN
  100 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,101)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,102)
      CALL DPWRST('XXX','BUG ')
  101 FORMAT('***** FROM BSPVN,  JHIGH DOES NOT SATISFY ')
  102 FORMAT('      1.LE.JHIGH.LE.K                     ******')
      RETURN
  105 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,106)
      CALL DPWRST('XXX','BUG ')
  106 FORMAT('***** FROM BSPVN, INDEX IS NOT 1 OR 2 *****')
      RETURN
  110 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,111)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,112)
      CALL DPWRST('XXX','BUG ')
  111 FORMAT('***** FROM BSPVN,  X DOES NOT SATISFY ')
  112 FORMAT('      T(ILEFT).LE.X.LE.T(ILEFT+1)     *****')
      RETURN
      END
      SUBROUTINE BTPCF(X,N,FCN,LDF,NF,T,K,BCOEF,WORK)
C***BEGIN PROLOGUE  BTPCF
C***REFER TO  B2INK,B3INK
C***ROUTINES CALLED  BINTK,BNSLV
C***END PROLOGUE  BTPCF
C
C  -----------------------------------------------------------------
C  BTPCF COMPUTES B-SPLINE INTERPOLATION COEFFICIENTS FOR NF SETS
C  OF DATA STORED IN THE COLUMNS OF THE ARRAY FCN. THE B-SPLINE
C  COEFFICIENTS ARE STORED IN THE ROWS OF BCOEF HOWEVER.
C  EACH INTERPOLATION IS BASED ON THE N ABCISSA STORED IN THE
C  ARRAY X, AND THE N+K KNOTS STORED IN THE ARRAY T. THE ORDER
C  OF EACH INTERPOLATION IS K. THE WORK ARRAY MUST BE OF LENGTH
C  AT LEAST 2*K*(N+1).
C  -----------------------------------------------------------------
C
C  ------------
C  DECLARATIONS
C  ------------
C
C  PARAMETERS
C
      INTEGER
     *        N, LDF, K
      REAL
     *     X(N), FCN(LDF,NF), T(*), BCOEF(NF,N), WORK(*)
C
C  LOCAL VARIABLES
C
      INTEGER
     *        I, J, K1, K2, IQ, IW
C
C  ---------------------------------------------
C  CHECK FOR NULL INPUT AND PARTITION WORK ARRAY
C  ---------------------------------------------
C
C***FIRST EXECUTABLE STATEMENT
      IF (NF .LE. 0)  GO TO 500
      K1 = K - 1
      K2 = K1 + K
      IQ = 1 + N
      IW = IQ + K2*N+1
C
C  -----------------------------
C  COMPUTE B-SPLINE COEFFICIENTS
C  -----------------------------
C
C
C   FIRST DATA SET
C
      CALL BINTK(X,FCN,T,N,K,WORK,WORK(IQ),WORK(IW))
      DO 20 I=1,N
         BCOEF(1,I) = WORK(I)
   20 CONTINUE
C
C  ALL REMAINING DATA SETS BY BACK-SUBSTITUTION
C
      IF (NF .EQ. 1)  GO TO 500
      DO 100 J=2,NF
         DO 50 I=1,N
            WORK(I) = FCN(I,J)
   50    CONTINUE
         CALL BNSLV(WORK(IQ),K2,N,K1,K1,WORK)
         DO 60 I=1,N
            BCOEF(J,I) = WORK(I)
   60    CONTINUE
  100 CONTINUE
C
C  ----
C  EXIT
C  ----
C
  500 CONTINUE
      RETURN
      END
      FUNCTION BVALU(T,A,N,K,IDERIV,X,INBV,WORK)
C***BEGIN PROLOGUE  BVALU
C***DATE WRITTEN   800901   (YYMMDD)
C***REVISION DATE  820801   (YYMMDD)
C***CATEGORY NO.  E3,K6
C***KEYWORDS  B-SPLINE,DATA FITTING,INTERPOLATION,SPLINE
C***AUTHOR  AMOS, D. E., (SNLA)
C***PURPOSE  Evaluates the B-representation of a B-spline at X for the
C            function value or any of its derivatives.
C***DESCRIPTION
C
C     Written by Carl de Boor and modified by D. E. Amos
C
C     Reference
C         SIAM J. Numerical Analysis, 14, No. 3, June, 1977, pp.441-472.
C
C     Abstract
C         BVALU is the BVALUE function of the reference.
C
C         BVALU evaluates the B-representation (T,A,N,K) of a B-spline
C         at X for the function value on IDERIV = 0 or any of its
C         derivatives on IDERIV = 1,2,...,K-1.  Right limiting values
C         (right derivatives) are returned except at the right end
C         point X=T(N+1) where left limiting values are computed.  The
C         spline is defined on T(K) .LE. X .LE. T(N+1).  BVALU returns
C         a fatal error message when X is outside of this interval.
C
C         To compute left derivatives or left limiting values at a
C         knot T(I), replace N by I-1 and set X=T(I), I=K+1,N+1.
C
C         BVALU calls INTRV
C
C     Description of Arguments
C         Input
C          T       - knot vector of length N+K
C          A       - B-spline coefficient vector of length N
C          N       - number of B-spline coefficients
C                    N = sum of knot multiplicities-K
C          K       - order of the B-spline, K .GE. 1
C          IDERIV  - order of the derivative, 0 .LE. IDERIV .LE. K-1
C                    IDERIV=0 returns the B-spline value
C          X       - argument, T(K) .LE. X .LE. T(N+1)
C          INBV    - an initialization parameter which must be set
C                    to 1 the first time BVALU is called.
C
C         Output
C          INBV    - INBV contains information for efficient process-
C                    ing after the initial call and INBV must not
C                    be changed by the user.  Distinct splines require
C                    distinct INBV parameters.
C          WORK    - work vector of length 3*K.
C          BVALU   - value of the IDERIV-th derivative at X
C
C     Error Conditions
C         An improper input is a fatal error
C***REFERENCES  C. DE BOOR, *PACKAGE FOR CALCULATING WITH B-SPLINES*,
C                 SIAM JOURNAL ON NUMERICAL ANALYSIS, VOLUME 14, NO. 3,
C                 JUNE 1977, PP. 441-472.
C***ROUTINES CALLED  INTRV,XERROR
C***END PROLOGUE  BVALU
C
C
      INTEGER I,IDERIV,IDERP1,IHI,IHMKMJ,ILO,IMK,IMKPJ, INBV, IPJ,
     1 IP1, IP1MJ, J, JJ, J1, J2, K, KMIDER, KMJ, KM1, KPK, MFLAG, N
      REAL A, FKMJ, T, WORK, X
C     DIMENSION T(N+K), WORK(3*K)
      DIMENSION T(*), A(N), WORK(*)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C***FIRST EXECUTABLE STATEMENT  BVALU
      BVALU = 0.0E0
      IF(K.LT.1) GO TO 102
      IF(N.LT.K) GO TO 101
      IF(IDERIV.LT.0 .OR. IDERIV.GE.K) GO TO 110
      KMIDER = K - IDERIV
C
C *** FIND *I* IN (K,N) SUCH THAT T(I) .LE. X .LT. T(I+1)
C     (OR, .LE. T(I+1) IF T(I) .LT. T(I+1) = T(N+1)).
      KM1 = K - 1
      CALL INTRV(T, N+1, X, INBV, I, MFLAG)
      IF (X.LT.T(K)) GO TO 120
      IF (MFLAG.EQ.0) GO TO 20
      IF (X.GT.T(I)) GO TO 130
   10 IF (I.EQ.K) GO TO 140
      I = I - 1
      IF (X.EQ.T(I)) GO TO 10
C
C *** DIFFERENCE THE COEFFICIENTS *IDERIV* TIMES
C     WORK(I) = AJ(I), WORK(K+I) = DP(I), WORK(K+K+I) = DM(I), I=1.K
C
   20 IMK = I - K
      DO 30 J=1,K
        IMKPJ = IMK + J
        WORK(J) = A(IMKPJ)
   30 CONTINUE
      IF (IDERIV.EQ.0) GO TO 60
      DO 50 J=1,IDERIV
        KMJ = K - J
        FKMJ = FLOAT(KMJ)
        DO 40 JJ=1,KMJ
          IHI = I + JJ
          IHMKMJ = IHI - KMJ
          WORK(JJ) = (WORK(JJ+1)-WORK(JJ))/(T(IHI)-T(IHMKMJ))*FKMJ
   40   CONTINUE
   50 CONTINUE
C
C *** COMPUTE VALUE AT *X* IN (T(I),(T(I+1)) OF IDERIV-TH DERIVATIVE,
C     GIVEN ITS RELEVANT B-SPLINE COEFF. IN AJ(1),...,AJ(K-IDERIV).
   60 IF (IDERIV.EQ.KM1) GO TO 100
      IP1 = I + 1
      KPK = K + K
      J1 = K + 1
      J2 = KPK + 1
      DO 70 J=1,KMIDER
        IPJ = I + J
        WORK(J1) = T(IPJ) - X
        IP1MJ = IP1 - J
        WORK(J2) = X - T(IP1MJ)
        J1 = J1 + 1
        J2 = J2 + 1
   70 CONTINUE
      IDERP1 = IDERIV + 1
      DO 90 J=IDERP1,KM1
        KMJ = K - J
        ILO = KMJ
        DO 80 JJ=1,KMJ
          WORK(JJ) = (WORK(JJ+1)*WORK(KPK+ILO)+WORK(JJ)
     1              *WORK(K+JJ))/(WORK(KPK+ILO)+WORK(K+JJ))
          ILO = ILO - 1
   80   CONTINUE
   90 CONTINUE
  100 BVALU = WORK(1)
      RETURN
C
C
  101 CONTINUE
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,901)
      CALL DPWRST('XXX','BUG ')
  901 FORMAT('*****FROM BVALU, N DOES NOT SATISFY N.GE.K *****')
      RETURN
  102 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,902)
      CALL DPWRST('XXX','BUG ')
  902 FORMAT('*****FROM BVALU, K DOES NOT SATISFY K.GE.1 *****')
      RETURN
  110 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,903)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,904)
      CALL DPWRST('XXX','BUG ')
  903 FORMAT('*****FROM BVALU, IDERIV DOES NOT SATISFY')
  904 FORMAT('     0.LE.IDERIV.LT.K                    *****')
      RETURN
  120 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,921)
      CALL DPWRST('XXX','BUG ')
  921 FORMAT('*****FROM BVALU, X IS N0T GREATER THAN OR EQUAL TO T(K)')
      RETURN
  130 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,931)
      CALL DPWRST('XXX','BUG ')
  931 FORMAT('*****FROM BVALU, X IS NOT LESS THAN OR EQUAL TO T(N+1)')
      RETURN
  140 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,941)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,942)
      CALL DPWRST('XXX','BUG ')
  941 FORMAT('*****FROM BVALU, A LEFT LIMITING VALUE CANN0T BE')
  942 FORMAT('     OBTAINED AT T(K)                            *****')
      RETURN
      END
      SUBROUTINE BVNCDF(X1,X2,CORR,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE BIVARIATE NORMAL (GAUSSIAN)
C              DISTRIBUTION WITH MEANS = 0 AND STANDARD DEVIATIONS = 1
C              AND WITH A CORRELATION OF CORR.
C              F(X) = (1/SQRT(2*PI))*EXP(-X*X/2).
C     INPUT  ARGUMENTS--X1     = THE SINGLE PRECISION VALUE AT WHICH
C                                THE FIRST CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C                     --X1     = THE SINGLE PRECISION VALUE AT WHICH
C                                THE SECOND CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C                     --CORR   = THE CORRELATION BETWEEN THE 2
C                                DISTRIBUTIONS
C     OUTPUT ARGUMENTS--CDF    = THE SINGLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION
C             FUNCTION VALUE CDF.
C     PRINTING--NONE.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NORCDF, THA.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--SQRT.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--"A REMARK ON ALGORITHM AS76: AN INTEGRAL USEFUL IN
C                 CALCULATING NONCENTRAL T AND BIVARIATE NORMAL 
C                 PROBABILITIES", BOYS, APPLIED STATISTICS, 
C               --"TABLES FOR COMPUTING BIVARIATE NORMAL PROBABILITIES"
C                 ANNALS OF MATHEMATICAL STATISTICS, OWEN, 1956 (1075-
C                 1090).
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--94.10
C     ORIGINAL VERSION--OCTOBER   1994.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DATA ONE/1.0/
      DATA EPS/0.0000001/
C
C-----START POINT-----------------------------------------------------
C
      ACORR=ABS(CORR)
      IF(ACORR.GT.1.0)THEN
        WRITE(ICOUT,10)
 10     FORMAT('***** ERROR--THIRD TERM TO BVNCDF IS OUTSIDE THE ',
     1   'INTERVAL (-1,1).  *****')
        CALL DPWRST('BUG','XXX')
        CDF=0.0
        GOTO9999
      ENDIF
C
C  CORRELATION OF 1 IS A SPECIAL CASE
C
      IF(ACORR.EQ.1.0)THEN
        TERM1=MIN(X1,X2)
        CALL NORCDF(TERM1,CDF)
        GOTO9999
      ENDIF
C
      XH=X1
      XK=X2
      IF(ABS(XH).LE.EPS .AND. ABS(XK).LE.EPS)THEN
        XH=EPS
        XK=-EPS
      ENDIF
      CALL NORCDF(XH,TERM1)
      CALL NORCDF(XK,TERM2)
      TERM3=1.0
      IF(XH*XK.GT.0.0 .OR. (XH*XK.EQ.0.0.AND.XH+XK.GE.0.0))TERM3=0.0
      A1=(XK-CORR*XH)/SQRT(1.0-CORR*CORR)
      A2=XH
      IF(A1.EQ.0.0.AND.A2.EQ.0.0)A1=0.000001
      TERM4=THA(XH,ONE,A1,A2)
      A1=(XH-CORR*XK)/SQRT(1.0-CORR*CORR)
      A2=XK
      IF(A1.EQ.0.0.AND.A2.EQ.0.0)A1=0.000001
      TERM5=THA(XK,ONE,A1,A2)
      CDF=0.5*(TERM1+TERM2-TERM3)-TERM4-TERM5
      GOTO9999
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE BVNPDF(X1,X2,CORR,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE BIVARIATE NORMAL (GAUSSIAN)
C              DISTRIBUTION WITH MEANS = 0 AND STANDARD DEVIATIONS = 1
C              AND WITH A CORRELATION OF CORR.  USE THE FOLLOWING
C              FORMULA FROM ABRAMOWITZ AND STEGUM
C              F(X) = (1-P**2)**(-1/2)*NORPDF(X1)
C                     *NORPDF((X2-P*X1)/(SQRT(1-P**2)))
C              WHERE NORPDF IS THE UNIVARIATE NORMAL PDF FUNCTION.
C     INPUT  ARGUMENTS--X1     = THE SINGLE PRECISION VALUE AT WHICH
C                                THE FIRST PROBABILTY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C                     --X1     = THE SINGLE PRECISION VALUE AT WHICH
C                                THE SECOND PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C                     --CORR   = THE CORRELATION BETWEEN THE 2
C                                DISTRIBUTIONS
C     OUTPUT ARGUMENTS--PDF    = THE SINGLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION
C             FUNCTION VALUE PDF.
C     PRINTING--NONE.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NORPDF
C     FORTRAN LIBRARY SUBROUTINES NEEDED--SQRT.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--"AMS 55", ABRAMOWITZ AND STEGUM.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--95.9
C     ORIGINAL VERSION--SEPTEMBER 1995.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      ACORR=ABS(CORR)
      IF(ACORR.GT.1.0)THEN
        WRITE(ICOUT,10)
 10     FORMAT('***** ERROR--THIRD TERM TO BVNPDF IS OUTSIDE THE ',
     1   'INTERVAL (-1,1).  *****')
        CALL DPWRST('BUG','XXX')
        PDF=0.0
        GOTO9999
      ENDIF
C
C  CORRELATION OF 1 IS A SPECIAL CASE (UNDEFINED SINCE GET DIVISION
C  BY ZERO IN THE FORMULA).
C
      IF(ACORR.EQ.1.0)THEN
        PDF=0.0
        GOTO9999
      ENDIF
C
      TERM1=(1.0-ACORR*ACORR)
      TERM2=1.0/SQRT(TERM1)
      CALL NORPDF(X1,TERM3)
      ARG1=(X2-CORR*X1)/SQRT(1.0-CORR*CORR)
      CALL NORPDF(ARG1,TERM4)
C
      PDF=TERM2*TERM3*TERM4
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE BWECDF(X,ASCAL1,GAMMA1,ALOC2,ASCAL2,GAMMA2,CDF,DCDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE BI-WEIBULL DISTRIBUTION AS
C              AS DEFINED IN THE THIRD EDITION OF "STATISTICAL
C              DISTRIBUTIONS", THIRD EDITION, EVANS, HASTINGS, AND
C              PEACOCK.  THIS DISTRIBUTION IS RELATED TO, BUT SOMEWHAT
C              DIFFERENT THAN, A STRAIGHT MIXTURE OF TWO WEIBULL
C              DISTRIBUTIONS.  THE CDF IS DEFINED AS:
C              F(X,S1,G1,L2,S2,G2) =
C               1 - EXP[-(X/S1)**G1]                  0 < X < L2
C               1 - EXP[-{(X/S1)**G1 +
C                   [(X-L2)/S2]**G2}]                 X > L2
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE NON-NEGATIVE.
C                     --ASCAL1 = SCALE PARAMETER (FIRST PART)
C                     --GAMMA1 = SHAPE PARAMETER (FIRST PART)
C                     --ALOC2  = LOCATION PARAMETER (SECOND PART)
C                     --ASCAL2 = SCALE PARAMETER (SECOND PART)
C                     --GAMMA2 = SHAPE PARAMETER (SECOND PART)
C     OUTPUT ARGUMENTS--CDF    = THE SINGLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION
C             FUNCTION VALUE CDF FOR THE WEIBULL DISTRIBUTION
C             WITH 5 SHAPE PARAMETERS
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE NON-NEGATIVE.
C                 --GAMMA1,GAMMA2,ASCAL1,ASCAL2,ALOC2 SHOULD BE
C                   POSITIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--EXP.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--HASTINGS AND PEACOCK, STATISTICAL
C                 DISTRIBUTIONS--THIRD EDITION,
C                 2000, PP. 200-202.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--2002.5
C     ORIGINAL VERSION--MAY       2002.
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DS1
      DOUBLE PRECISION DG1
      DOUBLE PRECISION DL2
      DOUBLE PRECISION DS2
      DOUBLE PRECISION DG2
      DOUBLE PRECISION DX
      DOUBLE PRECISION DCDF
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
C 
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      DCDF=0.0D0
      IF(ASCAL1.LE.0.0)THEN
        WRITE(ICOUT,5)
    5 FORMAT('***** FATAL ERROR--THE SCALE(1) PARAMETER FOR ',
     1'THE BWECDF SUBROUTINE IS NON-POSITIVE *****')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ASCAL1
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9999
      ENDIF
      IF(GAMMA1.LE.0.0)THEN
        WRITE(ICOUT,15)
   15 FORMAT('***** FATAL ERROR--THE GAMMA(1) SHAPE PARAMETER FOR ',
     1'THE BWECDF SUBROUTINE IS NON-POSITIVE *****')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)GAMMA1
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9999
      ENDIF
      IF(ASCAL2.LE.0.0)THEN
        WRITE(ICOUT,25)
   25 FORMAT('***** FATAL ERROR--THE SCALE(2) PARAMETER FOR ',
     1'THE BWECDF SUBROUTINE IS NON-POSITIVE *****')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ASCAL2
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9999
      ENDIF
      IF(GAMMA2.LE.0.0)THEN
        WRITE(ICOUT,35)
   35 FORMAT('***** FATAL ERROR--THE GAMMA(2) SHAPE PARAMETER FOR ',
     1'THE BWECDF SUBROUTINE IS NON-POSITIVE *****')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)GAMMA2
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9999
      ENDIF
      IF(ALOC2.LE.0.0)THEN
        WRITE(ICOUT,45)
   45 FORMAT('***** FATAL ERROR--THE LOCATION(2) PARAMETER FOR ',
     1'THE BWECDF SUBROUTINE IS NON-POSITIVE *****')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ALOC2
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9999
      ENDIF
C
   90 CONTINUE
      IF(X.LE.0.0)THEN
        CDF=0.0
        GOTO9999
      ENDIF
C
      DX=DBLE(X)
      DG1=DBLE(GAMMA1)
      DS1=DBLE(ASCAL1)
      DG2=DBLE(GAMMA2)
      DS2=DBLE(ASCAL2)
      DL2=DBLE(ALOC2)
C
      IF(DX.LE.DL2)THEN
         DCDF=DEXP(-(DX/DS1)**DG1)
      ELSE
         DTERM1=(DX/DS1)**DG1
         DTERM2=((DX-DL2)/DS2)**DG2
         DCDF=DEXP(-(DTERM1 + DTERM2))
      ENDIF
      DCDF=1.0D0 - DCDF
      CDF=REAL(DCDF)
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE BWEHAZ(X,ASCAL1,GAMMA1,ALOC2,ASCAL2,GAMMA2,HAZ,DHAZ)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE HAZARD
C              FUNCTION VALUE FOR THE BI-WEIBULL DISTRIBUTION AS
C              AS DEFINED IN THE THIRD EDITION OF "STATISTICAL
C              DISTRIBUTIONS", THIRD EDITION, EVANS, HASTINGS, AND
C              PEACOCK.  THIS DISTRIBUTION IS RELATED TO, BUT SOMEWHAT
C              DIFFERENT THAN, A STRAIGHT MIXTURE OF TWO WEIBULL
C              DISTRIBUTIONS.  THE HAZARD FUNCTION IS DEFINED AS:
C              h(X,S1,G1,L2,S2,G2) =
C               (1/S1)*G1*(X/S1)**(G1-1)          0 < X < L2
C               (1/S1)*G1*(X/S1)**(G1-1) +
C               (G2/S2)*((X-L2)/S2)**(G2-1)       X >= L2
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE HAZARD
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE NON-NEGATIVE.
C                     --ASCAL1 = SCALE PARAMETER (FIRST PART)
C                     --GAMMA1 = SHAPE PARAMETER (FIRST PART)
C                     --ALOC2  = LOCATION PARAMETER (SECOND PART)
C                     --ASCAL2 = SCALE PARAMETER (SECOND PART)
C                     --GAMMA2 = SHAPE PARAMETER (SECOND PART)
C     OUTPUT ARGUMENTS--HAZ    = THE SINGLE PRECISION HAZARD
C                                FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION HAZARD
C             FUNCTION VALUE HAZ FOR THE WEIBULL DISTRIBUTION
C             WITH 5 SHAPE PARAMETERS
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE NON-NEGATIVE.
C                 --GAMMA1,GAMMA2,ASCAL1,ASCAL2,ALOC2 SHOULD BE
C                   POSITIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--EXP.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--HASTINGS AND PEACOCK, STATISTICAL
C                 DISTRIBUTIONS--THIRD EDITION,
C                 2000, PP. 200-202.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--2002.5
C     ORIGINAL VERSION--MAY       2002.
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DS1
      DOUBLE PRECISION DG1
      DOUBLE PRECISION DL2
      DOUBLE PRECISION DS2
      DOUBLE PRECISION DG2
      DOUBLE PRECISION DX
      DOUBLE PRECISION DHAZ
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
C 
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      DHAZ=0.0D0
      IF(ASCAL1.LE.0.0)THEN
        WRITE(ICOUT,5)
    5 FORMAT('***** FATAL ERROR--THE SCALE(1) PARAMETER FOR ',
     1'THE BWEHAZ SUBROUTINE IS NON-POSITIVE *****')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ASCAL1
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
        CALL DPWRST('XXX','BUG ')
        HAZ=0.0
        GOTO9999
      ENDIF
      IF(GAMMA1.LE.0.0)THEN
        WRITE(ICOUT,15)
   15 FORMAT('***** FATAL ERROR--THE GAMMA(1) SHAPE PARAMETER FOR ',
     1'THE BWEHAZ SUBROUTINE IS NON-POSITIVE *****')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)GAMMA1
        CALL DPWRST('XXX','BUG ')
        HAZ=0.0
        GOTO9999
      ENDIF
      IF(ASCAL2.LE.0.0)THEN
        WRITE(ICOUT,25)
   25 FORMAT('***** FATAL ERROR--THE SCALE(2) PARAMETER FOR ',
     1'THE BWEHAZ SUBROUTINE IS NON-POSITIVE *****')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ASCAL2
        CALL DPWRST('XXX','BUG ')
        HAZ=0.0
        GOTO9999
      ENDIF
      IF(GAMMA2.LE.0.0)THEN
        WRITE(ICOUT,35)
   35 FORMAT('***** FATAL ERROR--THE GAMMA(2) SHAPE PARAMETER FOR ',
     1'THE BWEHAZ SUBROUTINE IS NON-POSITIVE *****')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)GAMMA2
        CALL DPWRST('XXX','BUG ')
        HAZ=0.0
        GOTO9999
      ENDIF
      IF(ALOC2.LE.0.0)THEN
        WRITE(ICOUT,45)
   45 FORMAT('***** FATAL ERROR--THE LOCATION(2) PARAMETER FOR ',
     1'THE BWEHAZ SUBROUTINE IS NON-POSITIVE *****')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ALOC2
        CALL DPWRST('XXX','BUG ')
        HAZ=0.0
        GOTO9999
      ENDIF
C
   90 CONTINUE
      IF(X.LE.0.0)THEN
        HAZ=0.0
        GOTO9999
      ENDIF
C
      DX=DBLE(X)
      DG1=DBLE(GAMMA1)
      DS1=DBLE(ASCAL1)
      DG2=DBLE(GAMMA2)
      DS2=DBLE(ASCAL2)
      DL2=DBLE(ALOC2)
C
      IF(DX.LE.DL2)THEN
         DHAZ=(DG1/DS1)*(DX/DS1)**(DG1-1.0D0)
      ELSE
         DTERM1=(DG1/DS1)*(DX/DS1)**(DG1-1.0D0)
         DTERM2=(DG2/DS2)*((DX-DL2)/DS2)**(DG2-1.0D0)
         DHAZ=DTERM1 + DTERM2
      ENDIF
      HAZ=REAL(DHAZ)
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE BWEPPF(P,ASCAL1,GAMMA1,ALOC2,ASCAL2,GAMMA2,PPF,DPPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE BI-WEIBULL DISTRIBUTION AS
C              AS DEFINED IN THE THIRD EDITION OF "STATISTICAL
C              DISTRIBUTIONS", THIRD EDITION, EVANS, HASTINGS, AND
C              PEACOCK.  THIS DISTRIBUTION IS RELATED TO, BUT SOMEWHAT
C              DIFFERENT THAN, A STRAIGHT MIXTURE OF TWO WEIBULL
C              DISTRIBUTIONS.  THE CDF IS DEFINED AS:
C              F(X,S1,G1,L2,S2,G2) =
C               1 - EXP[-(X/S1)**G1]                  0 < X < L2
C               1 - EXP[-{(X/S1)**G1 +
C                   [(X-L2)/S2]**G2}]                 X > L2
C              THE PERCENT POINT FUNCTION IS CALCULATED ANALYTICALLY
C              FOR CASE WHEN X < L2.  IT IS CALCULATED NUMERICALLY
C              FOR X > L2.
C     INPUT  ARGUMENTS--P      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE PERCENT POINT FUNCTION
C                                FUNCTION IS TO BE EVALUATED.
C                                P SHOULD BE IN THE INTERVAL [0,1).
C                     --ASCAL1 = SCALE PARAMETER (FIRST PART)
C                     --GAMMA1 = SHAPE PARAMETER (FIRST PART)
C                     --ALOC2  = LOCATION PARAMETER (SECOND PART)
C                     --ASCAL2 = SCALE PARAMETER (SECOND PART)
C                     --GAMMA2 = SHAPE PARAMETER (SECOND PART)
C     OUTPUT ARGUMENTS--CDF    = THE SINGLE PRECISION PERCENT POINT
C                                FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PERCENT POINT
C             FUNCTION VALUE PPF FOR THE BI-WEIBULL DISTRIBUTION
C             WITH 5 SHAPE PARAMETERS
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--0<= P < 1
C                 --GAMMA1,GAMMA2,ASCAL1,ASCAL2,ALOC2 SHOULD BE
C                   POSITIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--EXP.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--HASTINGS AND PEACOCK, STATISTICAL
C                 DISTRIBUTIONS--THIRD EDITION,
C                 2000, PP. 200-202.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--2002.5
C     ORIGINAL VERSION--MAY       2002.
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DS1
      DOUBLE PRECISION DG1
      DOUBLE PRECISION DL2
      DOUBLE PRECISION DS2
      DOUBLE PRECISION DG2
      DOUBLE PRECISION DX
      DOUBLE PRECISION DP
      DOUBLE PRECISION DPPF
      DOUBLE PRECISION DCDF
      DOUBLE PRECISION DCDFL
      DOUBLE PRECISION DCDFR
      DOUBLE PRECISION DXINC
      DOUBLE PRECISION DXL
      DOUBLE PRECISION DXR
      DOUBLE PRECISION DFXL
      DOUBLE PRECISION DFXR
      DOUBLE PRECISION DP1
      DOUBLE PRECISION DFCS
      DOUBLE PRECISION DXRML
      DOUBLE PRECISION DSIG
      DOUBLE PRECISION DEPS
C 
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DATA DEPS /0.0000001/
      DATA DSIG /1.0D-7/
      DATA MAXIT /2000/
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(P.LT.0.0 .OR. P.GE.1.0)THEN
        WRITE(ICOUT,1)
    1 FORMAT('***** FATAL ERROR--THE INPUT ARGUMENT FOR THE ',
     1'THE BWEPPF SUBROUTINE IS OUTSIDE THE INTERVAL [0,1).')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)P
        CALL DPWRST('XXX','BUG ')
        PPF=0.0
        DPPF=0.0D0
        GOTO9999
      ENDIF
      IF(ASCAL1.LE.0.0)THEN
        WRITE(ICOUT,5)
    5 FORMAT('***** FATAL ERROR--THE SCALE(1) PARAMETER FOR ',
     1'THE BWEPPF SUBROUTINE IS NON-POSITIVE *****')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ASCAL1
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
        CALL DPWRST('XXX','BUG ')
        PPF=0.0
        DPPF=0.0D0
        GOTO9999
      ENDIF
      IF(GAMMA1.LE.0.0)THEN
        WRITE(ICOUT,15)
   15 FORMAT('***** FATAL ERROR--THE GAMMA(1) SHAPE PARAMETER FOR ',
     1'THE BWEPPF SUBROUTINE IS NON-POSITIVE *****')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)GAMMA1
        CALL DPWRST('XXX','BUG ')
        PPF=0.0
        DPPF=0.0D0
        GOTO9999
      ENDIF
      IF(ASCAL2.LE.0.0)THEN
        WRITE(ICOUT,25)
   25 FORMAT('***** FATAL ERROR--THE SCALE(2) PARAMETER FOR ',
     1'THE BWEPPF SUBROUTINE IS NON-POSITIVE *****')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ASCAL2
        CALL DPWRST('XXX','BUG ')
        PPF=0.0
        GOTO9999
      ENDIF
      IF(GAMMA2.LE.0.0)THEN
        WRITE(ICOUT,35)
   35 FORMAT('***** FATAL ERROR--THE GAMMA(2) SHAPE PARAMETER FOR ',
     1'THE BWEPPF SUBROUTINE IS NON-POSITIVE *****')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)GAMMA2
        CALL DPWRST('XXX','BUG ')
        PPF=0.0
        DPPF=0.0D0
        GOTO9999
      ENDIF
      IF(ALOC2.LE.0.0)THEN
        WRITE(ICOUT,45)
   45 FORMAT('***** FATAL ERROR--THE LOCATION(2) PARAMETER FOR ',
     1'THE BWEPPF SUBROUTINE IS NON-POSITIVE *****')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ALOC2
        CALL DPWRST('XXX','BUG ')
        PPF=0.0
        DPPF=0.0D0
        GOTO9999
      ENDIF
C
   90 CONTINUE
      IF(P.EQ.0.0)THEN
        PPF=0.0
        DPPF=0.0D0
        GOTO9999
      ENDIF
C
      DP=DBLE(P)
      DG1=DBLE(GAMMA1)
      DS1=DBLE(ASCAL1)
      DG2=DBLE(GAMMA2)
      DS2=DBLE(ASCAL2)
      DL2=DBLE(ALOC2)
C
C  CHECK IF P <= BWECDF(LOC2)
C
      CALL BWECDF(ALOC2,ASCAL1,GAMMA1,ALOC2,ASCAL2,GAMMA2,CDF,DCDF)
      IF(DP.LE.DCDF)THEN
        DPPF=(DLOG(1.0D0/(1.0D0-DP)))**(1.0D0/DG1)
        DPPF=DS1*DPPF
        PPF=REAL(DPPF)
        GOTO9999
      ENDIF      
C
C  CASE WHERE PPF CALCULATED NUMERICALLY
C
C
C  FIND BRACKETING INTERVAL.
C
      DXL=DL2
      DXINC=DS2
      IF(DXINC.LT.1.0D0)DXINC=1.0D0
      ICOUNT=0
      MAXCNT=10000
C
   91 CONTINUE
      DXR=DXL+DXINC
      IF(DXL.LE.DL2)DXL=DL2
      IF(DXR.LE.DL2)DXR=DXL+DXINC
      XL=REAL(DXL)
      XR=REAL(DXR)
      CALL BWECDF(XL,ASCAL1,GAMMA1,ALOC2,ASCAL2,GAMMA2,CDFL,DCDFL)
      CALL BWECDF(XR,ASCAL1,GAMMA1,ALOC2,ASCAL2,GAMMA2,CDFR,DCDFR)
      IF(DCDFL.LT.DP .AND. DCDFR.LT.DP)THEN
        DXL=DXR
      ELSEIF(DCDFL.GT.DP .AND. DCDFR.GT.DP)THEN
        DXL=DXL-DXINC
      ELSE
        GOTO99
      ENDIF
      ICOUNT=ICOUNT+1
      IF(ICOUNT.GT.MAXCNT)THEN
        WRITE(ICOUT,96)
        CALL DPWRST('XXX','BUG ')
        PPF=0.0
        GOTO9999
      ENDIF
   96 FORMAT('***** FATAL ERROR--BWEPPF UNABLE TO FIND BRACKETING ',
     *       'INTERVAL. *****')
      GOTO91
C
C
C  BISECTION METHOD
C
   99 CONTINUE
      IC = 0
      DFXL = -DP
      DFXR = 1.0D0 - DP
  105 CONTINUE
      DX = (DXL+DXR)*0.5D0
      X=REAL(DX)
      CALL BWECDF(X,ASCAL1,GAMMA1,ALOC2,ASCAL2,GAMMA2,CDF,DCDF)
      DP1=DCDF
      DPPF=DX
      PPF=REAL(DPPF)
      DFCS = DP1 - DP
      IF(DFCS*DFXL.GT.0.0D0)GOTO110
      DXR = DX
      DFXR = DFCS 
      GOTO115
  110 CONTINUE
      DXL = DX
      DFXL = DFCS
  115 CONTINUE
      DXRML = DXR - DXL
      IF(DXRML.LE.DSIG .AND. DABS(DFCS).LE.DEPS)GOTO9999
      IC = IC + 1
      IF(IC.LE.MAXIT)GOTO105
      WRITE(ICOUT,130)
      CALL DPWRST('XXX','BUG ')
  130 FORMAT('***** FATAL ERROR--BWEPPF ROUTINE DID NOT CONVERGE. ***')
      GOTO9999
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE BWERAN(N,ASCAL1,GAMMA1,ALOC2,ASCAL2,GAMMA2,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE BIWEIBULL DISTRIBUTION
C              WITH 5 SHAPE PARAMETERS.
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --ASCAL1 = THE SINGLE PRECISION VALUE OF THE
C                                SCALE (1) PARAMETER.
C                     --GAMMA1 = THE SINGLE PRECISION VALUE OF THE
C                                SHAPE (1) PARAMETER.
C                     --ALOC2  = THE SINGLE PRECISION VALUE OF THE
C                                LOCATION (2) PARAMETER.
C                     --ASCAL2 = THE SINGLE PRECISION VALUE OF THE
C                                SCALE (2) PARAMETER.
C                     --GAMMA2 = THE SINGLE PRECISION VALUE OF THE
C                                SHAPE (2) PARAMETER.
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST N)
C                                INTO WHICH THE GENERATED
C                                RANDOM SAMPLE WILL BE PLACED.
C     OUTPUT--A RANDOM SAMPLE OF SIZE N
C             FROM THE BIWEIBULL DISTRIBUTION
C             WITH 5 SHAPE PARAMETERS.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C                 --5 SHAPE PARAMETERS SHOULD BE POSITIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--2002.5
C     ORIGINAL VERSION--MAY       2002.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
      DOUBLE PRECISION DTEMP
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(ASCAL1.LE.0.0)THEN
        WRITE(ICOUT,5)
    5 FORMAT('***** FATAL ERROR--THE SCALE(1) PARAMETER FOR ',
     1'THE BWERAN SUBROUTINE IS NON-POSITIVE *****')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ASCAL1
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
      IF(GAMMA1.LE.0.0)THEN
        WRITE(ICOUT,15)
   15 FORMAT('***** FATAL ERROR--THE GAMMA(1) SHAPE PARAMETER FOR ',
     1'THE BWERAN SUBROUTINE IS NON-POSITIVE *****')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)GAMMA1
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
      IF(ASCAL2.LE.0.0)THEN
        WRITE(ICOUT,25)
   25 FORMAT('***** FATAL ERROR--THE SCALE(2) PARAMETER FOR ',
     1'THE BWERAN SUBROUTINE IS NON-POSITIVE *****')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ASCAL2
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
      IF(GAMMA2.LE.0.0)THEN
        WRITE(ICOUT,35)
   35 FORMAT('***** FATAL ERROR--THE GAMMA(2) SHAPE PARAMETER FOR ',
     1'THE BWERAN SUBROUTINE IS NON-POSITIVE *****')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)GAMMA2
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
      IF(ALOC2.LE.0.0)THEN
        WRITE(ICOUT,45)
   45 FORMAT('***** FATAL ERROR--THE LOCATION(2) PARAMETER FOR ',
     1'THE BWERAN SUBROUTINE IS NON-POSITIVE *****')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ALOC2
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
C
C     GENERATE N UNIFORM (0,1) RANDOM NUMBERS;
C
      CALL UNIRAN(N,ISEED,X)
C
C     GENERATE N BIWEIBULL DISTRIBUTION RANDOM
C     NUMBERS USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD.
C
      DO100I=1,N
        CALL BWEPPF(X(I),ASCAL1,GAMMA1,ALOC2,ASCAL2,GAMMA2,
     1              XTEMP,DTEMP)
        X(I)=XTEMP
  100 CONTINUE
C
 9999 CONTINUE
      RETURN
      END
      DOUBLE PRECISION FUNCTION BVN ( LOWER, UPPER, INFIN, CORREL )
*
*     A function for computing bivariate normal probabilities.
*
*  Parameters
*
*     LOWER  REAL, array of lower integration limits.
*     UPPER  REAL, array of upper integration limits.
*     INFIN  INTEGER, array of integration limits flags:
*            if INFIN(I) = 0, Ith limits are (-infinity, UPPER(I)];
*            if INFIN(I) = 1, Ith limits are [LOWER(I), infinity);
*            if INFIN(I) = 2, Ith limits are [LOWER(I), UPPER(I)].
*     CORREL REAL, correlation coefficient.
*
      DOUBLE PRECISION LOWER(*), UPPER(*), CORREL, BVNU
      INTEGER INFIN(*)
      IF ( INFIN(1) .EQ. 2  .AND. INFIN(2) .EQ. 2 ) THEN
         BVN =  BVNU ( LOWER(1), LOWER(2), CORREL )
     +        - BVNU ( UPPER(1), LOWER(2), CORREL )
     +        - BVNU ( LOWER(1), UPPER(2), CORREL )
     +        + BVNU ( UPPER(1), UPPER(2), CORREL )
      ELSE IF ( INFIN(1) .EQ. 2  .AND. INFIN(2) .EQ. 1 ) THEN
         BVN =  BVNU ( LOWER(1), LOWER(2), CORREL )
     +        - BVNU ( UPPER(1), LOWER(2), CORREL )
      ELSE IF ( INFIN(1) .EQ. 1  .AND. INFIN(2) .EQ. 2 ) THEN
         BVN =  BVNU ( LOWER(1), LOWER(2), CORREL )
     +        - BVNU ( LOWER(1), UPPER(2), CORREL )
      ELSE IF ( INFIN(1) .EQ. 2  .AND. INFIN(2) .EQ. 0 ) THEN
         BVN =  BVNU ( -UPPER(1), -UPPER(2), CORREL )
     +        - BVNU ( -LOWER(1), -UPPER(2), CORREL )
      ELSE IF ( INFIN(1) .EQ. 0  .AND. INFIN(2) .EQ. 2 ) THEN
         BVN =  BVNU ( -UPPER(1), -UPPER(2), CORREL )
     +        - BVNU ( -UPPER(1), -LOWER(2), CORREL )
      ELSE IF ( INFIN(1) .EQ. 1  .AND. INFIN(2) .EQ. 0 ) THEN
         BVN =  BVNU ( LOWER(1), -UPPER(2), -CORREL )
      ELSE IF ( INFIN(1) .EQ. 0  .AND. INFIN(2) .EQ. 1 ) THEN
         BVN =  BVNU ( -UPPER(1), LOWER(2), -CORREL )
      ELSE IF ( INFIN(1) .EQ. 1  .AND. INFIN(2) .EQ. 1 ) THEN
         BVN =  BVNU ( LOWER(1), LOWER(2), CORREL )
      ELSE IF ( INFIN(1) .EQ. 0  .AND. INFIN(2) .EQ. 0 ) THEN
         BVN =  BVNU ( -UPPER(1), -UPPER(2), CORREL )
      END IF
C
      RETURN
      END
      DOUBLE PRECISION FUNCTION BVNU( SH, SK, R )
*
*     A function for computing bivariate normal probabilities.
*
*       Yihong Ge
*       Department of Computer Science and Electrical Engineering
*       Washington State University
*       Pullman, WA 99164-2752
*       Email : yge@eecs.wsu.edu
*     and
*       Alan Genz
*       Department of Mathematics
*       Washington State University
*       Pullman, WA 99164-3113
*       Email : alangenz@wsu.edu
*
* BVN - calculate the probability that X is larger than SH and Y is
*       larger than SK.
*
* Parameters
*
*   SH  REAL, integration limit
*   SK  REAL, integration limit
*   R   REAL, correlation coefficient
*   LG  INTEGER, number of Gauss Rule Points and Weights
*
      DOUBLE PRECISION BVN, SH, SK, R, ZERO, TWOPI 
      INTEGER I, LG, NG
      PARAMETER ( ZERO = 0.0D0, TWOPI = 6.2831 85307 179586D0 ) 
      DOUBLE PRECISION X(10,3), W(10,3), AS, A, B, C, D, RS, XS
      DOUBLE PRECISION PHI, SN, ASR, H, K, BS, HS, HK
*     Gauss Legendre Points and Weights, N =  6
      DATA ( W(I,1), X(I,1), I = 1,3) /
     &  0.1713244923791705D+00,-0.9324695142031522D+00,
     &  0.3607615730481384D+00,-0.6612093864662647D+00,
     &  0.4679139345726904D+00,-0.2386191860831970D+00/
*     Gauss Legendre Points and Weights, N = 12
      DATA ( W(I,2), X(I,2), I = 1,6) /
     &  0.4717533638651177D-01,-0.9815606342467191D+00,
     &  0.1069393259953183D+00,-0.9041172563704750D+00,
     &  0.1600783285433464D+00,-0.7699026741943050D+00,
     &  0.2031674267230659D+00,-0.5873179542866171D+00,
     &  0.2334925365383547D+00,-0.3678314989981802D+00,
     &  0.2491470458134029D+00,-0.1252334085114692D+00/
*     Gauss Legendre Points and Weights, N = 20
      DATA ( W(I,3), X(I,3), I = 1,10) /
     &  0.1761400713915212D-01,-0.9931285991850949D+00,
     &  0.4060142980038694D-01,-0.9639719272779138D+00,
     &  0.6267204833410906D-01,-0.9122344282513259D+00,
     &  0.8327674157670475D-01,-0.8391169718222188D+00,
     &  0.1019301198172404D+00,-0.7463319064601508D+00,
     &  0.1181945319615184D+00,-0.6360536807265150D+00,
     &  0.1316886384491766D+00,-0.5108670019508271D+00,
     &  0.1420961093183821D+00,-0.3737060887154196D+00,
     &  0.1491729864726037D+00,-0.2277858511416451D+00,
     &  0.1527533871307259D+00,-0.7652652113349733D-01/
      SAVE X, W
      IF ( ABS(R) .LT. 0.3 ) THEN
         NG = 1
         LG = 3
      ELSE IF ( ABS(R) .LT. 0.75 ) THEN
         NG = 2
         LG = 6
      ELSE 
         NG = 3
         LG = 10
      ENDIF
      H = SH
      K = SK 
      HK = H*K
      BVN = 0.0D0
      IF ( ABS(R) .LT. 0.925D0 ) THEN
         HS = ( H*H + K*K )/2.0D0
         ASR = ASIN(R)
         DO 10  I = 1, LG
            SN = SIN(ASR*( X(I,NG)+1.0D0 )/2.0D0)
            BVN = BVN + W(I,NG)*EXP( ( SN*HK - HS )/(1.0D0 - SN*SN))
            SN = SIN(ASR*(-X(I,NG)+1.0D0 )/2.0D0)
            BVN = BVN + W(I,NG)*EXP( ( SN*HK - HS )/(1.0D0 - SN*SN))
 10      CONTINUE
         BVN = BVN*ASR/(2.0D0*TWOPI) + PHI(-H)*PHI(-K) 
      ELSE
         IF ( R .LT. 0.0D0 ) THEN
            K = -K
            HK = -HK
         ENDIF
         IF ( ABS(R) .LT. 1.0D0 ) THEN
            AS = ( 1.0D0 - R )*( 1.0D0 + R )
            A = SQRT(AS)
            BS = ( H - K )**2
            C = ( 4.0D0 - HK )/8.0D0
            D = ( 12.0D0 - HK )/16.0D0
            BVN = A*EXP( -(BS/AS + HK)/2.0D0 )
     +             *( 1.0D0 - C*(BS - AS)*(1.0D0 - D*BS/5)/3.0D0
     +             + C*D*AS*AS/5.0D0 )
            IF ( HK .GT. -160.0D0 ) THEN
               B = SQRT(BS)
               BVN = BVN - EXP(-HK/2.0D0)*SQRT(TWOPI)*PHI(-B/A)*B
     +               *( 1.0D0 - C*BS*( 1.0D0 - D*BS/5.0D0 )/3.0D0 ) 
            ENDIF
            A = A/2.0D0
            DO 20 I = 1, LG
               XS = ( A*(X(I,NG)+1) )**2
               RS = SQRT( 1.0D0 - XS )
               BVN = BVN + A*W(I,NG)*
     +              ( EXP( -BS/(2.0D0*XS) - HK/(1.0D0+RS) )/RS 
     +              - EXP( -(BS/XS+HK)/2.0D0 )*
     +              ( 1.0D0 + C*XS*( 1.0D0 + D*XS ) ) )
               XS = AS*(-X(I,NG)+1.0D0)**2/4.0D0
               RS = SQRT( 1.0D0 - XS )
               BVN = BVN + A*W(I,NG)*EXP( -(BS/XS + HK)/2.0D0 )
     +               *( EXP( -HK*(1.0D0-RS)/(2.0D0*(1.0D0+RS)))/RS 
     +               - ( 1.0D0 + C*XS*( 1.0D0 + D*XS ) ) )
 20         CONTINUE 
            BVN = -BVN/TWOPI
         ENDIF
         IF (R .GT. 0.0D0) BVN =  BVN + PHI( -MAX( H, K ) )
         IF (R .LT. 0.0D0) BVN = -BVN + MAX( ZERO, PHI(-H) - PHI(-K))
      ENDIF
      BVNU = BVN
C
      RETURN
      END
