C      ALGORITHM 715, COLLECTED ALGORITHMS FROM ACM.
C      THIS WORK PUBLISHED IN TRANSACTIONS ON MATHEMATICAL SOFTWARE,
C      VOL. 19, NO. 1, MARCH, 1993, PP. 22-32.
C      
C      INCLUDES CHANGES GIVEN IN REMARK BY PRICE, TOMS 22 (2)
      SUBROUTINE MACHAR(IBETA,IT,IRND,NGRD,MACHEP,NEGEP,IEXP,MINEXP,
     1                   MAXEXP,EPS,EPSNEG,XMIN,XMAX)
C----------------------------------------------------------------------
C  This Fortran 77 subroutine is intended to determine the parameters
C   of the floating-point arithmetic system specified below.  The
C   determination of the first three uses an extension of an algorithm
C   due to M. Malcolm, CACM 15 (1972), pp. 949-951, incorporating some,
C   but not all, of the improvements suggested by M. Gentleman and S.
C   Marovich, CACM 17 (1974), pp. 276-277.  An earlier version of this
C   program was published in the book Software Manual for the
C   Elementary Functions by W. J. Cody and W. Waite, Prentice-Hall,
C   Englewood Cliffs, NJ, 1980.
C
C  The program as given here must be modified before compiling.  If
C   a single (double) precision version is desired, change all
C   occurrences of CS (CD) in columns 1 and 2 to blanks.
C
C  Parameter values reported are as follows:
C
C       IBETA   - the radix for the floating-point representation
C       IT      - the number of base IBETA digits in the floating-point
C                 significand
C       IRND    - 0 if floating-point addition chops
C                 1 if floating-point addition rounds, but not in the
C                   IEEE style
C                 2 if floating-point addition rounds in the IEEE style
C                 3 if floating-point addition chops, and there is
C                   partial underflow
C                 4 if floating-point addition rounds, but not in the
C                   IEEE style, and there is partial underflow
C                 5 if floating-point addition rounds in the IEEE style,
C                   and there is partial underflow
C       NGRD    - the number of guard digits for multiplication with
C                 truncating arithmetic.  It is
C                 0 if floating-point arithmetic rounds, or if it
C                   truncates and only  IT  base  IBETA digits
C                   participate in the post-normalization shift of the
C                   floating-point significand in multiplication;
C                 1 if floating-point arithmetic truncates and more
C                   than  IT  base  IBETA  digits participate in the
C                   post-normalization shift of the floating-point
C                   significand in multiplication.
C       MACHEP  - the largest negative integer such that
C                 1.0+FLOAT(IBETA)**MACHEP .NE. 1.0, except that
C                 MACHEP is bounded below by  -(IT+3)
C       NEGEPS  - the largest negative integer such that
C                 1.0-FLOAT(IBETA)**NEGEPS .NE. 1.0, except that
C                 NEGEPS is bounded below by  -(IT+3)
C       IEXP    - the number of bits (decimal places if IBETA = 10)
C                 reserved for the representation of the exponent
C                 (including the bias or sign) of a floating-point
C                 number
C       MINEXP  - the largest in magnitude negative integer such that
C                 FLOAT(IBETA)**MINEXP is positive and normalized
C       MAXEXP  - the smallest positive power of  BETA  that overflows
C       EPS     - FLOAT(IBETA)**MACHEP.
C       EPSNEG  - FLOAT(IBETA)**NEGEPS.
C       XMIN    - the smallest non-vanishing normalized floating-point
C                 power of the radix, i.e.,  XMIN = FLOAT(IBETA)**MINEXP
C       XMAX    - the largest finite floating-point number.  In
C                 particular  XMAX = (1.0-EPSNEG)*FLOAT(IBETA)**MAXEXP
C                 Note - on some machines  XMAX  will be only the
C                 second, or perhaps third, largest number, being
C                 too small by 1 or 2 units in the last digit of
C                 the significand.
C
C  Latest modification: May 30, 1989
C
C  Author: W. J. Cody
C          Mathematics and Computer Science Division
C          Argonne National Laboratory
C          Argonne, IL 60439
C
C----------------------------------------------------------------------
      INTEGER I,IBETA,IEXP,IRND,IT,ITEMP,IZ,J,K,MACHEP,MAXEXP,
     1        MINEXP,MX,NEGEP,NGRD,NXRES
CS    REAL
CD    DOUBLE PRECISION
     1   A,B,BETA,BETAIN,BETAH,CONV,EPS,EPSNEG,ONE,T,TEMP,TEMPA,
     2   TEMP1,TWO,XMAX,XMIN,Y,Z,ZERO
C----------------------------------------------------------------------
CS    CONV(I) = REAL(I)
CD    CONV(I) = DBLE(I)
      ONE = CONV(1)
      TWO = ONE + ONE
      ZERO = ONE - ONE
C----------------------------------------------------------------------
C  Determine IBETA, BETA ala Malcolm.
C----------------------------------------------------------------------
      A = ONE
   10 A = A + A
         TEMP = A+ONE
         TEMP1 = TEMP-A
         IF (TEMP1-ONE .EQ. ZERO) GO TO 10
      B = ONE
   20 B = B + B
         TEMP = A+B
         ITEMP = INT(TEMP-A)
         IF (ITEMP .EQ. 0) GO TO 20
      IBETA = ITEMP
      BETA = CONV(IBETA)
C----------------------------------------------------------------------
C  Determine IT, IRND.
C----------------------------------------------------------------------
      IT = 0
      B = ONE
  100 IT = IT + 1
         B = B * BETA
         TEMP = B+ONE
         TEMP1 = TEMP-B
         IF (TEMP1-ONE .EQ. ZERO) GO TO 100
      IRND = 0
      BETAH = BETA / TWO
      TEMP = A+BETAH
      IF (TEMP-A .NE. ZERO) IRND = 1
      TEMPA = A + BETA
      TEMP = TEMPA+BETAH
      IF ((IRND .EQ. 0) .AND. (TEMP-TEMPA .NE. ZERO)) IRND = 2
C----------------------------------------------------------------------
C  Determine NEGEP, EPSNEG.
C----------------------------------------------------------------------
      NEGEP = IT + 3
      BETAIN = ONE / BETA
      A = ONE
      DO 200 I = 1, NEGEP
         A = A * BETAIN
  200 CONTINUE
      B = A
  210 TEMP = ONE-A
         IF (TEMP-ONE .NE. ZERO) GO TO 220
         A = A * BETA
         NEGEP = NEGEP - 1
      GO TO 210
  220 NEGEP = -NEGEP
      EPSNEG = A
C----------------------------------------------------------------------
C  Determine MACHEP, EPS.
C----------------------------------------------------------------------
      MACHEP = -IT - 3
      A = B
  300 TEMP = ONE+A
         IF (TEMP-ONE .NE. ZERO) GO TO 320
         A = A * BETA
         MACHEP = MACHEP + 1
      GO TO 300
  320 EPS = A
C----------------------------------------------------------------------
C  Determine NGRD.
C----------------------------------------------------------------------
      NGRD = 0
      TEMP = ONE+EPS
      IF ((IRND .EQ. 0) .AND. (TEMP*ONE-ONE .NE. ZERO)) NGRD = 1
C----------------------------------------------------------------------
C  Determine IEXP, MINEXP, XMIN.
C
C  Loop to determine largest I and K = 2**I such that
C         (1/BETA) ** (2**(I))
C  does not underflow.
C  Exit from loop is signaled by an underflow.
C----------------------------------------------------------------------
      I = 0
      K = 1
      Z = BETAIN
      T = ONE + EPS
      NXRES = 0
  400 Y = Z
         Z = Y * Y
C----------------------------------------------------------------------
C  Check for underflow here.
C----------------------------------------------------------------------
         A = Z * ONE
         TEMP = Z * T
         IF ((A+A .EQ. ZERO) .OR. (ABS(Z) .GE. Y)) GO TO 410
         TEMP1 = TEMP * BETAIN
         IF (TEMP1*BETA .EQ. Z) GO TO 410
         I = I + 1
         K = K + K
      GO TO 400
  410 IF (IBETA .EQ. 10) GO TO 420
      IEXP = I + 1
      MX = K + K
      GO TO 450
C----------------------------------------------------------------------
C  This segment is for decimal machines only.
C----------------------------------------------------------------------
  420 IEXP = 2
      IZ = IBETA
  430 IF (K .LT. IZ) GO TO 440
         IZ = IZ * IBETA
         IEXP = IEXP + 1
      GO TO 430
  440 MX = IZ + IZ - 1
C----------------------------------------------------------------------
C  Loop to determine MINEXP, XMIN.
C  Exit from loop is signaled by an underflow.
C----------------------------------------------------------------------
  450 XMIN = Y
         Y = Y * BETAIN
C----------------------------------------------------------------------
C  Check for underflow here.
C----------------------------------------------------------------------
         A = Y * ONE
         TEMP = Y * T
         IF (((A+A) .EQ. ZERO) .OR. (ABS(Y) .GE. XMIN)) GO TO 460
         K = K + 1
         TEMP1 = TEMP * BETAIN
         IF ((TEMP1*BETA .NE. Y) .OR. (TEMP .EQ. Y)) THEN
               GO TO 450
            ELSE
               NXRES = 3
               XMIN = Y
         END IF
  460 MINEXP = -K
C----------------------------------------------------------------------
C  Determine MAXEXP, XMAX.
C----------------------------------------------------------------------
      IF ((MX .GT. K+K-3) .OR. (IBETA .EQ. 10)) GO TO 500
      MX = MX + MX
      IEXP = IEXP + 1
  500 MAXEXP = MX + MINEXP
C----------------------------------------------------------------------
C  Adjust IRND to reflect partial underflow.
C----------------------------------------------------------------------
      IRND = IRND + NXRES
C----------------------------------------------------------------------
C  Adjust for IEEE-style machines.
C----------------------------------------------------------------------
      IF (IRND .GE. 2) MAXEXP = MAXEXP - 2
C----------------------------------------------------------------------
C  Adjust for machines with implicit leading bit in binary
C  significand, and machines with radix point at extreme
C  right of significand.
C----------------------------------------------------------------------
      I = MAXEXP + MINEXP
      IF ((IBETA .EQ. 2) .AND. (I .EQ. 0)) MAXEXP = MAXEXP - 1
      IF (I .GT. 20) MAXEXP = MAXEXP - 1
      IF (A .NE. Y) MAXEXP = MAXEXP - 2
      XMAX = ONE - EPSNEG
      IF (XMAX*ONE .NE. XMAX) XMAX = ONE - BETA * EPSNEG
      XMAX = XMAX / (BETA * BETA * BETA * XMIN)
      I = MAXEXP + MINEXP + 3
      IF (I .LE. 0) GO TO 520
      DO 510 J = 1, I
          IF (IBETA .EQ. 2) XMAX = XMAX + XMAX
          IF (IBETA .NE. 2) XMAX = XMAX * BETA
  510 CONTINUE
  520 RETURN
C---------- Last line of MACHAR ----------
      END
      SUBROUTINE RIBESL(X,ALPHA,NB,IZE,B,NCALC)
C-------------------------------------------------------------------
C
C  This routine calculates Bessel functions I SUB(N+ALPHA) (X)
C  for non-negative argument X, and non-negative order N+ALPHA,
C  with or without exponential scaling.
C
C
C Explanation of variables in the calling sequence
C
C X     - Working precision non-negative real argument for which
C         I's or exponentially scaled I's (I*EXP(-X))
C         are to be calculated.  If I's are to be calculated,
C         X must be less than EXPARG (see below).
C ALPHA - Working precision fractional part of order for which
C         I's or exponentially scaled I's (I*EXP(-X)) are
C         to be calculated.  0 .LE. ALPHA .LT. 1.0.
C NB    - Integer number of functions to be calculated, NB .GT. 0.
C         The first function calculated is of order ALPHA, and the
C         last is of order (NB - 1 + ALPHA).
C IZE   - Integer type.  IZE = 1 if unscaled I's are to calculated,
C         and 2 if exponentially scaled I's are to be calculated.
C B     - Working precision output vector of length NB.  If the routine
C         terminates normally (NCALC=NB), the vector B contains the
C         functions I(ALPHA,X) through I(NB-1+ALPHA,X), or the
C         corresponding exponentially scaled functions.
C NCALC - Integer output variable indicating possible errors.
C         Before using the vector B, the user should check that
C         NCALC=NB, i.e., all orders have been calculated to
C         the desired accuracy.  See error returns below.
C
C
C*******************************************************************
C*******************************************************************
C
C Explanation of machine-dependent constants.  Let
C
C   beta   = Radix for the floating-point system
C   minexp = Smallest representable power of beta
C   maxexp = Smallest power of beta that overflows
C   it     = Number of bits in the mantissa of a working precision
C            variable
C
C Then the following machine-dependent constants must be declared
C   in DATA statements.  IEEE values are provided as a default.
C
C   NSIG   = Decimal significance desired.  Should be set to
C            INT(LOG10(2)*it+1).  Setting NSIG lower will result
C            in decreased accuracy while setting NSIG higher will
C            increase CPU time without increasing accuracy.  The
C            truncation error is limited to a relative error of
C            T=.5*10**(-NSIG).
C   ENTEN  = 10.0 ** K, where K is the largest integer such that
C            ENTEN is machine-representable in working precision
C   ENSIG  = 10.0 ** NSIG
C   RTNSIG = 10.0 ** (-K) for the smallest integer K such that
C            K .GE. NSIG/4
C   ENMTEN = Smallest ABS(X) such that X/4 does not underflow
C   XLARGE = Upper limit on the magnitude of X when IZE=2.  Bear
C            in mind that if ABS(X)=N, then at least N iterations
C            of the backward recursion will be executed.  The value
C            of 10.0 ** 4 is used on every machine.
C   EXPARG = Largest working precision argument that the library
C            EXP routine can handle and upper limit on the
C            magnitude of X when IZE=1; approximately
C            LOG(beta**maxexp)
C
C
C     Approximate values for some important machines are:
C
C                        beta       minexp      maxexp       it
C
C  CRAY-1        (S.P.)    2        -8193        8191        48
C  Cyber 180/855
C    under NOS   (S.P.)    2         -975        1070        48
C  IEEE (IBM/XT,
C    SUN, etc.)  (S.P.)    2         -126         128        24
C  IEEE (IBM/XT,
C    SUN, etc.)  (D.P.)    2        -1022        1024        53
C  IBM 3033      (D.P.)   16          -65          63        14
C  VAX           (S.P.)    2         -128         127        24
C  VAX D-Format  (D.P.)    2         -128         127        56
C  VAX G-Format  (D.P.)    2        -1024        1023        53
C
C
C                        NSIG       ENTEN       ENSIG      RTNSIG
C
C CRAY-1        (S.P.)    15       1.0E+2465   1.0E+15     1.0E-4
C Cyber 180/855
C   under NOS   (S.P.)    15       1.0E+322    1.0E+15     1.0E-4
C IEEE (IBM/XT,
C   SUN, etc.)  (S.P.)     8       1.0E+38     1.0E+8      1.0E-2
C IEEE (IBM/XT,
C   SUN, etc.)  (D.P.)    16       1.0D+308    1.0D+16     1.0D-4
C IBM 3033      (D.P.)     5       1.0D+75     1.0D+5      1.0D-2
C VAX           (S.P.)     8       1.0E+38     1.0E+8      1.0E-2
C VAX D-Format  (D.P.)    17       1.0D+38     1.0D+17     1.0D-5
C VAX G-Format  (D.P.)    16       1.0D+307    1.0D+16     1.0D-4
C
C
C                         ENMTEN      XLARGE   EXPARG
C
C CRAY-1        (S.P.)   1.84E-2466   1.0E+4    5677
C Cyber 180/855
C   under NOS   (S.P.)   1.25E-293    1.0E+4     741
C IEEE (IBM/XT,
C   SUN, etc.)  (S.P.)   4.70E-38     1.0E+4      88
C IEEE (IBM/XT,
C   SUN, etc.)  (D.P.)   8.90D-308    1.0D+4     709
C IBM 3033      (D.P.)   2.16D-78     1.0D+4     174
C VAX           (S.P.)   1.17E-38     1.0E+4      88
C VAX D-Format  (D.P.)   1.17D-38     1.0D+4      88
C VAX G-Format  (D.P.)   2.22D-308    1.0D+4     709
C
C*******************************************************************
C*******************************************************************
C
C Error returns
C
C  In case of an error,  NCALC .NE. NB, and not all I's are
C  calculated to the desired accuracy.
C
C  NCALC .LT. 0:  An argument is out of range. For example,
C     NB .LE. 0, IZE is not 1 or 2, or IZE=1 and ABS(X) .GE. EXPARG.
C     In this case, the B-vector is not calculated, and NCALC is
C     set to MIN0(NB,0)-1 so that NCALC .NE. NB.
C
C  NB .GT. NCALC .GT. 0: Not all requested function values could
C     be calculated accurately.  This usually occurs because NB is
C     much larger than ABS(X).  In this case, B(N) is calculated
C     to the desired accuracy for N .LE. NCALC, but precision
C     is lost for NCALC .LT. N .LE. NB.  If B(N) does not vanish
C     for N .GT. NCALC (because it is too small to be represented),
C     and B(N)/B(NCALC) = 10**(-K), then only the first NSIG-K
C     significant figures of B(N) can be trusted.
C
C
C Intrinsic functions required are:
C
C     DBLE, EXP, DGAMMA, GAMMA, INT, MAX, MIN, REAL, SQRT
C
C
C Acknowledgement
C
C  This program is based on a program written by David J.
C  Sookne (2) that computes values of the Bessel functions J or
C  I of real argument and integer order.  Modifications include
C  the restriction of the computation to the I Bessel function
C  of non-negative real argument, the extension of the computation
C  to arbitrary positive order, the inclusion of optional
C  exponential scaling, and the elimination of most underflow.
C  An earlier version was published in (3).
C
C References: "A Note on Backward Recurrence Algorithms," Olver,
C              F. W. J., and Sookne, D. J., Math. Comp. 26, 1972,
C              pp 941-947.
C
C             "Bessel Functions of Real Argument and Integer Order,"
C              Sookne, D. J., NBS Jour. of Res. B. 77B, 1973, pp
C              125-132.
C
C             "ALGORITHM 597, Sequence of Modified Bessel Functions
C              of the First Kind," Cody, W. J., Trans. Math. Soft.,
C              1983, pp. 242-245.
C
C  Latest modification: March 14, 1992
C
C  Modified by: W. J. Cody and L. Stoltz
C               Applied Mathematics Division
C               Argonne National Laboratory
C               Argonne, IL  60439
C
C-------------------------------------------------------------------
      INTEGER IZE,K,L,MAGX,N,NB,NBMX,NCALC,NEND,NSIG,NSTART
CS    REAL              GAMMA,
CD    DOUBLE PRECISION DGAMMA,
     1 ALPHA,B,CONST,CONV,EM,EMPAL,EMP2AL,EN,ENMTEN,ENSIG,
     2 ENTEN,EXPARG,FUNC,HALF,HALFX,ONE,P,PLAST,POLD,PSAVE,PSAVEL,
     3 RTNSIG,SUM,TEMPA,TEMPB,TEMPC,TEST,TOVER,TWO,X,XLARGE,ZERO
      DIMENSION B(NB)
C-------------------------------------------------------------------
C  Mathematical constants
C-------------------------------------------------------------------
CS    DATA ONE,TWO,ZERO,HALF,CONST/1.0E0,2.0E0,0.0E0,0.5E0,1.585E0/
CD    DATA ONE,TWO,ZERO,HALF,CONST/1.0D0,2.0D0,0.0D0,0.5D0,1.585D0/
C-------------------------------------------------------------------
C  Machine-dependent parameters
C-------------------------------------------------------------------
CS    DATA NSIG,XLARGE,EXPARG /8,1.0E4,88.0E0/
CS    DATA ENTEN,ENSIG,RTNSIG/1.0E38,1.0E8,1.0E-2/
CS    DATA ENMTEN/4.7E-38/
CD    DATA NSIG,XLARGE,EXPARG /16,1.0D4,709.0D0/
CD    DATA ENTEN,ENSIG,RTNSIG/1.0D308,1.0D16,1.0D-4/
CD    DATA ENMTEN/8.9D-308/
C-------------------------------------------------------------------
C  Statement functions for conversion
C-------------------------------------------------------------------
CS    CONV(N) = REAL(N)
CS    FUNC(X) = GAMMA(X)
CD    CONV(N) = DBLE(N)
CD    FUNC(X) = DGAMMA(X)
C-------------------------------------------------------------------
C Check for X, NB, OR IZE out of range.
C-------------------------------------------------------------------
      IF ((NB.GT.0) .AND. (X .GE. ZERO) .AND.
     1    (ALPHA .GE. ZERO) .AND. (ALPHA .LT. ONE) .AND.
     2    (((IZE .EQ. 1) .AND. (X .LE. EXPARG)) .OR.
     3     ((IZE .EQ. 2) .AND. (X .LE. XLARGE)))) THEN
C-------------------------------------------------------------------
C Use 2-term ascending series for small X
C-------------------------------------------------------------------
            NCALC = NB
            MAGX = INT(X)
            IF (X .GE. RTNSIG) THEN
C-------------------------------------------------------------------
C Initialize the forward sweep, the P-sequence of Olver
C-------------------------------------------------------------------
                  NBMX = NB-MAGX
                  N = MAGX+1
                  EN = CONV(N+N) + (ALPHA+ALPHA)
                  PLAST = ONE
                  P = EN / X
C-------------------------------------------------------------------
C Calculate general significance test
C-------------------------------------------------------------------
                  TEST = ENSIG + ENSIG
                  IF (2*MAGX .GT. 5*NSIG) THEN
                        TEST = SQRT(TEST*P)
                     ELSE
                        TEST = TEST / CONST**MAGX
                  END IF
                  IF (NBMX .GE. 3) THEN
C-------------------------------------------------------------------
C Calculate P-sequence until N = NB-1.  Check for possible overflow.
C-------------------------------------------------------------------
                     TOVER = ENTEN / ENSIG
                     NSTART = MAGX+2
                     NEND = NB - 1
                     DO 100 K = NSTART, NEND
                        N = K
                        EN = EN + TWO
                        POLD = PLAST
                        PLAST = P
                        P = EN * PLAST/X + POLD
                        IF (P .GT. TOVER) THEN
C-------------------------------------------------------------------
C To avoid overflow, divide P-sequence by TOVER.  Calculate
C P-sequence until ABS(P) .GT. 1.
C-------------------------------------------------------------------
                           TOVER = ENTEN
                           P = P / TOVER
                           PLAST = PLAST / TOVER
                           PSAVE = P
                           PSAVEL = PLAST
                           NSTART = N + 1
   60                      N = N + 1
                              EN = EN + TWO
                              POLD = PLAST
                              PLAST = P
                              P = EN * PLAST/X + POLD
                           IF (P .LE. ONE) GO TO 60
                           TEMPB = EN / X
C-------------------------------------------------------------------
C Calculate backward test, and find NCALC, the highest N
C such that the test is passed.
C-------------------------------------------------------------------
                           TEST = POLD*PLAST / ENSIG
                           TEST = TEST*(HALF-HALF/(TEMPB*TEMPB))
                           P = PLAST * TOVER
                           N = N - 1
                           EN = EN - TWO
                           NEND = MIN0(NB,N)
                           DO 80 L = NSTART, NEND
                              NCALC = L
                              POLD = PSAVEL
                              PSAVEL = PSAVE
                              PSAVE = EN * PSAVEL/X + POLD
                              IF (PSAVE*PSAVEL .GT. TEST) GO TO 90
   80                      CONTINUE
                           NCALC = NEND + 1
   90                      NCALC = NCALC - 1
                           GO TO 120
                        END IF
  100                CONTINUE
                     N = NEND
                     EN = CONV(N+N) + (ALPHA+ALPHA)
C-------------------------------------------------------------------
C Calculate special significance test for NBMX .GT. 2.
C-------------------------------------------------------------------
                     TEST = MAX(TEST,SQRT(PLAST*ENSIG)*SQRT(P+P))
                  END IF
C-------------------------------------------------------------------
C Calculate P-sequence until significance test passed.
C-------------------------------------------------------------------
  110             N = N + 1
                     EN = EN + TWO
                     POLD = PLAST
                     PLAST = P
                     P = EN * PLAST/X + POLD
                  IF (P .LT. TEST) GO TO 110
C-------------------------------------------------------------------
C Initialize the backward recursion and the normalization sum.
C-------------------------------------------------------------------
  120             N = N + 1
                  EN = EN + TWO
                  TEMPB = ZERO
                  TEMPA = ONE / P
                  EM = CONV(N) - ONE
                  EMPAL = EM + ALPHA
                  EMP2AL = (EM - ONE) + (ALPHA + ALPHA)
                  SUM = TEMPA * EMPAL * EMP2AL / EM
                  NEND = N - NB
                  IF (NEND .LT. 0) THEN
C-------------------------------------------------------------------
C N .LT. NB, so store B(N) and set higher orders to zero.
C-------------------------------------------------------------------
                        B(N) = TEMPA
                        NEND = -NEND
                        DO 130 L = 1, NEND
  130                      B(N+L) = ZERO
                     ELSE
                        IF (NEND .GT. 0) THEN
C-------------------------------------------------------------------
C Recur backward via difference equation, calculating (but
C not storing) B(N), until N = NB.
C-------------------------------------------------------------------
                           DO 140 L = 1, NEND
                              N = N - 1
                              EN = EN - TWO
                              TEMPC = TEMPB
                              TEMPB = TEMPA
                              TEMPA = (EN*TEMPB) / X + TEMPC
                              EM = EM - ONE
                              EMP2AL = EMP2AL - ONE
                              IF (N .EQ. 1) GO TO 150
                              IF (N .EQ. 2) EMP2AL = ONE
                              EMPAL = EMPAL - ONE
                              SUM = (SUM + TEMPA*EMPAL) * EMP2AL / EM
  140                      CONTINUE
                        END IF
C-------------------------------------------------------------------
C Store B(NB)
C-------------------------------------------------------------------
  150                   B(N) = TEMPA
                        IF (NB .LE. 1) THEN
                           SUM = (SUM + SUM) + TEMPA
                           GO TO 230
                        END IF
C-------------------------------------------------------------------
C Calculate and Store B(NB-1)
C-------------------------------------------------------------------
                        N = N - 1
                        EN = EN - TWO
                        B(N)  = (EN*TEMPA) / X + TEMPB
                        IF (N .EQ. 1) GO TO 220
                        EM = EM - ONE
                        EMP2AL = EMP2AL - ONE
                        IF (N .EQ. 2) EMP2AL = ONE
                        EMPAL = EMPAL - ONE
                        SUM = (SUM + B(N)*EMPAL) * EMP2AL / EM
                  END IF
                  NEND = N - 2
                  IF (NEND .GT. 0) THEN
C-------------------------------------------------------------------
C Calculate via difference equation and store B(N), until N = 2.
C-------------------------------------------------------------------
                     DO 200 L = 1, NEND
                        N = N - 1
                        EN = EN - TWO
                        B(N) = (EN*B(N+1)) / X +B(N+2)
                        EM = EM - ONE
                        EMP2AL = EMP2AL - ONE
                        IF (N .EQ. 2) EMP2AL = ONE
                        EMPAL = EMPAL - ONE
                        SUM = (SUM + B(N)*EMPAL) * EMP2AL / EM
  200                CONTINUE
                  END IF
C-------------------------------------------------------------------
C Calculate B(1)
C-------------------------------------------------------------------
                  B(1) = TWO*EMPAL*B(2) / X + B(3)
  220             SUM = (SUM + SUM) + B(1)
C-------------------------------------------------------------------
C Normalize.  Divide all B(N) by sum.
C-------------------------------------------------------------------
  230             IF (ALPHA .NE. ZERO)
     1               SUM = SUM * FUNC(ONE+ALPHA) * (X*HALF)**(-ALPHA)
                  IF (IZE .EQ. 1) SUM = SUM * EXP(-X)
                  TEMPA = ENMTEN
                  IF (SUM .GT. ONE) TEMPA = TEMPA * SUM
                  DO 260 N = 1, NB
                     IF (B(N) .LT. TEMPA) B(N) = ZERO
                     B(N) = B(N) / SUM
  260             CONTINUE
                  RETURN
C-------------------------------------------------------------------
C Two-term ascending series for small X.
C-------------------------------------------------------------------
               ELSE
                  TEMPA = ONE
                  EMPAL = ONE + ALPHA
                  HALFX = ZERO
                  IF (X .GT. ENMTEN) HALFX = HALF * X
                  IF (ALPHA .NE. ZERO) TEMPA = HALFX**ALPHA /FUNC(EMPAL)
                  IF (IZE .EQ. 2) TEMPA = TEMPA * EXP(-X)
                  TEMPB = ZERO
                  IF ((X+ONE) .GT. ONE) TEMPB = HALFX * HALFX
                  B(1) = TEMPA + TEMPA*TEMPB / EMPAL
                  IF ((X .NE. ZERO) .AND. (B(1) .EQ. ZERO)) NCALC = 0
                  IF (NB .GT. 1) THEN
                     IF (X .EQ. ZERO) THEN
                           DO 310 N = 2, NB
                              B(N) = ZERO
  310                      CONTINUE
                        ELSE
C-------------------------------------------------------------------
C Calculate higher-order functions.
C-------------------------------------------------------------------
                           TEMPC = HALFX
                           TOVER = (ENMTEN + ENMTEN) / X
                           IF (TEMPB .NE. ZERO) TOVER = ENMTEN / TEMPB
                           DO 340 N = 2, NB
                              TEMPA = TEMPA / EMPAL
                              EMPAL = EMPAL + ONE
                              TEMPA = TEMPA * TEMPC
                              IF (TEMPA .LE. TOVER*EMPAL) TEMPA = ZERO
                              B(N) = TEMPA + TEMPA*TEMPB / EMPAL
                              IF ((B(N) .EQ. ZERO) .AND. (NCALC .GT. N))
     1                             NCALC = N-1
  340                      CONTINUE
                     END IF
                  END IF
            END IF
         ELSE
            NCALC = MIN0(NB,0)-1
      END IF
      RETURN
C---------- Last line of RIBESL ----------
      END

      PROGRAM RITEST
C----------------------------------------------------------------------
C FORTRAN 77 program to test RIBESL
C
C  Method:
C
C     Two different accuracy tests are used.  In the first interval,
C     function values are compared against values generated with the
C     multiplication formula, where the Bessel values used in the
C     multiplication formula are obtained from the function program.
C     In the remaining intervals, function values are compared
C     against values generated with a local Taylor series expansion.
C     Derivatives in the expansion are expressed in terms of the
C     first two Bessel functions, which are in turn obtained from
C     the function program.
C
C  Data required
C
C     None
C
C  Subprograms required from this package
C
C     MACHAR - An environmental inquiry program providing
C         information on the floating-point arithmetic
C         system.  Note that the call to MACHAR can
C         be deleted provided the following five
C         parameters are assigned the values indicated
C
C              IBETA  - the radix of the floating-point system
C              IT     - the number of base-IBETA digits in the
C                       significant of a floating-point number
C              EPS    - the smallest positive floating-point
C                       number such that 1.0+EPS .NE. 1.0
C              XMAX   - the largest finite floating-point number
C
C     REN(K) - a function subprogram returning random real
C              numbers uniformly distributed over (0,1)
C
C
C  Intrinsic functions required are:
C
C      ABS, DBLE, INT, LOG, MAX, REAL, SQRT
C
C  Reference: "Performance evaluation of programs for certain
C              Bessel functions", W. J. Cody and L. Stoltz,
C              ACM Trans. on Math. Software, Vol. 15, 1989,
C              pp 41-48.
C
C             "Use of Taylor series to test accuracy of function
C              programs," W. J. Cody and L. Stoltz, submitted for
C              publication.
C
C  Latest modification: March 14, 1992
C
C  Authors: W. J. Cody and L. Stoltz
C           Mathematics and Computer Science Division
C           Argonne National Laboratory
C           Argonne, IL 60439
C
C----------------------------------------------------------------------
      INTEGER I,IBETA,IEXP,II,III,IND,IOUT,IRND,IT,IZE,J,JT,J1,J2,K,
     1    KK,K1,K2,K3,LAST,M,MACHEP,MAXEXP,MB,MBORG,MINEXP,MVR,N,NCALC,
     2    NDUM,NDX,NDX2,NEGEP,NGRD,NK,NO1,NUM
CS    REAL  
CD    DOUBLE PRECISION  
     1    A,AIT,AK,AKK,ALBETA,ALPHA,ALPHSQ,A1,AR1,AR2,B,BETA,C,CONV,D,
     2    DEL,DELTA,DERIV,E,EPS,EPSNEG,F,G,HALF,HUND,ONE,REN,R6,R7,
     3    SIXTEN,SUM,TEN,TWO,T1,T2,U,U2,W,X,XBAD,XL,XLAM,XLARGE,XMAX,
     4    XMB,XMIN,XJ1,XN,X1,X99,Y,YSQ,Z,ZERO,ZZ
      DIMENSION AR1(11,6),AR2(13,9),G(5),NDX(24),NDX2(8),U(560),U2(560)
CS    DATA ZERO,HALF,ONE,TWO/0.0E0,0.5E0,1.0E0,2.0E0/,
CS   1    TEN,SIXTEN,HUND,X99/10.0E0,1.6E1,1.0E2,-999.0E0/,
CS   2    XLAM,XLARGE/1.03125E0,1.0E4/,
CS   3    C/0.9189385332E0/
CD    DATA ZERO,HALF,ONE,TWO/0.0D0,0.5D0,1.0D0,2.0D0/,
CD   1    TEN,SIXTEN,HUND,X99/10.0D0,1.6D1,1.0D2,-999.0D0/,
CD   2    XLAM,XLARGE/1.03125D0,1.0D4/,
CD   3    C/0.9189385332D0/
C----------------------------------------------------------------------
C  Arrays related to expansion of the derivatives in terms
C   of the first two Bessel functions.
C----------------------------------------------------------------------
      DATA  NDX/9,7,5,3,1,8,6,4,2,7,5,3,1,6,4,2,5,3,1,4,2,3,1,2/
      DATA  NDX2/5,9,13,16,19,21,23,24/
CS    DATA  AR1/0.0E0,1.0E0,0.0E0,-1.0E0,0.0E0,1.0E0,3.0E0,0.0E0,-2.0E0,
CS   1          -1.2E1,0.0E0,1.0E0,0.0E0,-1.0E0,1.0E0,2.0E0,0.0E0,
CS   2          -2.0E0,-6.0E0,1.0E0,7.0E0,2.4E1,0.0E0,0.0E0,1.0E0,0.0E0,
CS   3          -3.0E0,0.0E0,2.0E0,1.1E1,0.0E0,-1.2E1,-5.0E1,0.0E0,
CS   4          0.0E0,0.0E0,0.0E0,1.0E0,0.0E0,0.0E0,-6.0E0,0.0E0,2.0E0,
CS   5          3.5E1,0.0E0,0.0E0,0.0E0,0.0E0,0.0E0,0.0E0,0.0E0,1.0E0,
CS   6          0.0E0,0.0E0,-1.0E1,0.0E0,0.0E0,0.0E0,0.0E0,0.0E0,0.0E0,
CS   7          0.0E0,0.0E0,0.0E0,0.0E0,1.0E0/
CS    DATA  AR2/1.0E0,9.0E0,6.0E1,0.0E0,-3.0E0,-5.1E1,-3.6E2,0.0E0,
CS   1          1.0E0,1.8E1,3.45E2,2.52E3,0.0E0,0.0E0,-3.0E0,-3.3E1,
CS   2          -1.2E2,1.0E0,1.5E1,1.92E2,7.2E2,0.0E0,-4.0E0,-9.6E1,
CS   3          -1.32E3,-5.04E3,0.0E0,3.0E0,7.8E1,2.74E2,0.0E0,-2.7E1,
CS   4          -5.7E2,-1.764E3,0.0E0,4.0E0,2.46E2,4.666E3,1.3068E4,
CS   5          0.0E0,0.0E0,-1.8E1,-2.25E2,0.0E0,3.0E0,1.5E2,1.624E3,
CS   6          0.0E0,0.0E0,-3.6E1,-1.32E3,-1.3132E4,0.0E0,0.0E0,3.0E0,
CS   7          8.5E1,0.0E0,0.0E0,-4.5E1,-7.35E2,0.0E0,0.0E0,6.0E0,
CS   8          5.5E2,6.769E3,0.0E0,0.0E0,0.0E0,-1.5E1,0.0E0,0.0E0,
CS   9          3.0E0,1.75E2,0.0E0,0.0E0,0.0E0,-6.0E1,-1.96E3,0.0E0,
CS   a          0.0E0,0.0E0,1.0E0,0.0E0,0.0E0,0.0E0,-2.1E1,0.0E0,0.0E0,
CS   b          0.0E0,4.0E0,3.22E2,0.0E0,0.0E0,0.0E0,0.0E0,0.0E0,0.0E0,
CS   c          0.0E0,1.0E0,0.0E0,0.0E0,0.0E0,0.0E0,-2.8E1,0.0E0,0.0E0,
CS   d          0.0E0,0.0E0,0.0E0,0.0E0,0.0E0,0.0E0,0.0E0,0.0E0,0.0E0,
CS   e          0.0E0,1.0E0/
CD    DATA  AR1/0.0D0,1.0D0,0.0D0,-1.0D0,0.0D0,1.0D0,3.0D0,0.0D0,-2.0D0,
CD   1          -1.2D1,0.0D0,1.0D0,0.0D0,-1.0D0,1.0D0,2.0D0,0.0D0,
CD   2          -2.0D0,-6.0D0,1.0D0,7.0D0,2.4D1,0.0D0,0.0D0,1.0D0,0.0D0,
CD   3          -3.0D0,0.0D0,2.0D0,1.1D1,0.0D0,-1.2D1,-5.0D1,0.0D0,
CD   4          0.0D0,0.0D0,0.0D0,1.0D0,0.0D0,0.0D0,-6.0D0,0.0D0,2.0D0,
CD   5          3.5D1,0.0D0,0.0D0,0.0D0,0.0D0,0.0D0,0.0D0,0.0D0,1.0D0,
CD   6          0.0D0,0.0D0,-1.0D1,0.0D0,0.0D0,0.0D0,0.0D0,0.0D0,0.0D0,
CD   7          0.0D0,0.0D0,0.0D0,0.0D0,1.0D0/
CD    DATA  AR2/1.0D0,9.0D0,6.0D1,0.0D0,-3.0D0,-5.1D1,-3.6D2,0.0D0,
CD   1          1.0D0,1.8D1,3.45D2,2.52D3,0.0D0,0.0D0,-3.0D0,-3.3D1,
CD   2          -1.2D2,1.0D0,1.5D1,1.92D2,7.2D2,0.0D0,-4.0D0,-9.6D1,
CD   3          -1.32D3,-5.04D3,0.0D0,3.0D0,7.8D1,2.74D2,0.0D0,-2.7D1,
CD   4          -5.7D2,-1.764D3,0.0D0,4.0D0,2.46D2,4.666D3,1.3068D4,
CD   5          0.0D0,0.0D0,-1.8D1,-2.25D2,0.0D0,3.0D0,1.5D2,1.624D3,
CD   6          0.0D0,0.0D0,-3.6D1,-1.32D3,-1.3132D4,0.0D0,0.0D0,3.0D0,
CD   7          8.5D1,0.0D0,0.0D0,-4.5D1,-7.35D2,0.0D0,0.0D0,6.0D0,
CD   8          5.5D2,6.769D3,0.0D0,0.0D0,0.0D0,-1.5D1,0.0D0,0.0D0,
CD   9          3.0D0,1.75D2,0.0D0,0.0D0,0.0D0,-6.0D1,-1.96D3,0.0D0,
CD   a          0.0D0,0.0D0,1.0D0,0.0D0,0.0D0,0.0D0,-2.1D1,0.0D0,0.0D0,
CD   b          0.0D0,4.0D0,3.22D2,0.0D0,0.0D0,0.0D0,0.0D0,0.0D0,0.0D0,
CD   c          0.0D0,1.0D0,0.0D0,0.0D0,0.0D0,0.0D0,-2.8D1,0.0D0,0.0D0,
CD   d          0.0D0,0.0D0,0.0D0,0.0D0,0.0D0,0.0D0,0.0D0,0.0D0,0.0D0,
CD   e          0.0D0,1.0D0/
      DATA IOUT/6/
C----------------------------------------------------------------------
C  Statement function for integer to float conversion
C----------------------------------------------------------------------
CS    CONV(NDUM) = REAL(NDUM)
CD    CONV(NDUM) = DBLE(NDUM)
C----------------------------------------------------------------------
C  Determine machine parameters and set constants
C----------------------------------------------------------------------
      CALL MACHAR(IBETA,IT,IRND,NGRD,MACHEP,NEGEP,IEXP,MINEXP,
     1            MAXEXP,EPS,EPSNEG,XMIN,XMAX)
      BETA = CONV(IBETA)
      AIT = CONV(IT)
      ALBETA = LOG(BETA)
      A = ZERO
      B = TWO
      JT = 0
      DELTA = XLAM - ONE 
      F = (DELTA) * (XLAM+ONE) * HALF
C----------------------------------------------------------------------
C  Random argument accuracy tests
C----------------------------------------------------------------------
      DO 300 J = 1, 4
C----------------------------------------------------------------------
C  Determine the number of terms needed for convergence of the series
C  used in the multiplication theorem.  Use Newton iteration on the
C  asymptotic form of the convergence check for I0(X).
C----------------------------------------------------------------------
         XBAD = B
         D = AIT * ALBETA - C + ONE
         E = LOG(XBAD * F) + ONE
         AKK = ONE
  100    AK = AKK
            Z = D + E*AK - (AK+HALF) * LOG(AK+ONE)
            ZZ = E - (AK+HALF)/(AK+ONE) - LOG(AK+ONE)
            AKK = AK - Z/ZZ
         IF (ABS(AK-AKK) .GT. HUND*EPS*AK) GO TO 100
         MBORG = INT(AKK) + 1
         N = 2000
         XN = CONV(N)
         K1 = 0
         K2 = 0
         K3 = 0
         X1 = ZERO
         A1 = ZERO
         R6 = ZERO
         R7 = ZERO
         DEL = (B - A) / XN
         XL = A
         DO 200 I = 1, N
            MB = MBORG
            X = DEL * REN(JT) + XL
            ALPHA = REN(JT)
            IZE = 1
C----------------------------------------------------------------------
C   Carefully purify arguments
C----------------------------------------------------------------------
            IF (J .EQ. 1) THEN
                  Y = X/XLAM
               ELSE
                  Y = X - DELTA
            END IF
            W = SIXTEN * Y
            T1 = W + Y
            T1 = W + T1
            Y = T1 - W
            Y = Y - W
            IF (J .EQ. 1) THEN
                  X = Y * XLAM
               ELSE
                  X = Y + DELTA
            END IF
            CALL RIBESL(Y,ALPHA,MB,IZE,U2,NCALC)
            IF (J .EQ. 1) THEN
C----------------------------------------------------------------------
C   Accuracy test is based on the multiplication theorem
C----------------------------------------------------------------------
                  D = F*Y
                  MB = NCALC - 2
                  XMB = CONV(MB)
                  SUM = U2(MB+1)
                  IND = MB
                  DO 155 II = 2, MB
                     SUM = SUM * D / XMB + U2(IND)
                     IND = IND - 1
                     XMB = XMB - ONE
  155             CONTINUE
                  ZZ = SUM * D + U2(IND)
                  ZZ = ZZ * XLAM ** ALPHA
               ELSE
C----------------------------------------------------------------------
C   Accuracy test is based on local Taylor's series expansion
C----------------------------------------------------------------------
                  YSQ = Y * Y
                  ALPHSQ = ALPHA * ALPHA
                  MB = 8
                  J1 = MB
                  XJ1 = CONV(J1+1)
                  IEXP = 0
                  NK = 13
                  NUM = 2
                  DO 180 II = 1, MB
                     IF (NK .EQ. 0) THEN 
                           NK = 11 
                           NUM = 1
                     END IF
                     K = 9 - J1
                     IF (K .GT. 1) THEN
                           NO1 = NDX2(K-1) + 1
                        ELSE
                           NO1 = 1
                     END IF
                     MVR = NO1
                     LAST = NDX2(K)
                     K = LAST - NO1 + 1
C----------------------------------------------------------------------
C         Group I(ALPHA) terms in the derivative
C----------------------------------------------------------------------
                     DO 160 III = 1, K
                        J2 = NDX(MVR)
                        IF (NUM .EQ. 1) THEN
                              G(III) = AR1(NK,J2)
                           ELSE
                              G(III) = AR2(NK,J2)
                        END IF
                        IF (J2 .GT. 1) THEN
  157                         J2 = J2 - 1
                              IF (NUM .EQ. 1) THEN
                                    G(III) = G(III) * ALPHA + AR1(NK,J2)
                                 ELSE
                                    G(III) = G(III) * ALPHA + AR2(NK,J2)
                              END IF
                           IF (J2 .GT. 1) GO TO 157
                        END IF
                        MVR = MVR + 1
                        NK = NK - 1
  160                CONTINUE
                     T1 = G(1)
                     DO 162 III = 2, K
                        T1 = T1 / YSQ + G(III)
  162                CONTINUE
                     IF (IEXP .EQ. 1) T1 = T1 / Y
C----------------------------------------------------------------------
C         Group I(ALPHA+1) terms in the derivative
C----------------------------------------------------------------------
                     IEXP = 1 - IEXP
                     NK = NK + K
                     MVR = NO1
                     KK = K
                     DO 165 III = 1, K
                        J2 = NDX(MVR)
                        M = MOD(J2,2)
                        IF (M .EQ. 1) J2 = J2 - 1
                        IF (J2 .GE. 2) THEN
                              IF (NUM .EQ. 1) THEN
                                    G(III) = AR1(NK,J2)
                                 ELSE
                                    G(III) = AR2(NK,J2)
                              END IF
  163                         J2 = J2 - 2
                              IF (J2 .GE. 2) THEN
                                    IF (NUM .EQ. 1) THEN
                                          G(III) = G(III) * ALPHSQ +
     1                                             AR1(NK,J2)
                                       ELSE
                                          G(III) = G(III) * ALPHSQ +
     1                                             AR2(NK,J2)
                                    END IF
                                    GO TO 163
                              END IF
                           ELSE
                              KK = III - 1
                        END IF
                        MVR = MVR + 1
                        NK = NK - 1
  165                CONTINUE
                     T2 = G(1)
                     DO 167 III = 2, KK
                        T2 = T2 / YSQ + G(III)
  167                CONTINUE
                     IF (IEXP .EQ. 1) T2 = T2 / Y
                     DERIV = U2(1) * T1 + U2(2) * T2
                     IF (J1 .EQ. 8) THEN
                           SUM = DERIV
                        ELSE
                           SUM = SUM * DELTA / XJ1 + DERIV
                     END IF
                     J1 = J1 - 1
                     XJ1 = XJ1 - ONE
  180             CONTINUE
                  ZZ = SUM * DELTA + U2(1)
            END IF
            MB = 2 
            CALL RIBESL(X,ALPHA,MB,IZE,U,NCALC)
            Z = U(1)
C----------------------------------------------------------------------
C   Accumulate Results
C----------------------------------------------------------------------
            W = (Z - ZZ) / Z
            IF (W .GT. ZERO) THEN 
                  K1 = K1 + 1
               ELSE IF (W .LT. ZERO) THEN 
                  K3 = K3 + 1
            END IF
            W = ABS(W)
            IF (W .GT. R6) THEN
                  R6 = W
                  X1 = X
                  A1 = ALPHA
            END IF
            R7 = R7 + W * W
            XL = XL + DEL
  200    CONTINUE
C----------------------------------------------------------------------
C   Gather and print statistics for test
C----------------------------------------------------------------------
         K2 = N - K1 - K3
         R7 = SQRT(R7/XN)
         IF (J .EQ. 1) THEN
               WRITE (IOUT,1000)
            ELSE
               WRITE (IOUT,1001)
         END IF
         WRITE (IOUT,1010) N,A,B
         WRITE (IOUT,1011) K1,K2,K3
         WRITE (IOUT,1020) IT,IBETA
         IF (R6 .NE. ZERO) THEN
               W = LOG(R6)/ALBETA
            ELSE
               W = X99
         END IF
         WRITE (IOUT,1021) R6,IBETA,W,X1,A1
         W = MAX(AIT+W,ZERO)
         WRITE (IOUT,1022) IBETA,W
         IF (R7 .NE. ZERO) THEN
               W = LOG(R7)/ALBETA
            ELSE
               W = X99
         END IF
         WRITE (IOUT,1023) R7,IBETA,W
         W = MAX(AIT+W,ZERO)
         WRITE (IOUT,1022) IBETA,W
C----------------------------------------------------------------------
C   Initialize for next test
C----------------------------------------------------------------------
         A = B
         B = B + B
         IF (J .EQ. 2) B = TEN
  300 CONTINUE
C----------------------------------------------------------------------
C   Test of error returns
C
C   First, test with bad parameters
C----------------------------------------------------------------------
      WRITE (IOUT, 2006)
      X = ONE 
      ALPHA = ONE + HALF
      MB = 5
      IZE = 2
      U(1) = ZERO
      CALL RIBESL(X,ALPHA,MB,IZE,U,NCALC)
      WRITE (IOUT, 2011) X,ALPHA,MB,IZE,U(1),NCALC
      ALPHA = HALF
      MB = -MB
      CALL RIBESL(X,ALPHA,MB,IZE,U,NCALC)
      WRITE (IOUT, 2011) X,ALPHA,MB,IZE,U(1),NCALC
      MB = -MB
      IZE = 5
      CALL RIBESL(X,ALPHA,MB,IZE,U,NCALC)
      WRITE (IOUT, 2011) X,ALPHA,MB,IZE,U(1),NCALC
C----------------------------------------------------------------------
C   Last tests are with extreme parameters
C----------------------------------------------------------------------
      X = ZERO
      ALPHA = REN(JT)
      MB = 2
      IZE = 1
      U(1) = ZERO
      CALL RIBESL(X,ALPHA,MB,IZE,U,NCALC)
      WRITE (IOUT, 2011) X,ALPHA,MB,IZE,U(1),NCALC
      ALPHA = ZERO
      MB = 2
      U(1) = ZERO
      CALL RIBESL(X,ALPHA,MB,IZE,U,NCALC)
      WRITE (IOUT, 2011) X,ALPHA,MB,IZE,U(1),NCALC
      ALPHA = ONE
      MB = 2
      U(1) = ZERO
      CALL RIBESL(X,ALPHA,MB,IZE,U,NCALC)
      WRITE (IOUT, 2011) X,ALPHA,MB,IZE,U(1),NCALC
      X = -ONE
      ALPHA = HALF
      MB = 5
      IZE = 2
      U(1) = ZERO
      CALL RIBESL(X,ALPHA,MB,IZE,U,NCALC)
      WRITE (IOUT, 2012) X
      WRITE (IOUT, 2013)
      WRITE (IOUT, 2014) NCALC,U(1)
C----------------------------------------------------------------------
C   Determine largest safe argument for scaled functions
C----------------------------------------------------------------------
      WRITE (IOUT, 2015)
      X = XLARGE * (ONE - SQRT(SQRT(EPS)))
      IZE = 2
      MB = 2
      U(1) = ZERO
      CALL RIBESL(X,ALPHA,MB,IZE,U,NCALC)
      WRITE (IOUT, 2012) X
      WRITE (IOUT, 2014) NCALC,U(1)
      X = XLARGE * (ONE + SQRT(SQRT(EPS)))
      MB = 2
      U(1) = ZERO
      CALL RIBESL(X,ALPHA,MB,IZE,U,NCALC)
      WRITE (IOUT, 2012) X
      WRITE (IOUT, 2013)
      WRITE (IOUT, 2014) NCALC,U(1)
C----------------------------------------------------------------------
C   Determine largest safe argument for unscaled functions
C----------------------------------------------------------------------
      WRITE (IOUT, 2016)
      N = INT(LOG(XMAX))
      Z = CONV(N)
      X = Z * (ONE - SQRT(SQRT(EPS)))
      IZE = 1
      MB = 2
      U(1) = ZERO
      CALL RIBESL(X,ALPHA,MB,IZE,U,NCALC)
      WRITE (IOUT, 2012) X
      WRITE (IOUT, 2014) NCALC,U(1)
      X = Z * (ONE + SQRT(SQRT(EPS)))
      MB = 2
      U(1) = ZERO
      CALL RIBESL(X,ALPHA,MB,IZE,U,NCALC)
      WRITE (IOUT, 2012) X
      WRITE (IOUT, 2013)
      WRITE (IOUT, 2014) NCALC,U(1)
      WRITE (IOUT, 2020)
      STOP
C----------------------------------------------------------------------
 1000 FORMAT('1Test of I(X,ALPHA) vs Multiplication Theorem'//)
 1001 FORMAT('1Test of I(X,ALPHA) vs Taylor series'//)
 1010 FORMAT(I7,' Random arguments were tested from the interval ',
     1    '(',F5.2,',',F5.2,')'//)
 1011 FORMAT(' I(X,ALPHA) was larger',I6,' times,'/
     1    15X,' agreed',I6,' times, and'/
     1    11X,'was smaller',I6,' times.'//)
 1020 FORMAT(' There are',I4,' base',I4,
     1    ' significant digits in a floating-point number'//)
 1021 FORMAT(' The maximum relative error of',E15.4,' = ',I4,' **',
     1    F7.2/4X,'occurred for X =',E13.6,' and NU =',E13.6)
 1022 FORMAT(' The estimated loss of base',I4,
     1    ' significant digits is',F7.2//)
 1023 FORMAT(' The root mean square relative error was',E15.4,
     1    ' = ',I4,' **',F7.2)
 2006 FORMAT('1Check of Error Returns'///
     1    ' The following summarizes calls with indicated parameters'//
     2    ' NCALC different from MB indicates some form of error'//
     3    ' See documentation for RIBESL for details'//
     4    7X,'ARG',12X,'ALPHA',6X,'MB',3X,'IZ',7X,'RES',6X,'NCALC'//)
 2011 FORMAT(2E15.7,2I5,E15.7,I5//)
 2012 FORMAT(' RIBESL will be called with the argument',E13.6)
 2013 FORMAT(' This should trigger an error message.')
 2014 FORMAT(' NCALC returned the value',I5/
     1    ' and RIBESL returned the value',E13.6/)
 2015 FORMAT(' Tests near the largest argument for scaled functions'/)
 2016 FORMAT(' Tests near the largest argument for unscaled functions'/)
 2020 FORMAT(' This concludes the tests.') 
C     ---------- Last line of RIBESL test program ---------- 
      END

      SUBROUTINE RJBESL(X, ALPHA, NB, B, NCALC)
C---------------------------------------------------------------------
C This routine calculates Bessel functions J sub(N+ALPHA) (X)
C   for non-negative argument X, and non-negative order N+ALPHA.
C
C
C  Explanation of variables in the calling sequence.
C
C   X     - working precision non-negative real argument for which
C           J's are to be calculated.
C   ALPHA - working precision fractional part of order for which
C           J's or exponentially scaled J'r (J*exp(X)) are
C           to be calculated.  0 <= ALPHA < 1.0.
C   NB  - integer number of functions to be calculated, NB > 0.
C           The first function calculated is of order ALPHA, and the
C           last is of order (NB - 1 + ALPHA).
C   B  - working precision output vector of length NB.  If RJBESL
C           terminates normally (NCALC=NB), the vector B contains the
C           functions J/ALPHA/(X) through J/NB-1+ALPHA/(X), or the
C           corresponding exponentially scaled functions.
C   NCALC - integer output variable indicating possible errors.
C           Before using the vector B, the user should check that
C           NCALC=NB, i.e., all orders have been calculated to
C           the desired accuracy.  See Error Returns below.
C
C
C*******************************************************************
C*******************************************************************
C
C Explanation of machine-dependent constants.  Let
C
C   it     = Number of bits in the mantissa of a working precision
C            variable
C   NSIG   = Decimal significance desired.  Should be set to
C            INT(LOG10(2)*it+1).  Setting NSIG lower will result
C            in decreased accuracy while setting NSIG higher will
C            increase CPU time without increasing accuracy.  The
C            truncation error is limited to a relative error of
C            T=.5*10**(-NSIG).
C
C Then the following machine-dependent constants must be declared
C   in DATA statements.  IEEE values are provided as a default.
C
C   ENTEN  = 10.0 ** K, where K is the largest integer such that
C            ENTEN is machine-representable in working precision
C   ENSIG  = 10.0 ** NSIG
C   RTNSIG = 10.0 ** (-K) for the smallest integer K such that
C            K .GE. NSIG/4
C   ENMTEN = Smallest ABS(X) such that X/4 does not underflow
C   XLARGE = Upper limit on the magnitude of X.  If ABS(X)=N,
C            then at least N iterations of the backward recursion
C            will be executed.  The value of 10.0 ** 4 is used on
C            every machine.
C
C
C     Approximate values for some important machines are:
C
C
C                            it    NSIG    ENTEN       ENSIG
C
C   CRAY-1        (S.P.)     48     15    1.0E+2465   1.0E+15
C   Cyber 180/855
C     under NOS   (S.P.)     48     15    1.0E+322    1.0E+15
C   IEEE (IBM/XT,
C     SUN, etc.)  (S.P.)     24      8    1.0E+38     1.0E+8
C   IEEE (IBM/XT,
C     SUN, etc.)  (D.P.)     53     16    1.0D+308    1.0D+16
C   IBM 3033      (D.P.)     14      5    1.0D+75     1.0D+5
C   VAX           (S.P.)     24      8    1.0E+38     1.0E+8
C   VAX D-Format  (D.P.)     56     17    1.0D+38     1.0D+17
C   VAX G-Format  (D.P.)     53     16    1.0D+307    1.0D+16
C
C
C                           RTNSIG      ENMTEN      XLARGE
C
C   CRAY-1        (S.P.)    1.0E-4    1.84E-2466   1.0E+4
C   Cyber 180/855
C     under NOS   (S.P.)    1.0E-4    1.25E-293    1.0E+4
C   IEEE (IBM/XT,
C     SUN, etc.)  (S.P.)    1.0E-2    4.70E-38     1.0E+4
C   IEEE (IBM/XT,
C     SUN, etc.)  (D.P.)    1.0E-4    8.90D-308    1.0D+4
C   IBM 3033      (D.P.)    1.0E-2    2.16D-78     1.0D+4
C   VAX           (S.P.)    1.0E-2    1.17E-38     1.0E+4
C   VAX D-Format  (D.P.)    1.0E-5    1.17D-38     1.0D+4
C   VAX G-Format  (D.P.)    1.0E-4    2.22D-308    1.0D+4
C
C*******************************************************************
C*******************************************************************
C
C  Error returns
C
C    In case of an error,  NCALC .NE. NB, and not all J's are
C    calculated to the desired accuracy.
C
C    NCALC .LT. 0:  An argument is out of range. For example,
C       NBES .LE. 0, ALPHA .LT. 0 or .GT. 1, or X is too large.
C       In this case, B(1) is set to zero, the remainder of the
C       B-vector is not calculated, and NCALC is set to
C       MIN(NB,0)-1 so that NCALC .NE. NB.
C
C    NB .GT. NCALC .GT. 0: Not all requested function values could
C       be calculated accurately.  This usually occurs because NB is
C       much larger than ABS(X).  In this case, B(N) is calculated
C       to the desired accuracy for N .LE. NCALC, but precision
C       is lost for NCALC .LT. N .LE. NB.  If B(N) does not vanish
C       for N .GT. NCALC (because it is too small to be represented),
C       and B(N)/B(NCALC) = 10**(-K), then only the first NSIG-K
C       significant figures of B(N) can be trusted.
C
C
C  Intrinsic and other functions required are:
C
C     ABS, AINT, COS, DBLE, GAMMA (or DGAMMA), INT, MAX, MIN,
C
C     REAL, SIN, SQRT
C
C
C  Acknowledgement
C
C   This program is based on a program written by David J. Sookne
C   (2) that computes values of the Bessel functions J or I of real
C   argument and integer order.  Modifications include the restriction
C   of the computation to the J Bessel function of non-negative real
C   argument, the extension of the computation to arbitrary positive
C   order, and the elimination of most underflow.
C
C  References: "A Note on Backward Recurrence Algorithms," Olver,
C               F. W. J., and Sookne, D. J., Math. Comp. 26, 1972,
C               pp 941-947.
C
C              "Bessel Functions of Real Argument and Integer Order,"
C               Sookne, D. J., NBS Jour. of Res. B. 77B, 1973, pp
C               125-132.
C
C  Latest modification: March 15, 1992
C
C  Author: W. J. Cody
C          Applied Mathematics Division
C          Argonne National Laboratory
C          Argonne, IL  60439
C
C---------------------------------------------------------------------
      INTEGER I,J,K,L,M,MAGX,N,NB,NBMX,NCALC,NEND,NSTART
CS    REAL               GAMMA,
CD    DOUBLE PRECISION  DGAMMA,
     1 ALPHA,ALPEM,ALP2EM,B,CAPP,CAPQ,CONV,EIGHTH,EM,EN,ENMTEN,ENSIG,
     2 ENTEN,FACT,FOUR,FUNC,GNU,HALF,HALFX,ONE,ONE30,P,PI2,PLAST,
     3 POLD,PSAVE,PSAVEL,RTNSIG,S,SUM,T,T1,TEMPA,TEMPB,TEMPC,TEST,
     4 THREE,THREE5,TOVER,TWO,TWOFIV,TWOPI1,TWOPI2,X,XC,XIN,XK,XLARGE,
     5 XM,VCOS,VSIN,Z,ZERO
      DIMENSION B(NB), FACT(25)
C---------------------------------------------------------------------
C  Mathematical constants
C
C   PI2    - 2 / PI
C   TWOPI1 - first few significant digits of 2 * PI
C   TWOPI2 - (2*PI - TWOPI) to working precision, i.e.,
C            TWOPI1 + TWOPI2 = 2 * PI to extra precision.
C---------------------------------------------------------------------
CS    DATA PI2, TWOPI1, TWOPI2 /0.636619772367581343075535E0,6.28125E0,
CS   1 1.935307179586476925286767E-3/
CS    DATA ZERO, EIGHTH, HALF, ONE /0.0E0,0.125E0,0.5E0,1.0E0/
CS    DATA TWO, THREE, FOUR, TWOFIV /2.0E0,3.0E0,4.0E0,25.0E0/
CS    DATA ONE30, THREE5 /130.0E0,35.0E0/
CD    DATA PI2, TWOPI1, TWOPI2 /0.636619772367581343075535D0,6.28125D0,
CD   1 1.935307179586476925286767D-3/
CD    DATA ZERO, EIGHTH, HALF, ONE /0.0D0,0.125D0,0.5D0,1.0D0/
CD    DATA TWO, THREE, FOUR, TWOFIV /2.0D0,3.0D0,4.0D0,25.0D0/
CD    DATA ONE30, THREE5 /130.0D0,35.0D0/
C---------------------------------------------------------------------
C  Machine-dependent parameters
C---------------------------------------------------------------------
CS    DATA ENTEN, ENSIG, RTNSIG /1.0E38,1.0E8,1.0E-2/
CS    DATA ENMTEN, XLARGE /4.70E-38,1.0E4/
CD    DATA ENTEN, ENSIG, RTNSIG /1.0D308,1.0D16,1.0D-4/
CD    DATA ENMTEN, XLARGE /8.90D-308,1.0D4/
C---------------------------------------------------------------------
C     Factorial(N)
C---------------------------------------------------------------------
CS    DATA FACT /1.0E0,1.0E0,2.0E0,6.0E0,24.0E0,1.2E2,7.2E2,5.04E3,
CS   1 4.032E4,3.6288E5,3.6288E6,3.99168E7,4.790016E8,6.2270208E9,
CS   2 8.71782912E10,1.307674368E12,2.0922789888E13,3.55687428096E14,
CS   3 6.402373705728E15,1.21645100408832E17,2.43290200817664E18,
CS   4 5.109094217170944E19,1.12400072777760768E21,
CS   5 2.585201673888497664E22,6.2044840173323943936E23/
CD    DATA FACT /1.0D0,1.0D0,2.0D0,6.0D0,24.0D0,1.2D2,7.2D2,5.04D3,
CD   1 4.032D4,3.6288D5,3.6288D6,3.99168D7,4.790016D8,6.2270208D9,
CD   2 8.71782912D10,1.307674368D12,2.0922789888D13,3.55687428096D14,
CD   3 6.402373705728D15,1.21645100408832D17,2.43290200817664D18,
CD   4 5.109094217170944D19,1.12400072777760768D21,
CD   5 2.585201673888497664D22,6.2044840173323943936D23/
C---------------------------------------------------------------------
C Statement functions for conversion and the gamma function.
C---------------------------------------------------------------------
CS    CONV(I) = REAL(I)
CS    FUNC(X) = GAMMA(X)
CD    CONV(I) = DBLE(I)
CD    FUNC(X) = DGAMMA(X)
C---------------------------------------------------------------------
C Check for out of range arguments.
C---------------------------------------------------------------------
      MAGX = INT(X)
      IF ((NB.GT.0) .AND. (X.GE.ZERO) .AND. (X.LE.XLARGE)
     1       .AND. (ALPHA.GE.ZERO) .AND. (ALPHA.LT.ONE))
     2   THEN
C---------------------------------------------------------------------
C Initialize result array to zero.
C---------------------------------------------------------------------
            NCALC = NB
            DO 20 I=1,NB
              B(I) = ZERO
   20       CONTINUE
C---------------------------------------------------------------------
C Branch to use 2-term ascending series for small X and asymptotic
C form for large X when NB is not too large.
C---------------------------------------------------------------------
            IF (X.LT.RTNSIG) THEN
C---------------------------------------------------------------------
C Two-term ascending series for small X.
C---------------------------------------------------------------------
               TEMPA = ONE
               ALPEM = ONE + ALPHA
               HALFX = ZERO
               IF (X.GT.ENMTEN) HALFX = HALF*X
               IF (ALPHA.NE.ZERO)
     1            TEMPA = HALFX**ALPHA/(ALPHA*FUNC(ALPHA))
               TEMPB = ZERO
               IF ((X+ONE).GT.ONE) TEMPB = -HALFX*HALFX
               B(1) = TEMPA + TEMPA*TEMPB/ALPEM
               IF ((X.NE.ZERO) .AND. (B(1).EQ.ZERO)) NCALC = 0
               IF (NB .NE. 1) THEN
                  IF (X .LE. ZERO) THEN
                        DO 30 N=2,NB
                          B(N) = ZERO
   30                   CONTINUE
                     ELSE
C---------------------------------------------------------------------
C Calculate higher order functions.
C---------------------------------------------------------------------
                        TEMPC = HALFX
                        TOVER = (ENMTEN+ENMTEN)/X
                        IF (TEMPB.NE.ZERO) TOVER = ENMTEN/TEMPB
                        DO 50 N=2,NB
                          TEMPA = TEMPA/ALPEM
                          ALPEM = ALPEM + ONE
                          TEMPA = TEMPA*TEMPC
                          IF (TEMPA.LE.TOVER*ALPEM) TEMPA = ZERO
                          B(N) = TEMPA + TEMPA*TEMPB/ALPEM
                          IF ((B(N).EQ.ZERO) .AND. (NCALC.GT.N))
     1                       NCALC = N-1
   50                   CONTINUE
                  END IF
               END IF
            ELSE IF ((X.GT.TWOFIV) .AND. (NB.LE.MAGX+1)) THEN
C---------------------------------------------------------------------
C Asymptotic series for X .GT. 21.0.
C---------------------------------------------------------------------
               XC = SQRT(PI2/X)
               XIN = (EIGHTH/X)**2
               M = 11
               IF (X.GE.THREE5) M = 8
               IF (X.GE.ONE30) M = 4
               XM = FOUR*CONV(M)
C---------------------------------------------------------------------
C Argument reduction for SIN and COS routines.
C---------------------------------------------------------------------
               T = AINT(X/(TWOPI1+TWOPI2)+HALF)
               Z = ((X-T*TWOPI1)-T*TWOPI2) - (ALPHA+HALF)/PI2
               VSIN = SIN(Z)
               VCOS = COS(Z)
               GNU = ALPHA + ALPHA
               DO 80 I=1,2
                 S = ((XM-ONE)-GNU)*((XM-ONE)+GNU)*XIN*HALF
                 T = (GNU-(XM-THREE))*(GNU+(XM-THREE))
                 CAPP = S*T/FACT(2*M+1)
                 T1 = (GNU-(XM+ONE))*(GNU+(XM+ONE))
                 CAPQ = S*T1/FACT(2*M+2)
                 XK = XM
                 K = M + M
                 T1 = T
                 DO 70 J=2,M
                   XK = XK - FOUR
                   S = ((XK-ONE)-GNU)*((XK-ONE)+GNU)
                   T = (GNU-(XK-THREE))*(GNU+(XK-THREE))
                   CAPP = (CAPP+ONE/FACT(K-1))*S*T*XIN
                   CAPQ = (CAPQ+ONE/FACT(K))*S*T1*XIN
                   K = K - 2
                   T1 = T
   70            CONTINUE
                 CAPP = CAPP + ONE
                 CAPQ = (CAPQ+ONE)*(GNU*GNU-ONE)*(EIGHTH/X)
                 B(I) = XC*(CAPP*VCOS-CAPQ*VSIN)
                 IF (NB.EQ.1) GO TO 300
                 T = VSIN
                 VSIN = -VCOS
                 VCOS = T
                 GNU = GNU + TWO
   80         CONTINUE
C---------------------------------------------------------------------
C If  NB .GT. 2, compute J(X,ORDER+I)  I = 2, NB-1
C---------------------------------------------------------------------
               IF (NB .GT. 2) THEN
                  GNU = ALPHA + ALPHA + TWO
                  DO 90 J=3,NB
                    B(J) = GNU*B(J-1)/X - B(J-2)
                    GNU = GNU + TWO
   90             CONTINUE
               END IF
C---------------------------------------------------------------------
C Use recurrence to generate results.  First initialize the
C calculation of P*S.
C---------------------------------------------------------------------
            ELSE
               NBMX = NB - MAGX
               N = MAGX + 1
               EN = CONV(N+N) + (ALPHA+ALPHA)
               PLAST = ONE
               P = EN/X
C---------------------------------------------------------------------
C Calculate general significance test.
C---------------------------------------------------------------------
               TEST = ENSIG + ENSIG
               IF (NBMX .GE. 3) THEN
C---------------------------------------------------------------------
C Calculate P*S until N = NB-1.  Check for possible overflow.
C---------------------------------------------------------------------
                  TOVER = ENTEN/ENSIG
                  NSTART = MAGX + 2
                  NEND = NB - 1
                  EN = CONV(NSTART+NSTART) - TWO + (ALPHA+ALPHA)
                  DO 130 K=NSTART,NEND
                     N = K
                     EN = EN + TWO
                     POLD = PLAST
                     PLAST = P
                     P = EN*PLAST/X - POLD
                     IF (P.GT.TOVER) THEN
C---------------------------------------------------------------------
C To avoid overflow, divide P*S by TOVER.  Calculate P*S until
C ABS(P) .GT. 1.
C---------------------------------------------------------------------
                        TOVER = ENTEN
                        P = P/TOVER
                        PLAST = PLAST/TOVER
                        PSAVE = P
                        PSAVEL = PLAST
                        NSTART = N + 1
  100                   N = N + 1
                           EN = EN + TWO
                           POLD = PLAST
                           PLAST = P
                           P = EN*PLAST/X - POLD
                        IF (P.LE.ONE) GO TO 100
                        TEMPB = EN/X
C---------------------------------------------------------------------
C Calculate backward test and find NCALC, the highest N such that
C the test is passed.
C---------------------------------------------------------------------
                        TEST = POLD*PLAST*(HALF-HALF/(TEMPB*TEMPB))
                        TEST = TEST/ENSIG
                        P = PLAST*TOVER
                        N = N - 1
                        EN = EN - TWO
                        NEND = MIN(NB,N)
                        DO 110 L=NSTART,NEND
                           POLD = PSAVEL
                           PSAVEL = PSAVE
                           PSAVE = EN*PSAVEL/X - POLD
                           IF (PSAVE*PSAVEL.GT.TEST) THEN
                              NCALC = L - 1
                              GO TO 190
                           END IF
  110                   CONTINUE
                        NCALC = NEND
                        GO TO 190
                     END IF
  130             CONTINUE
                  N = NEND
                  EN = CONV(N+N) + (ALPHA+ALPHA)
C---------------------------------------------------------------------
C Calculate special significance test for NBMX .GT. 2.
C---------------------------------------------------------------------
                  TEST = MAX(TEST,SQRT(PLAST*ENSIG)*SQRT(P+P))
               END IF
C---------------------------------------------------------------------
C Calculate P*S until significance test passes.
C---------------------------------------------------------------------
  140          N = N + 1
                  EN = EN + TWO
                  POLD = PLAST
                  PLAST = P
                  P = EN*PLAST/X - POLD
               IF (P.LT.TEST) GO TO 140
C---------------------------------------------------------------------
C Initialize the backward recursion and the normalization sum.
C---------------------------------------------------------------------
  190          N = N + 1
               EN = EN + TWO
               TEMPB = ZERO
               TEMPA = ONE/P
               M = 2*N - 4*(N/2)
               SUM = ZERO
               EM = CONV(N/2)
               ALPEM = (EM-ONE) + ALPHA
               ALP2EM = (EM+EM) + ALPHA
               IF (M .NE. 0) SUM = TEMPA*ALPEM*ALP2EM/EM
               NEND = N - NB
               IF (NEND .GT. 0) THEN
C---------------------------------------------------------------------
C Recur backward via difference equation, calculating (but not
C storing) B(N), until N = NB.
C---------------------------------------------------------------------
                  DO 200 L=1,NEND
                     N = N - 1
                     EN = EN - TWO
                     TEMPC = TEMPB
                     TEMPB = TEMPA
                     TEMPA = (EN*TEMPB)/X - TEMPC
                     M = 2 - M
                     IF (M .NE. 0) THEN
                        EM = EM - ONE
                        ALP2EM = (EM+EM) + ALPHA
                        IF (N.EQ.1) GO TO 210
                        ALPEM = (EM-ONE) + ALPHA
                        IF (ALPEM.EQ.ZERO) ALPEM = ONE
                        SUM = (SUM+TEMPA*ALP2EM)*ALPEM/EM
                     END IF
  200             CONTINUE
               END IF
C---------------------------------------------------------------------
C Store B(NB).
C---------------------------------------------------------------------
  210          B(N) = TEMPA
               IF (NEND .GE. 0) THEN
                  IF (NB .LE. 1) THEN
                        ALP2EM = ALPHA
                        IF ((ALPHA+ONE).EQ.ONE) ALP2EM = ONE
                        SUM = SUM + B(1)*ALP2EM
                        GO TO 250
                     ELSE
C---------------------------------------------------------------------
C Calculate and store B(NB-1).
C---------------------------------------------------------------------
                        N = N - 1
                        EN = EN - TWO
                        B(N) = (EN*TEMPA)/X - TEMPB
                        IF (N.EQ.1) GO TO 240
                        M = 2 - M
                        IF (M .NE. 0) THEN
                           EM = EM - ONE
                           ALP2EM = (EM+EM) + ALPHA
                           ALPEM = (EM-ONE) + ALPHA
                           IF (ALPEM.EQ.ZERO) ALPEM = ONE
                           SUM = (SUM+B(N)*ALP2EM)*ALPEM/EM
                        END IF
                  END IF
               END IF
               NEND = N - 2
               IF (NEND .NE. 0) THEN
C---------------------------------------------------------------------
C Calculate via difference equation and store B(N), until N = 2.
C---------------------------------------------------------------------
                  DO 230 L=1,NEND
                     N = N - 1
                     EN = EN - TWO
                     B(N) = (EN*B(N+1))/X - B(N+2)
                     M = 2 - M
                     IF (M .NE. 0) THEN
                        EM = EM - ONE
                        ALP2EM = (EM+EM) + ALPHA
                        ALPEM = (EM-ONE) + ALPHA
                        IF (ALPEM.EQ.ZERO) ALPEM = ONE
                        SUM = (SUM+B(N)*ALP2EM)*ALPEM/EM
                     END IF
  230             CONTINUE
               END IF
C---------------------------------------------------------------------
C Calculate B(1).
C---------------------------------------------------------------------
               B(1) = TWO*(ALPHA+ONE)*B(2)/X - B(3)
  240          EM = EM - ONE
               ALP2EM = (EM+EM) + ALPHA
               IF (ALP2EM.EQ.ZERO) ALP2EM = ONE
               SUM = SUM + B(1)*ALP2EM
C---------------------------------------------------------------------
C Normalize.  Divide all B(N) by sum.
C---------------------------------------------------------------------
  250          IF ((ALPHA+ONE).NE.ONE)
     1              SUM = SUM*FUNC(ALPHA)*(X*HALF)**(-ALPHA)
               TEMPA = ENMTEN
               IF (SUM.GT.ONE) TEMPA = TEMPA*SUM
               DO 260 N=1,NB
                 IF (ABS(B(N)).LT.TEMPA) B(N) = ZERO
                 B(N) = B(N)/SUM
  260          CONTINUE
            END IF
C---------------------------------------------------------------------
C Error return -- X, NB, or ALPHA is out of range.
C---------------------------------------------------------------------
         ELSE
            B(1) = ZERO
            NCALC = MIN(NB,0) - 1
      END IF
C---------------------------------------------------------------------
C Exit
C---------------------------------------------------------------------
  300 RETURN
C ---------- Last line of RJBESL ----------
      END

      PROGRAM RJTEST
C----------------------------------------------------------------------
C FORTRAN 77 program to test RJBESL
C
C  Method:
C
C     Two different accuracy tests are used.  In the first interval,
C     function values are compared against values generated with the
C     multiplication formula, where the Bessel values used in the
C     multiplication formula are obtained from the function program.
C     In the remaining intervals, function values are compared
C     against values generated with a local Taylor series expansion.
C     Derivatives in the expansion are expressed in terms of the
C     first two Bessel functions, which are in turn obtained from
C     the function program.
C
C  Data required
C
C     None
C
C  Subprograms required from this package
C
C     MACHAR - An environmental inquiry program providing
C         information on the floating-point arithmetic
C         system.  Note that the call to MACHAR can
C         be deleted provided the following five
C         parameters are assigned the values indicated
C
C              IBETA  - the radix of the floating-point system
C              IT     - the number of base-IBETA digits in the
C                       significant of a floating-point number
C              EPS    - the smallest positive floating-point
C                       number such that 1.0+EPS .NE. 1.0
C              XMAX   - the largest finite floating-point number
C
C     REN(K) - a function subprogram returning random real
C              numbers uniformly distributed over (0,1)
C
C
C  Intrinsic functions required are:
C
C      ABS, DBLE, INT, LOG, MAX, REAL, SQRT
C
C  Reference: "Performance evaluation of programs for certain
C              Bessel functions", W. J. Cody and L. Stoltz,
C              ACM Trans. on Math. Software, Vol. 15, 1989,
C              pp 41-48.
C
C             "Use of Taylor series to test accuracy of function
C              programs," W. J. Cody and L. Stoltz, submitted for
C              publication.
C
C  Latest modification: March 14, 1992
C
C  Author: W. J. Cody 
C          Mathematics and Computer Science Division
C          Argonne National Laboratory
C          Argonne, IL 60439
C
C Acknowledgement: this program is a minor modification of the test
C          driver for RIBESL whose primary author was Laura Stoltz.
C
C----------------------------------------------------------------------
      INTEGER I,IBETA,IEXP,II,III,IND,IOUT,IRND,IT,J,JT,J1,J2,K,KK,
     1    K1,K2,K3,LAST,M,MACHEP,MAXEXP,MB,MINEXP,MVR,N,NCALC,NDUM,
     2    NDX,NDX2,NEGEP,NGRD,NK,NO1,NUM
CS    REAL  
CD    DOUBLE PRECISION  
     1    A,AIT,ALBETA,ALPHA,ALPHSQ,A1,AR1,AR2,B,BETA,CONV,D,DEL,
     2    DELTA,DERIV,EPS,EPSNEG,F,FXMX,G,HALF,ONE,REN,RTPI,R6,
     3    R7,SIXTEN,SUM,TEN,TWO,T1,T2,U,U2,W,X,XL,XLAM,XLARGE,
     4    XMAX,XMB,XMIN,XJ1,XN,X1,X99,Y,YSQ,Z,ZERO,ZZ
      DIMENSION AR1(11,6),AR2(13,9),G(5),NDX(24),NDX2(8),U(560),U2(560)
CS    DATA ZERO,HALF,ONE,TWO/0.0E0,0.5E0,1.0E0,2.0E0/,
CS   1    TEN,SIXTEN,X99/10.0E0,1.6E1,-999.0E0/,
CS   2    XLAM,XLARGE,RTPI/1.03125E0,1.0E4,0.6366E0/
CD    DATA ZERO,HALF,ONE,TWO/0.0D0,0.5D0,1.0D0,2.0D0/,
CD   1    TEN,SIXTEN,X99/10.0D0,1.6D1,-999.0D0/,
CD   2    XLAM,XLARGE,RTPI/1.03125D0,1.0D4,0.6366D0/
C----------------------------------------------------------------------
C  Arrays related to expansion of the derivatives in terms
C   of the first two Bessel functions.
C----------------------------------------------------------------------
      DATA  NDX/9,7,5,3,1,8,6,4,2,7,5,3,1,6,4,2,5,3,1,4,2,3,1,2/
      DATA  NDX2/5,9,13,16,19,21,23,24/
CS    DATA AR1/0.0E0,-1.0E0,0.0E0,1.0E0,0.0E0,1.0E0,-3.0E0,0.0E0,-2.0E0,
CS   1         1.2E1,0.0E0,1.0E0,0.0E0,-1.0E0,-1.0E0,2.0E0,0.0E0,
CS   2         2.0E0,-6.0E0,1.0E0,-7.0E0,2.4E1,0.0E0,0.0E0,1.0E0,0.0E0,
CS   3         -3.0E0,0.0E0,-2.0E0,1.1E1,0.0E0,1.2E1,-5.0E1,0.0E0,
CS   4         0.0E0,0.0E0,0.0E0,1.0E0,0.0E0,0.0E0,-6.0E0,0.0E0,-2.0E0,
CS   5         3.5E1,0.0E0,0.0E0,0.0E0,0.0E0,0.0E0,0.0E0,0.0E0,1.0E0,
CS   6         0.0E0,0.0E0,-1.0E1,0.0E0,0.0E0,0.0E0,0.0E0,0.0E0,0.0E0,
CS   7         0.0E0,0.0E0,0.0E0,0.0E0,1.0E0/
CS    DATA AR2/-1.0E0,9.0E0,-6.0E1,0.0E0,3.0E0,-5.1E1,3.6E2,0.0E0,
CS   1          1.0E0,-1.8E1,3.45E2,-2.52E3,0.0E0,0.0E0,-3.0E0,3.3E1,
CS   2          -1.2E2,-1.0E0,1.5E1,-1.92E2,7.2E2,0.0E0,4.0E0,-9.6E1,
CS   3          1.32E3,-5.04E3,0.0E0,3.0E0,-7.8E1,2.74E2,0.0E0,-2.7E1,
CS   4          5.7E2,-1.764E3,0.0E0,-4.0E0,2.46E2,-4.666E3,1.3068E4,
CS   5          0.0E0,0.0E0,1.8E1,-2.25E2,0.0E0,3.0E0,-1.5E2,1.624E3,
CS   6          0.0E0,0.0E0,-3.6E1,1.32E3,-1.3132E4,0.0E0,0.0E0,-3.0E0,
CS   7          8.5E1,0.0E0,0.0E0,4.5E1,-7.35E2,0.0E0,0.0E0,6.0E0,
CS   8          -5.5E2,6.769E3,0.0E0,0.0E0,0.0E0,-1.5E1,0.0E0,0.0E0,
CS   9          -3.0E0,1.75E2,0.0E0,0.0E0,0.0E0,6.0E1,-1.96E3,0.0E0,
CS   a          0.0E0,0.0E0,1.0E0,0.0E0,0.0E0,0.0E0,-2.1E1,0.0E0,0.0E0,
CS   b          0.0E0,-4.0E0,3.22E2,0.0E0,0.0E0,0.0E0,0.0E0,0.0E0,0.0E0,
CS   c          0.0E0,1.0E0,0.0E0,0.0E0,0.0E0,0.0E0,-2.8E1,0.0E0,0.0E0,
CS   d          0.0E0,0.0E0,0.0E0,0.0E0,0.0E0,0.0E0,0.0E0,0.0E0,0.0E0,
CS   e          0.0E0,1.0E0/
CD    DATA AR1/0.0D0,-1.0D0,0.0D0,1.0D0,0.0D0,1.0D0,-3.0D0,0.0D0,-2.0D0,
CD   1         1.2D1,0.0D0,1.0D0,0.0D0,-1.0D0,-1.0D0,2.0D0,0.0D0,
CD   2         2.0D0,-6.0D0,1.0D0,-7.0D0,2.4D1,0.0D0,0.0D0,1.0D0,0.0D0,
CD   3         -3.0D0,0.0D0,-2.0D0,1.1D1,0.0D0,1.2D1,-5.0D1,0.0D0,
CD   4         0.0D0,0.0D0,0.0D0,1.0D0,0.0D0,0.0D0,-6.0D0,0.0D0,-2.0D0,
CD   5         3.5D1,0.0D0,0.0D0,0.0D0,0.0D0,0.0D0,0.0D0,0.0D0,1.0D0,
CD   6         0.0D0,0.0D0,-1.0D1,0.0D0,0.0D0,0.0D0,0.0D0,0.0D0,0.0D0,
CD   7         0.0D0,0.0D0,0.0D0,0.0D0,1.0D0/
CD    DATA AR2/-1.0D0,9.0D0,-6.0D1,0.0D0,3.0D0,-5.1D1,3.6D2,0.0D0,
CD   1          1.0D0,-1.8D1,3.45D2,-2.52D3,0.0D0,0.0D0,-3.0D0,3.3D1,
CD   2          -1.2D2,-1.0D0,1.5D1,-1.92D2,7.2D2,0.0D0,4.0D0,-9.6D1,
CD   3          1.32D3,-5.04D3,0.0D0,3.0D0,-7.8D1,2.74D2,0.0D0,-2.7D1,
CD   4          5.7D2,-1.764D3,0.0D0,-4.0D0,2.46D2,-4.666D3,1.3068D4,
CD   5          0.0D0,0.0D0,1.8D1,-2.25D2,0.0D0,3.0D0,-1.5D2,1.624D3,
CD   6          0.0D0,0.0D0,-3.6D1,1.32D3,-1.3132D4,0.0D0,0.0D0,-3.0D0,
CD   7          8.5D1,0.0D0,0.0D0,4.5D1,-7.35D2,0.0D0,0.0D0,6.0D0,
CD   8          -5.5D2,6.769D3,0.0D0,0.0D0,0.0D0,-1.5D1,0.0D0,0.0D0,
CD   9          -3.0D0,1.75D2,0.0D0,0.0D0,0.0D0,6.0D1,-1.96D3,0.0D0,
CD   a          0.0D0,0.0D0,1.0D0,0.0D0,0.0D0,0.0D0,-2.1D1,0.0D0,0.0D0,
CD   b          0.0D0,-4.0D0,3.22D2,0.0D0,0.0D0,0.0D0,0.0D0,0.0D0,0.0D0,
CD   c          0.0D0,1.0D0,0.0D0,0.0D0,0.0D0,0.0D0,-2.8D1,0.0D0,0.0D0,
CD   d          0.0D0,0.0D0,0.0D0,0.0D0,0.0D0,0.0D0,0.0D0,0.0D0,0.0D0,
CD   e          0.0D0,1.0D0/
      DATA IOUT/6/
C----------------------------------------------------------------------
C  Statement function for integer to float conversion
C----------------------------------------------------------------------
CS    CONV(NDUM) = REAL(NDUM)
CD    CONV(NDUM) = DBLE(NDUM)
C----------------------------------------------------------------------
C  Determine machine parameters and set constants
C----------------------------------------------------------------------
      CALL MACHAR(IBETA,IT,IRND,NGRD,MACHEP,NEGEP,IEXP,MINEXP,
     1            MAXEXP,EPS,EPSNEG,XMIN,XMAX)
      BETA = CONV(IBETA)
      AIT = CONV(IT)
      ALBETA = LOG(BETA)
      A = ZERO
      B = TWO
      JT = 0
      DELTA = XLAM - ONE 
      F = (DELTA) * (XLAM+ONE) * HALF
C----------------------------------------------------------------------
C  Random argument accuracy tests
C----------------------------------------------------------------------
      DO 300 J = 1, 4
         N = 2000
         XN = CONV(N)
         K1 = 0
         K2 = 0
         K3 = 0
         X1 = ZERO
         A1 = ZERO
         R6 = ZERO
         R7 = ZERO
         DEL = (B - A) / XN
         XL = A
         DO 200 I = 1, N
            X = DEL * REN(JT) + XL
  110       ALPHA = REN(JT)
C----------------------------------------------------------------------
C   Carefully purify arguments
C----------------------------------------------------------------------
            IF (J .EQ. 1) THEN
                  Y = X/XLAM
               ELSE
                  Y = X - DELTA
            END IF
            W = SIXTEN * Y
            T1 = W + Y
            T1 = W + T1
            Y = T1 - W
            Y = Y - W
            IF (J .EQ. 1) THEN
                  X = Y * XLAM
                  MB = 11
               ELSE
                  X = Y + DELTA
                  MB = 2
            END IF
            CALL RJBESL(Y,ALPHA,MB,U2,NCALC)
            CALL RJBESL(X,ALPHA,MB,U,NCALC)
            IF (J .EQ. 1) THEN
C----------------------------------------------------------------------
C   Accuracy test is based on the multiplication theorem
C----------------------------------------------------------------------
                  D = -F*Y
                  MB = NCALC - 2
                  XMB = CONV(MB)
                  SUM = U2(MB+1)
                  IND = MB
                  DO 125 II = 2, MB
                     SUM = SUM * D / XMB + U2(IND)
                     IND = IND - 1
                     XMB = XMB - ONE
  125             CONTINUE
                  ZZ = SUM * D + U2(IND)
                  ZZ = ZZ * XLAM ** ALPHA
               ELSE
C----------------------------------------------------------------------
C   Accuracy test is based on local Taylor's series expansion
C----------------------------------------------------------------------
                  IF (ABS(U(1)) .LT. ABS(U2(1))) THEN
                     Z = X
                     X = Y
                     Y = Z
                     DELTA = X - Y
                     DO 130 II = 1, MB
                        Z = U(II)
                        U(II) = U2(II)
                        U2(II) = Z
  130                CONTINUE
                  END IF
C----------------------------------------------------------------------
C   Filter out cases where function values or derivatives are small
C----------------------------------------------------------------------
                  W = SQRT(RTPI/X)/SIXTEN
                  Z = MIN(ABS(U2(1)),ABS(U2(2)))
                  IF (Z .LT. W) GO TO 110
                  YSQ = Y * Y
                  ALPHSQ = ALPHA * ALPHA
                  MB = 8
                  J1 = MB
                  XJ1 = CONV(J1+1)
                  IEXP = 0
                  NK = 13
                  NUM = 2
                  DO 180 II = 1, MB
                     IF (NK .EQ. 0) THEN 
                           NK = 11 
                           NUM = 1
                     END IF
                     K = 9 - J1
                     IF (K .GT. 1) THEN
                           NO1 = NDX2(K-1) + 1
                        ELSE
                           NO1 = 1
                     END IF
                     MVR = NO1
                     LAST = NDX2(K)
                     K = LAST - NO1 + 1
C----------------------------------------------------------------------
C         Group J(ALPHA) terms in the derivative
C----------------------------------------------------------------------
                     DO 160 III = 1, K
                        J2 = NDX(MVR)
                        IF (NUM .EQ. 1) THEN
                              G(III) = AR1(NK,J2)
                           ELSE
                              G(III) = AR2(NK,J2)
                        END IF
                        IF (J2 .GT. 1) THEN
  157                         J2 = J2 - 1
                              IF (NUM .EQ. 1) THEN
                                    G(III) = G(III) * ALPHA + AR1(NK,J2)
                                 ELSE
                                    G(III) = G(III) * ALPHA + AR2(NK,J2)
                              END IF
                           IF (J2 .GT. 1) GO TO 157
                        END IF
                        MVR = MVR + 1
                        NK = NK - 1
  160                CONTINUE
                     T1 = G(1)
                     DO 162 III = 2, K
                        T1 = T1 / YSQ + G(III)
  162                CONTINUE
                     IF (IEXP .EQ. 1) T1 = T1 / Y
C----------------------------------------------------------------------
C         Group J(ALPHA+1) terms in the derivative
C----------------------------------------------------------------------
                     IEXP = 1 - IEXP
                     NK = NK + K
                     MVR = NO1
                     KK = K
                     DO 165 III = 1, K
                        J2 = NDX(MVR)
                        M = MOD(J2,2)
                        IF (M .EQ. 1) J2 = J2 - 1
                        IF (J2 .GE. 2) THEN
                              IF (NUM .EQ. 1) THEN
                                    G(III) = AR1(NK,J2)
                                 ELSE
                                    G(III) = AR2(NK,J2)
                              END IF
  163                         J2 = J2 - 2
                              IF (J2 .GE. 2) THEN
                                    IF (NUM .EQ. 1) THEN
                                          G(III) = G(III) * ALPHSQ +
     1                                             AR1(NK,J2)
                                       ELSE
                                          G(III) = G(III) * ALPHSQ +
     1                                             AR2(NK,J2)
                                    END IF
                                    GO TO 163
                              END IF
                           ELSE
                              KK = III - 1
                        END IF
                        MVR = MVR + 1
                        NK = NK - 1
  165                CONTINUE
                     T2 = G(1)
                     DO 167 III = 2, KK
                        T2 = T2 / YSQ + G(III)
  167                CONTINUE
                     IF (IEXP .EQ. 1) T2 = T2 / Y
                     DERIV = U2(1) * T1 - U2(2) * T2
                     IF (J1 .EQ. 8) THEN
                           SUM = DERIV
                        ELSE
                           SUM = SUM * DELTA / XJ1 + DERIV
                     END IF
                     J1 = J1 - 1
                     XJ1 = XJ1 - ONE
  180             CONTINUE
                  ZZ = SUM * DELTA + U2(1)
            END IF
            MB = 2 
            Z = U(1)
C----------------------------------------------------------------------
C   Accumulate Results
C----------------------------------------------------------------------
            W = (Z - ZZ) / Z
            IF (W .GT. ZERO) THEN 
                  K1 = K1 + 1
               ELSE IF (W .LT. ZERO) THEN 
                  K3 = K3 + 1
            END IF
            W = ABS(W)
            IF (W .GT. R6) THEN
                  R6 = W
                  X1 = X
                  A1 = ALPHA
                  FXMX = Z
            END IF
            R7 = R7 + W * W
            XL = XL + DEL
  200    CONTINUE
C----------------------------------------------------------------------
C   Gather and print statistics for test
C----------------------------------------------------------------------
         K2 = N - K1 - K3
         R7 = SQRT(R7/XN)
         IF (J .EQ. 1) THEN
               WRITE (IOUT,1000)
            ELSE
               WRITE (IOUT,1001)
         END IF
         WRITE (IOUT,1010) N,A,B
         WRITE (IOUT,1011) K1,K2,K3
         WRITE (IOUT,1020) IT,IBETA
         IF (R6 .NE. ZERO) THEN
               W = LOG(R6)/ALBETA
            ELSE
               W = X99
         END IF
         WRITE (IOUT,1021) R6,IBETA,W,X1,A1
         WRITE (IOUT,1024) FXMX
         W = MAX(AIT+W,ZERO)
         WRITE (IOUT,1022) IBETA,W
         IF (R7 .NE. ZERO) THEN
               W = LOG(R7)/ALBETA
            ELSE
               W = X99
         END IF
         WRITE (IOUT,1023) R7,IBETA,W
         W = MAX(AIT+W,ZERO)
         WRITE (IOUT,1022) IBETA,W
C----------------------------------------------------------------------
C   Initialize for next test
C----------------------------------------------------------------------
         A = B
         IF (J .EQ. 1) THEN
               B = TEN
            ELSE IF (J .EQ. 2) THEN
               B = B + B
            ELSE IF (J .EQ. 3) THEN
               A = A + TEN
               B = A + TEN
         END IF
  300 CONTINUE
C----------------------------------------------------------------------
C   Test of error returns
C
C   First, test with bad parameters
C----------------------------------------------------------------------
      WRITE (IOUT, 2006)
      X = ONE 
      ALPHA = ONE + HALF
      MB = 5
      CALL RJBESL(X,ALPHA,MB,U,NCALC)
      WRITE (IOUT, 2011) X,ALPHA,MB,U(1),NCALC
      ALPHA = HALF
      MB = -MB
      CALL RJBESL(X,ALPHA,MB,U,NCALC)
      WRITE (IOUT, 2011) X,ALPHA,MB,U(1),NCALC
C----------------------------------------------------------------------
C   Last tests are with extreme parameters
C----------------------------------------------------------------------
      X = ZERO
      ALPHA = ONE
      MB = 2
      CALL RJBESL(X,ALPHA,MB,U,NCALC)
      WRITE (IOUT, 2011) X,ALPHA,MB,U(1),NCALC
      X = -ONE
      ALPHA = HALF
      MB = 5
      CALL RJBESL(X,ALPHA,MB,U,NCALC)
      WRITE (IOUT, 2011) X,ALPHA,MB,U(1),NCALC
C----------------------------------------------------------------------
C   Determine largest safe argument 
C----------------------------------------------------------------------
      WRITE (IOUT, 2015)
      X = XLARGE * (ONE - SQRT(SQRT(EPS)))
      MB = 2
      CALL RJBESL(X,ALPHA,MB,U,NCALC)
      WRITE (IOUT, 2012) X
      WRITE (IOUT, 2014) NCALC,U(1)
      X = XLARGE * (ONE + SQRT(SQRT(EPS)))
      MB = 2
      CALL RJBESL(X,ALPHA,MB,U,NCALC)
      WRITE (IOUT, 2012) X
      WRITE (IOUT, 2013)
      WRITE (IOUT, 2014) NCALC,U(1)
      WRITE (IOUT, 2020)
      STOP
C----------------------------------------------------------------------
 1000 FORMAT('1Test of J(X,ALPHA) vs Multiplication Theorem'//)
 1001 FORMAT('1Test of J(X,ALPHA) vs Taylor series'//)
 1010 FORMAT(I7,' Random arguments were tested from the interval ',
     1    '(',F5.2,',',F5.2,')'//)
 1011 FORMAT(' J(X,ALPHA) was larger',I6,' times,'/
     1    15X,' agreed',I6,' times, and'/
     1    11X,'was smaller',I6,' times.'//)
 1020 FORMAT(' There are',I4,' base',I4,
     1    ' significant digits in a floating-point number'//)
 1021 FORMAT(' The maximum relative error of',E15.4,' = ',I4,' **',
     1    F7.2/4X,'occurred for X =',E13.6,' and NU =',E13.6)
 1022 FORMAT(' The estimated loss of base',I4,
     1    ' significant digits is',F7.2//)
 1023 FORMAT(' The root mean square relative error was',E15.4,
     1    ' = ',I4,' **',F7.2)
 1024 FORMAT(4x,'with J(X,ALPHA) = ',E13.6)
 2006 FORMAT('1Check of Error Returns'///
     1    ' The following summarizes calls with indicated parameters'//
     2    ' NCALC different from MB indicates some form of error'//
     3    ' See documentation for RJBESL for details'//
     4    7X,'ARG',12X,'ALPHA',6X,'MB',6X,'B(1)',6X,'NCALC'//)
 2011 FORMAT(2E15.7,I5,E15.7,I5//)
 2012 FORMAT(' RJBESL will be called with the argument',E13.6)
 2013 FORMAT(' This should trigger an error message.')
 2014 FORMAT(' NCALC returned the value',I5/
     1    ' and RJBESL returned U(1) = ',E13.6/)
 2015 FORMAT(' Tests near the largest acceptable argument for RJBESL'/)
 2020 FORMAT(' This concludes the tests.') 
C     ---------- Last line of RJBESL test program ---------- 
      END

      SUBROUTINE RKBESL(X,ALPHA,NB,IZE,BK,NCALC)
C-------------------------------------------------------------------
C
C  This FORTRAN 77 routine calculates modified Bessel functions
C  of the second kind, K SUB(N+ALPHA) (X), for non-negative
C  argument X, and non-negative order N+ALPHA, with or without
C  exponential scaling.
C
C  Explanation of variables in the calling sequence
C
C  Description of output values ..
C
C X     - Working precision non-negative real argument for which
C         K's or exponentially scaled K's (K*EXP(X))
C         are to be calculated.  If K's are to be calculated,
C         X must not be greater than XMAX (see below).
C ALPHA - Working precision fractional part of order for which
C         K's or exponentially scaled K's (K*EXP(X)) are
C         to be calculated.  0 .LE. ALPHA .LT. 1.0.
C NB    - Integer number of functions to be calculated, NB .GT. 0.
C         The first function calculated is of order ALPHA, and the
C         last is of order (NB - 1 + ALPHA).
C IZE   - Integer type.  IZE = 1 if unscaled K's are to be calculated,
C         and 2 if exponentially scaled K's are to be calculated.
C BK    - Working precision output vector of length NB.  If the
C         routine terminates normally (NCALC=NB), the vector BK
C         contains the functions K(ALPHA,X), ... , K(NB-1+ALPHA,X),
C         or the corresponding exponentially scaled functions.
C         If (0 .LT. NCALC .LT. NB), BK(I) contains correct function
C         values for I .LE. NCALC, and contains the ratios
C         K(ALPHA+I-1,X)/K(ALPHA+I-2,X) for the rest of the array.
C NCALC - Integer output variable indicating possible errors.
C         Before using the vector BK, the user should check that
C         NCALC=NB, i.e., all orders have been calculated to
C         the desired accuracy.  See error returns below.
C
C
C*******************************************************************
C*******************************************************************
C
C Explanation of machine-dependent constants.  Let
C
C   beta   = Radix for the floating-point system
C   minexp = Smallest representable power of beta
C   maxexp = Smallest power of beta that overflows
C
C Then the following machine-dependent constants must be declared
C   in DATA statements.  IEEE values are provided as a default.
C
C   EPS    = The smallest positive floating-point number such that
C            1.0+EPS .GT. 1.0
C   XMAX   = Upper limit on the magnitude of X when IZE=1;  Solution
C            to equation:
C               W(X) * (1-1/8X+9/128X**2) = beta**minexp
C            where  W(X) = EXP(-X)*SQRT(PI/2X)
C   SQXMIN = Square root of beta**minexp
C   XINF   = Largest positive machine number; approximately
C            beta**maxexp
C   XMIN   = Smallest positive machine number; approximately
C            beta**minexp
C
C
C     Approximate values for some important machines are:
C
C                          beta       minexp      maxexp      EPS
C
C  CRAY-1        (S.P.)      2        -8193        8191    7.11E-15
C  Cyber 180/185
C    under NOS   (S.P.)      2         -975        1070    3.55E-15
C  IEEE (IBM/XT,
C    SUN, etc.)  (S.P.)      2         -126         128    1.19E-7
C  IEEE (IBM/XT,
C    SUN, etc.)  (D.P.)      2        -1022        1024    2.22D-16
C  IBM 3033      (D.P.)     16          -65          63    2.22D-16
C  VAX           (S.P.)      2         -128         127    5.96E-8
C  VAX D-Format  (D.P.)      2         -128         127    1.39D-17
C  VAX G-Format  (D.P.)      2        -1024        1023    1.11D-16
C
C
C                         SQXMIN       XINF        XMIN      XMAX
C
C CRAY-1        (S.P.)  6.77E-1234  5.45E+2465  4.59E-2467 5674.858
C Cyber 180/855
C   under NOS   (S.P.)  1.77E-147   1.26E+322   3.14E-294   672.788
C IEEE (IBM/XT,
C   SUN, etc.)  (S.P.)  1.08E-19    3.40E+38    1.18E-38     85.337
C IEEE (IBM/XT,
C   SUN, etc.)  (D.P.)  1.49D-154   1.79D+308   2.23D-308   705.342
C IBM 3033      (D.P.)  7.35D-40    7.23D+75    5.40D-79    177.852
C VAX           (S.P.)  5.42E-20    1.70E+38    2.94E-39     86.715
C VAX D-Format  (D.P.)  5.42D-20    1.70D+38    2.94D-39     86.715
C VAX G-Format  (D.P.)  7.46D-155   8.98D+307   5.57D-309   706.728
C
C*******************************************************************
C*******************************************************************
C
C Error returns
C
C  In case of an error, NCALC .NE. NB, and not all K's are
C  calculated to the desired accuracy.
C
C  NCALC .LT. -1:  An argument is out of range. For example,
C       NB .LE. 0, IZE is not 1 or 2, or IZE=1 and ABS(X) .GE.
C       XMAX.  In this case, the B-vector is not calculated,
C       and NCALC is set to MIN0(NB,0)-2  so that NCALC .NE. NB.
C  NCALC = -1:  Either  K(ALPHA,X) .GE. XINF  or
C       K(ALPHA+NB-1,X)/K(ALPHA+NB-2,X) .GE. XINF.  In this case,
C       the B-vector is not calculated.  Note that again
C       NCALC .NE. NB.
C
C  0 .LT. NCALC .LT. NB: Not all requested function values could
C       be calculated accurately.  BK(I) contains correct function
C       values for I .LE. NCALC, and contains the ratios
C       K(ALPHA+I-1,X)/K(ALPHA+I-2,X) for the rest of the array.
C
C
C Intrinsic functions required are:
C
C     ABS, AINT, EXP, INT, LOG, MAX, MIN, SINH, SQRT
C
C
C Acknowledgement
C
C  This program is based on a program written by J. B. Campbell
C  (2) that computes values of the Bessel functions K of real
C  argument and real order.  Modifications include the addition
C  of non-scaled functions, parameterization of machine
C  dependencies, and the use of more accurate approximations
C  for SINH and SIN.
C
C References: "On Temme's Algorithm for the Modified Bessel
C              Functions of the Third Kind," Campbell, J. B.,
C              TOMS 6(4), Dec. 1980, pp. 581-586.
C
C             "A FORTRAN IV Subroutine for the Modified Bessel
C              Functions of the Third Kind of Real Order and Real
C              Argument," Campbell, J. B., Report NRC/ERB-925,
C              National Research Council, Canada.
C
C  Latest modification: March 15, 1992
C
C  Modified by: W. J. Cody and L. Stoltz
C               Applied Mathematics Division
C               Argonne National Laboratory
C               Argonne, IL  60439
C
C-------------------------------------------------------------------
      INTEGER I,IEND,ITEMP,IZE,J,K,M,MPLUS1,NB,NCALC
CS    REAL
CD    DOUBLE PRECISION
     1    A,ALPHA,BLPHA,BK,BK1,BK2,C,D,DM,D1,D2,D3,ENU,EPS,ESTF,ESTM,
     2    EX,FOUR,F0,F1,F2,HALF,ONE,P,P0,Q,Q0,R,RATIO,S,SQXMIN,T,TINYX,
     3    TWO,TWONU,TWOX,T1,T2,WMINF,X,XINF,XMAX,XMIN,X2BY4,ZERO
      DIMENSION BK(NB),P(8),Q(7),R(5),S(4),T(6),ESTM(6),ESTF(7)
C---------------------------------------------------------------------
C  Mathematical constants
C    A = LOG(2.D0) - Euler's constant
C    D = SQRT(2.D0/PI)
C---------------------------------------------------------------------
CS    DATA HALF,ONE,TWO,ZERO/0.5E0,1.0E0,2.0E0,0.0E0/
CS    DATA FOUR,TINYX/4.0E0,1.0E-10/
CS    DATA A/ 0.11593151565841244881E0/,D/0.797884560802865364E0/
CD    DATA HALF,ONE,TWO,ZERO/0.5D0,1.0D0,2.0D0,0.0D0/
CD    DATA FOUR,TINYX/4.0D0,1.0D-10/
CD    DATA A/ 0.11593151565841244881D0/,D/0.797884560802865364D0/
C---------------------------------------------------------------------
C  Machine dependent parameters
C---------------------------------------------------------------------
CS    DATA EPS/1.19E-7/,SQXMIN/1.08E-19/,XINF/3.40E+38/
CS    DATA XMIN/1.18E-38/,XMAX/85.337E0/
CD    DATA EPS/2.22D-16/,SQXMIN/1.49D-154/,XINF/1.79D+308/
CD    DATA XMIN/2.23D-308/,XMAX/705.342D0/
C---------------------------------------------------------------------
C  P, Q - Approximation for LOG(GAMMA(1+ALPHA))/ALPHA
C                                         + Euler's constant
C         Coefficients converted from hex to decimal and modified
C         by W. J. Cody, 2/26/82
C  R, S - Approximation for (1-ALPHA*PI/SIN(ALPHA*PI))/(2.D0*ALPHA)
C  T    - Approximation for SINH(Y)/Y
C---------------------------------------------------------------------
CS    DATA P/ 0.805629875690432845E00,    0.204045500205365151E02,
CS   1        0.157705605106676174E03,    0.536671116469207504E03,
CS   2        0.900382759291288778E03,    0.730923886650660393E03,
CS   3        0.229299301509425145E03,    0.822467033424113231E00/
CS    DATA Q/ 0.294601986247850434E02,    0.277577868510221208E03,
CS   1        0.120670325591027438E04,    0.276291444159791519E04,
CS   2        0.344374050506564618E04,    0.221063190113378647E04,
CS   3        0.572267338359892221E03/
CS    DATA R/-0.48672575865218401848E+0,  0.13079485869097804016E+2,
CS   1       -0.10196490580880537526E+3,  0.34765409106507813131E+3,
CS   2        0.34958981245219347820E-3/
CS    DATA S/-0.25579105509976461286E+2,  0.21257260432226544008E+3,
CS   1       -0.61069018684944109624E+3,  0.42269668805777760407E+3/
CS    DATA T/ 0.16125990452916363814E-9, 0.25051878502858255354E-7,
CS   1        0.27557319615147964774E-5, 0.19841269840928373686E-3,
CS   2        0.83333333333334751799E-2, 0.16666666666666666446E+0/
CS    DATA ESTM/5.20583E1, 5.7607E0, 2.7782E0, 1.44303E1, 1.853004E2,
CS   1          9.3715E0/
CS    DATA ESTF/4.18341E1, 7.1075E0, 6.4306E0, 4.25110E1, 1.35633E0,
CS   1          8.45096E1, 2.0E1/
CD    DATA P/ 0.805629875690432845D00,    0.204045500205365151D02,
CD   1        0.157705605106676174D03,    0.536671116469207504D03,
CD   2        0.900382759291288778D03,    0.730923886650660393D03,
CD   3        0.229299301509425145D03,    0.822467033424113231D00/
CD    DATA Q/ 0.294601986247850434D02,    0.277577868510221208D03,
CD   1        0.120670325591027438D04,    0.276291444159791519D04,
CD   2        0.344374050506564618D04,    0.221063190113378647D04,
CD   3        0.572267338359892221D03/
CD    DATA R/-0.48672575865218401848D+0,  0.13079485869097804016D+2,
CD   1       -0.10196490580880537526D+3,  0.34765409106507813131D+3,
CD   2        0.34958981245219347820D-3/
CD    DATA S/-0.25579105509976461286D+2,  0.21257260432226544008D+3,
CD   1       -0.61069018684944109624D+3,  0.42269668805777760407D+3/
CD    DATA T/ 0.16125990452916363814D-9, 0.25051878502858255354D-7,
CD   1        0.27557319615147964774D-5, 0.19841269840928373686D-3,
CD   2        0.83333333333334751799D-2, 0.16666666666666666446D+0/
CD    DATA ESTM/5.20583D1, 5.7607D0, 2.7782D0, 1.44303D1, 1.853004D2,
CD   1          9.3715D0/
CD    DATA ESTF/4.18341D1, 7.1075D0, 6.4306D0, 4.25110D1, 1.35633D0,
CD   1          8.45096D1, 2.0D1/
C---------------------------------------------------------------------
      EX = X
      ENU = ALPHA
      NCALC = MIN(NB,0)-2
      IF ((NB .GT. 0) .AND. ((ENU .GE. ZERO) .AND. (ENU .LT. ONE))
     1     .AND. ((IZE .GE. 1) .AND. (IZE .LE. 2)) .AND.
     2     ((IZE .NE. 1) .OR. (EX .LE. XMAX)) .AND.
     3     (EX .GT. ZERO))  THEN
            K = 0
            IF (ENU .LT. SQXMIN) ENU = ZERO
            IF (ENU .GT. HALF) THEN
                  K = 1
                  ENU = ENU - ONE
            END IF
            TWONU = ENU+ENU
            IEND = NB+K-1
            C = ENU*ENU
            D3 = -C
            IF (EX .LE. ONE) THEN
C---------------------------------------------------------------------
C  Calculation of P0 = GAMMA(1+ALPHA) * (2/X)**ALPHA
C                 Q0 = GAMMA(1-ALPHA) * (X/2)**ALPHA
C---------------------------------------------------------------------
                  D1 = ZERO
                  D2 = P(1)
                  T1 = ONE
                  T2 = Q(1)
                  DO 10 I = 2,7,2
                     D1 = C*D1+P(I)
                     D2 = C*D2+P(I+1)
                     T1 = C*T1+Q(I)
                     T2 = C*T2+Q(I+1)
   10             CONTINUE
                  D1 = ENU*D1
                  T1 = ENU*T1
                  F1 = LOG(EX)
                  F0 = A+ENU*(P(8)-ENU*(D1+D2)/(T1+T2))-F1
                  Q0 = EXP(-ENU*(A-ENU*(P(8)+ENU*(D1-D2)/(T1-T2))-F1))
                  F1 = ENU*F0
                  P0 = EXP(F1)
C---------------------------------------------------------------------
C  Calculation of F0 =
C---------------------------------------------------------------------
                  D1 = R(5)
                  T1 = ONE
                  DO 20 I = 1,4
                     D1 = C*D1+R(I)
                     T1 = C*T1+S(I)
   20             CONTINUE
                  IF (ABS(F1) .LE. HALF) THEN
                        F1 = F1*F1
                        D2 = ZERO
                        DO 30 I = 1,6
                           D2 = F1*D2+T(I)
   30                   CONTINUE
                        D2 = F0+F0*F1*D2
                     ELSE
                        D2 = SINH(F1)/ENU
                  END IF
                  F0 = D2-ENU*D1/(T1*P0)
                  IF (EX .LE. TINYX) THEN
C--------------------------------------------------------------------
C  X.LE.1.0E-10
C  Calculation of K(ALPHA,X) and X*K(ALPHA+1,X)/K(ALPHA,X)
C--------------------------------------------------------------------
                        BK(1) = F0+EX*F0
                        IF (IZE .EQ. 1) BK(1) = BK(1)-EX*BK(1)
                        RATIO = P0/F0
                        C = EX*XINF
                        IF (K .NE. 0) THEN
C--------------------------------------------------------------------
C  Calculation of K(ALPHA,X) and X*K(ALPHA+1,X)/K(ALPHA,X),
C  ALPHA .GE. 1/2
C--------------------------------------------------------------------
                              NCALC = -1
                              IF (BK(1) .GE. C/RATIO) GO TO 500
                              BK(1) = RATIO*BK(1)/EX
                              TWONU = TWONU+TWO
                              RATIO = TWONU
                        END IF
                        NCALC = 1
                        IF (NB .EQ. 1) GO TO 500
C--------------------------------------------------------------------
C  Calculate  K(ALPHA+L,X)/K(ALPHA+L-1,X),  L  =  1, 2, ... , NB-1
C--------------------------------------------------------------------
                        NCALC = -1
                        DO 80 I = 2,NB
                           IF (RATIO .GE. C) GO TO 500
                           BK(I) = RATIO/EX
                           TWONU = TWONU+TWO
                           RATIO = TWONU
   80                   CONTINUE
                        NCALC = 1
                        GO TO 420
                     ELSE
C--------------------------------------------------------------------
C  1.0E-10 .LT. X .LE. 1.0
C--------------------------------------------------------------------
                        C = ONE
                        X2BY4 = EX*EX/FOUR
                        P0 = HALF*P0
                        Q0 = HALF*Q0
                        D1 = -ONE
                        D2 = ZERO
                        BK1 = ZERO
                        BK2 = ZERO
                        F1 = F0
                        F2 = P0
  100                   D1 = D1+TWO
                        D2 = D2+ONE
                        D3 = D1+D3
                        C = X2BY4*C/D2
                        F0 = (D2*F0+P0+Q0)/D3
                        P0 = P0/(D2-ENU)
                        Q0 = Q0/(D2+ENU)
                        T1 = C*F0
                        T2 = C*(P0-D2*F0)
                        BK1 = BK1+T1
                        BK2 = BK2+T2
                        IF ((ABS(T1/(F1+BK1)) .GT. EPS) .OR.
     1                     (ABS(T2/(F2+BK2)) .GT. EPS))  GO TO 100
                        BK1 = F1+BK1
                        BK2 = TWO*(F2+BK2)/EX
                        IF (IZE .EQ. 2) THEN
                              D1 = EXP(EX)
                              BK1 = BK1*D1
                              BK2 = BK2*D1
                        END IF
                        WMINF = ESTF(1)*EX+ESTF(2)
                  END IF
               ELSE IF (EPS*EX .GT. ONE) THEN
C--------------------------------------------------------------------
C  X .GT. ONE/EPS
C--------------------------------------------------------------------
                  NCALC = NB
                  BK1 = ONE / (D*SQRT(EX))
                  DO 110 I = 1, NB
                     BK(I) = BK1
  110             CONTINUE
                  GO TO 500
               ELSE
C--------------------------------------------------------------------
C  X .GT. 1.0
C--------------------------------------------------------------------
                  TWOX = EX+EX
                  BLPHA = ZERO
                  RATIO = ZERO
                  IF (EX .LE. FOUR) THEN
C--------------------------------------------------------------------
C  Calculation of K(ALPHA+1,X)/K(ALPHA,X),  1.0 .LE. X .LE. 4.0
C--------------------------------------------------------------------
                        D2 = AINT(ESTM(1)/EX+ESTM(2))
                        M = INT(D2)
                        D1 = D2+D2
                        D2 = D2-HALF
                        D2 = D2*D2
                        DO 120 I = 2,M
                           D1 = D1-TWO
                           D2 = D2-D1
                           RATIO = (D3+D2)/(TWOX+D1-RATIO)
  120                   CONTINUE
C--------------------------------------------------------------------
C  Calculation of I(|ALPHA|,X) and I(|ALPHA|+1,X) by backward
C    recurrence and K(ALPHA,X) from the wronskian
C--------------------------------------------------------------------
                        D2 = AINT(ESTM(3)*EX+ESTM(4))
                        M = INT(D2)
                        C = ABS(ENU)
                        D3 = C+C
                        D1 = D3-ONE
                        F1 = XMIN
                        F0 = (TWO*(C+D2)/EX+HALF*EX/(C+D2+ONE))*XMIN
                        DO 130 I = 3,M
                           D2 = D2-ONE
                           F2 = (D3+D2+D2)*F0
                           BLPHA = (ONE+D1/D2)*(F2+BLPHA)
                           F2 = F2/EX+F1
                           F1 = F0
                           F0 = F2
  130                   CONTINUE
                        F1 = (D3+TWO)*F0/EX+F1
                        D1 = ZERO
                        T1 = ONE
                        DO 140 I = 1,7
                           D1 = C*D1+P(I)
                           T1 = C*T1+Q(I)
  140                   CONTINUE
                        P0 = EXP(C*(A+C*(P(8)-C*D1/T1)-LOG(EX)))/EX
                        F2 = (C+HALF-RATIO)*F1/EX
                        BK1 = P0+(D3*F0-F2+F0+BLPHA)/(F2+F1+F0)*P0
                        IF (IZE .EQ. 1) BK1 = BK1*EXP(-EX)
                        WMINF = ESTF(3)*EX+ESTF(4)
                     ELSE
C--------------------------------------------------------------------
C  Calculation of K(ALPHA,X) and K(ALPHA+1,X)/K(ALPHA,X), by backward
C  recurrence, for  X .GT. 4.0
C--------------------------------------------------------------------
                        DM = AINT(ESTM(5)/EX+ESTM(6))
                        M = INT(DM)
                        D2 = DM-HALF
                        D2 = D2*D2
                        D1 = DM+DM
                        DO 160 I = 2,M
                           DM = DM-ONE
                           D1 = D1-TWO
                           D2 = D2-D1
                           RATIO = (D3+D2)/(TWOX+D1-RATIO)
                           BLPHA = (RATIO+RATIO*BLPHA)/DM
  160                   CONTINUE
                        BK1 = ONE/((D+D*BLPHA)*SQRT(EX))
                        IF (IZE .EQ. 1) BK1 = BK1*EXP(-EX)
                        WMINF = ESTF(5)*(EX-ABS(EX-ESTF(7)))+ESTF(6)
                  END IF
C--------------------------------------------------------------------
C  Calculation of K(ALPHA+1,X) from K(ALPHA,X) and
C    K(ALPHA+1,X)/K(ALPHA,X)
C--------------------------------------------------------------------
                  BK2 = BK1+BK1*(ENU+HALF-RATIO)/EX
            END IF
C--------------------------------------------------------------------
C  Calculation of 'NCALC', K(ALPHA+I,X), I  =  0, 1, ... , NCALC-1,
C  K(ALPHA+I,X)/K(ALPHA+I-1,X), I  =  NCALC, NCALC+1, ... , NB-1
C--------------------------------------------------------------------
            NCALC = NB
            BK(1) = BK1
            IF (IEND .EQ. 0) GO TO 500
            J = 2-K
            IF (J .GT. 0) BK(J) = BK2
            IF (IEND .EQ. 1) GO TO 500
            M = MIN(INT(WMINF-ENU),IEND)
            DO 190 I = 2,M
               T1 = BK1
               BK1 = BK2
               TWONU = TWONU+TWO
               IF (EX .LT. ONE) THEN
                     IF (BK1 .GE. (XINF/TWONU)*EX) GO TO 195
                     GO TO 187
                  ELSE
                     IF (BK1/EX .GE. XINF/TWONU) GO TO 195
               END IF
  187          CONTINUE
               BK2 = TWONU/EX*BK1+T1
               ITEMP = I
               J = J+1
               IF (J .GT. 0) BK(J) = BK2
  190       CONTINUE
  195       M = ITEMP
            IF (M .EQ. IEND) GO TO 500
            RATIO = BK2/BK1
            MPLUS1 = M+1
            NCALC = -1
            DO 410 I = MPLUS1,IEND
               TWONU = TWONU+TWO
               RATIO = TWONU/EX+ONE/RATIO
               J = J+1
               IF (J .GT. 1) THEN
                     BK(J) = RATIO
                  ELSE
                     IF (BK2 .GE. XINF/RATIO) GO TO 500
                     BK2 = RATIO*BK2
               END IF
  410       CONTINUE
            NCALC = MAX(MPLUS1-K,1)
            IF (NCALC .EQ. 1) BK(1) = BK2
            IF (NB .EQ. 1) GO TO 500
  420       J = NCALC+1
            DO 430 I = J,NB
               IF (BK(NCALC) .GE. XINF/BK(I)) GO TO 500
               BK(I) = BK(NCALC)*BK(I)
               NCALC = I
  430       CONTINUE
      END IF
  500 RETURN
C---------- Last line of RKBESL ----------
      END
      PROGRAM RKTEST
C--------------------------------------------------------------------
C FORTRAN 77 program to test RKBESL
C
C  Data required
C
C     None
C
C  Subprograms required from this package
C
C     MACHAR - An environmental inquiry program providing
C         information on the floating-point arithmetic
C         system.  Note that the call to MACHAR can
C         be deleted provided the following five
C         parameters are assigned the values indicated
C
C              IBETA  - the radix of the floating-point system
C              IT     - the number of base-IBETA digits in the
C                       significand of a floating-point number
C              MINEXP - the largest in magnitude negative
C                       integer such that FLOAT(IBETA)**MINEXP
C                       is a positive floating-point number
C              EPS    - the smallest positive floating-point
C                       number such that 1.0+EPS .NE. 1.0
C              EPSNEG - the smallest positive floating-point
C                       number such that 1.0-EPSNEG .NE. 1.0
C
C     REN(K) - a function subprogram returning random real
C              numbers uniformly distributed over (0,1)
C
C
C  Intrinsic functions required are:
C
C      ABS, DBLE, EXP, LOG, MAX, REAL, SQRT
C
C  Reference: "Performance evaluation of programs for certain
C              Bessel functions", W. J. Cody and L. Stoltz,
C              ACM Trans. on Math. Software, Vol. 15, 1989,
C              pp 41-48.
C
C  Latest modification: March 14, 1992
C
C  Authors: W. J. Cody and L. Stoltz
C           Mathematics and Computer Science Division
C           Argonne National Laboratory
C           Argonne, IL 60439
C
C--------------------------------------------------------------------
      LOGICAL SFLAG,TFLAG
      INTEGER I,IBETA,IEXP,II,IND,IOUT,IRND,IT,IZE,IZ1,J,JT,K1,K2,
     1        K3,MACHEP,MAXEXP,MB,MINEXP,N,NCALC,NDUM,NEGEP,NGRD
CS    REAL 
CD    DOUBLE PRECISION 
     1    A,AIT,ALBETA,ALPHA,AMAXEXP,A1,B,BETA,C,CONV,D,DEL,EIGHT,EPS,
     2    EPSNEG,FIVE,HALF,HUND,ONE,OVRCHK,REN,R6,R7,SIXTEN,SUM,T,TEN,
     3    TINYX,T1,U,U2,W,X,XL,XLAM,XMAX,XMB,XMIN,XN,XNINE,X1,X99,Y,Z,
     4    ZERO,ZZ
      DIMENSION U(560),U2(560)
CS    DATA ZERO,HALF,ONE,FIVE,EIGHT/0.0E0,0.5E0,1.0E0,5.0E0,8.0E0/
CS    DATA XNINE,TEN,HUND/9.0E0,10.0E0,1.0E2/
CS    DATA X99,SIXTEN,XLAM/-999.0E0,1.6E1,0.9375E0/
CS    DATA C/2.2579E-1/,TINYX/1.0E-10/
CD    DATA ZERO,HALF,ONE,FIVE,EIGHT/0.0D0,0.5D0,1.0D0,5.0D0,8.0D0/
CD    DATA XNINE,TEN,HUND/9.0D0,10.0D0,1.0D2/
CD    DATA X99,SIXTEN,XLAM/-999.0D0,1.6D1,0.9375D0/
CD    DATA C/2.2579D-1/,TINYX/1.0D-10/
      DATA IOUT/6/
C--------------------------------------------------------------------
C  Define statement function for integer to float conversion
C--------------------------------------------------------------------
CS    CONV(NDUM) = REAL(NDUM)
CD    CONV(NDUM) = DBLE(NDUM)
C--------------------------------------------------------------------
C  Determine machine parameters and set constants
C--------------------------------------------------------------------
      CALL MACHAR(IBETA,IT,IRND,NGRD,MACHEP,NEGEP,IEXP,MINEXP,
     1            MAXEXP,EPS,EPSNEG,XMIN,XMAX)
      BETA = CONV(IBETA)
      AIT = CONV(IT)
      ALBETA = LOG(BETA)
      AMAXEXP = CONV(MAXEXP)
      A = EPS
      B = ONE
      JT = 0
C-------------------------------------------------------------------
C  Random argument accuracy tests
C-------------------------------------------------------------------
      DO 300 J = 1, 3
         SFLAG = ((J .EQ. 1) .AND. (AMAXEXP/AIT .LE. FIVE))
         N = 2000
         XN = CONV(N)
         K1 = 0
         K2 = 0
         K3 = 0
         X1 = ZERO
         A1 = ZERO
         R6 = ZERO
         R7 = ZERO
         DEL = (B - A) / XN
         XL = A
         DO 200 I = 1, N
            X = DEL * REN(JT) + XL
            ALPHA = REN(JT)
C--------------------------------------------------------------------
C   Accuracy test is based on the multiplication theorem
C--------------------------------------------------------------------
            IZE = 1
            MB = 3
C--------------------------------------------------------------------
C   Carefully purify arguments
C--------------------------------------------------------------------
            Y = X/XLAM
            W = SIXTEN * Y
            T1 = W + Y
            Y = T1 - W
            X = Y * XLAM
            CALL RKBESL(Y,ALPHA,MB,IZE,U2,NCALC)
            TFLAG = SFLAG .AND. (Y .LT. HALF)
            IF (TFLAG) THEN
                  U2(1) = U2(1) * EPS
                  U2(2) = U2(2) * EPS
            END IF
            MB = 1
            XMB = ZERO
            W = (ONE-XLAM) * (ONE+XLAM) * HALF
            D = W*Y
            T = U2(1) + D * U2(2)
            T1 = EPS / HUND
C--------------------------------------------------------------------
C   Generate terms using recurrence
C--------------------------------------------------------------------
            DO 110 II = 3, 35
               XMB = XMB + ONE
               T1 = XMB * T1 / D
               Z = U2(II-1)
               OVRCHK = (XMB+ALPHA)/(Y*HALF)
               IF (Z/T1 .LT. T) THEN
                     GO TO 120
                  ELSE IF (U2(II-1) .GT. ONE) THEN
                     IF (OVRCHK .GT. (XMAX/U2(II-1))) THEN
                           XL = XL + DEL
                           A = XL
                           GO TO 200
                     END IF
               END IF
               U2(II) = OVRCHK * U2(II-1) + U2(II-2)
               IF (T1 .GT. ONE/EPS) THEN
                     T = T * T1
                     T1 = ONE
               END IF
               MB = MB + 1
  110       CONTINUE
C--------------------------------------------------------------------
C   Accurate Summation
C--------------------------------------------------------------------
            XMB = XMB + ONE
  120       SUM = U2(MB+1)
            IND = MB
            DO 155 II = 1, MB
               SUM = SUM * D / XMB + U2(IND)
               IND = IND - 1
               XMB = XMB - ONE
  155       CONTINUE
            ZZ = SUM
            IF (TFLAG) ZZ = ZZ / EPS
            ZZ = ZZ * XLAM ** ALPHA
            MB = 2 
            CALL RKBESL(X,ALPHA,MB,IZE,U,NCALC)
            Z = U(1)
            Y = Z
            IF (U2(1) .GT. Y) Y = U2(1)
C--------------------------------------------------------------------
C   Accumulate Results
C--------------------------------------------------------------------
            W = (Z - ZZ) / Y
            IF (W .GT. ZERO) THEN 
                  K1 = K1 + 1
               ELSE IF (W .LT. ZERO) THEN 
                  K3 = K3 + 1
               ELSE
                  K2 = K2 + 1
            END IF
            W = ABS(W)
            IF (W .GT. R6) THEN
                  R6 = W
                  X1 = X
                  A1 = ALPHA
                  IZ1 = IZE
            END IF
            R7 = R7 + W * W
            XL = XL + DEL
  200    CONTINUE
C--------------------------------------------------------------------
C   Gather and print statistics for test
C--------------------------------------------------------------------
         N = K1 + K2 + K3
         R7 = SQRT(R7/XN)
         WRITE (IOUT,1000)
         WRITE (IOUT,1010) N,A,B
         WRITE (IOUT,1011) K1,K2,K3
         WRITE (IOUT,1020) IT,IBETA
         W = X99
         IF (R6 .NE. ZERO) W = LOG(R6)/ALBETA
         IF (J .EQ. 3) THEN
               WRITE (IOUT,1024) R6,IBETA,W,X1,A1,IZ1
            ELSE
               WRITE (IOUT,1021) R6,IBETA,W,X1,A1,IZ1
         END IF
         W = MAX(AIT+W,ZERO)
         WRITE (IOUT,1022) IBETA,W
         W = X99
         IF (R7 .NE. ZERO) W = LOG(R7)/ALBETA
         IF (J .EQ. 3) THEN
               WRITE (IOUT,1025) R7,IBETA,W
            ELSE
               WRITE (IOUT,1023) R7,IBETA,W
         END IF
         W = MAX(AIT+W,ZERO)
         WRITE (IOUT,1022) IBETA,W
C--------------------------------------------------------------------
C   Initialize for next test
C--------------------------------------------------------------------
         A = B
         B = B + B
         IF (J .EQ. 1) B = TEN
  300 CONTINUE
C-------------------------------------------------------------------
C   Test of error returns
C   First, test with bad parameters
C-------------------------------------------------------------------
      WRITE (IOUT, 2006)
      X = -ONE
      ALPHA = HALF
      MB = 5
      IZE = 2
      U(1) = ZERO
      CALL RKBESL(X,ALPHA,MB,IZE,U,NCALC)
      WRITE (IOUT, 2011) X,ALPHA,MB,IZE,U(1),NCALC
      X = -X
      ALPHA = ONE + HALF
      CALL RKBESL(X,ALPHA,MB,IZE,U,NCALC)
      WRITE (IOUT, 2011) X,ALPHA,MB,IZE,U(1),NCALC
      ALPHA = HALF
      MB = -MB
      CALL RKBESL(X,ALPHA,MB,IZE,U,NCALC)
      WRITE (IOUT, 2011) X,ALPHA,MB,IZE,U(1),NCALC
      MB = -MB
      IZE = 5
      CALL RKBESL(X,ALPHA,MB,IZE,U,NCALC)
      WRITE (IOUT, 2011) X,ALPHA,MB,IZE,U(1),NCALC
C-------------------------------------------------------------------
C   Last tests are with extreme parameters
C-------------------------------------------------------------------
      X = XMIN
      ALPHA = ZERO
      MB = 2
      IZE = 2
      U(1) = ZERO
      CALL RKBESL(X,ALPHA,MB,IZE,U,NCALC)
      WRITE (IOUT, 2011) X,ALPHA,MB,IZE,U(1),NCALC
      X = TINYX*(ONE-SQRT(EPS))
      MB = 20
      U(1) = ZERO
      CALL RKBESL(X,ALPHA,MB,IZE,U,NCALC)
      WRITE (IOUT, 2011) X,ALPHA,MB,IZE,U(1),NCALC
      X = TINYX*(ONE+SQRT(EPS))
      MB = 20
      U(1) = ZERO
      CALL RKBESL(X,ALPHA,MB,IZE,U,NCALC)
      WRITE (IOUT, 2011) X,ALPHA,MB,IZE,U(1),NCALC
C-------------------------------------------------------------------
C   Determine largest safe argument for unscaled functions
C-------------------------------------------------------------------
      Z = LOG(XMIN)
      W = Z-C
      ZZ = -Z-TEN
  350 Z = ZZ
         ZZ = ONE/(EIGHT*Z)
         A = Z+LOG(Z)*HALF+ZZ*(ONE-XNINE*HALF*ZZ)+W
         B = ONE+(HALF-ZZ*(ONE-XNINE*ZZ))/Z
         ZZ = Z-A/B
      IF (ABS(Z-ZZ) .GT. HUND*EPS*Z) GO TO 350
      X = ZZ*XLAM
      IZE = 1
      MB = 2
      U(1) = ZERO
      CALL RKBESL(X,ALPHA,MB,IZE,U,NCALC)
      WRITE (IOUT, 2011) X,ALPHA,MB,IZE,U(1),NCALC
      X = ZZ
      MB = 2
      U(1) = ZERO
      CALL RKBESL(X,ALPHA,MB,IZE,U,NCALC)
      WRITE (IOUT, 2011) X,ALPHA,MB,IZE,U(1),NCALC
      X = TEN / EPS
      IZE = 2
      U(1) = ZERO
      CALL RKBESL(X,ALPHA,MB,IZE,U,NCALC)
      WRITE (IOUT, 2011) X,ALPHA,MB,IZE,U(1),NCALC
      X = XMAX
      U(1) = ZERO
      CALL RKBESL(X,ALPHA,MB,IZE,U,NCALC)
      WRITE (IOUT, 2011) X,ALPHA,MB,IZE,U(1),NCALC
      STOP
C-------------------------------------------------------------------
 1000 FORMAT('1Test of K(X,ALPHA) vs Multiplication Theorem'//)
 1010 FORMAT(I7,' Random arguments were tested from the interval ',
     1    '(',F5.2,',',F5.2,')'//)
 1011 FORMAT(' K(X,ALPHA) was larger',I6,' times,'/
     1    15X,' agreed',I6,' times, and'/
     1    11X,'was smaller',I6,' times.'//)
 1020 FORMAT(' There are',I4,' base',I4,
     1    ' significant digits in a floating-point number'//)
 1021 FORMAT(' The maximum relative error of',E15.4,' = ',I4,' **',
     1    F7.2/4X,'occurred for X =',E13.6,', NU =',E13.6,
     2    ' and IZE =',I2)
 1022 FORMAT(' The estimated loss of base',I4,
     1    ' significant digits is',F7.2//)
 1023 FORMAT(' The root mean square relative error was',E15.4,
     1    ' = ',I4,' **',F7.2)
 1024 FORMAT(' The maximum absolute error of',E15.4,' = ',I4,' **',
     1    F7.2/4X,'occurred for X =',E13.6,', NU =',E13.6,
     2    ' and IZE =',I2)
 1025 FORMAT(' The root mean square absolute error was',E15.4,
     1    ' = ',I4,' **',F7.2)
 2006 FORMAT('1Check of Error Returns'///
     1    ' The following summarizes calls with indicated parameters'//
     2    ' NCALC different from MB indicates some form of error'//
     3    ' See documentation for RKBESL for details'//
     4    7X,'ARG',12X,'ALPHA',6X,'MB',3X,'IZ',7X,'RES',6X,'NCALC'//)
 2011 FORMAT(2E15.7,2I5,E15.7,I5//)
C---------- Last line of RKBESL test program ----------
      END
      SUBROUTINE RYBESL(X,ALPHA,NB,BY,NCALC)
C----------------------------------------------------------------------
C
C  This routine calculates Bessel functions Y SUB(N+ALPHA) (X)
C  for non-negative argument X, and non-negative order N+ALPHA.
C
C
C Explanation of variables in the calling sequence
C
C X     - Working precision positive real argument for which
C         Y's are to be calculated.
C ALPHA - Working precision fractional part of order for which
C         Y's are to be calculated.  0 .LE. ALPHA .LT. 1.0.
C NB    - Integer number of functions to be calculated, NB .GT. 0.
C         The first function calculated is of order ALPHA, and the
C         last is of order (NB - 1 + ALPHA).
C BY    - Working precision output vector of length NB.  If the
C         routine terminates normally (NCALC=NB), the vector BY
C         contains the functions Y(ALPHA,X), ... , Y(NB-1+ALPHA,X),
C         If (0 .LT. NCALC .LT. NB), BY(I) contains correct function
C         values for I .LE. NCALC, and contains the ratios
C         Y(ALPHA+I-1,X)/Y(ALPHA+I-2,X) for the rest of the array.
C NCALC - Integer output variable indicating possible errors.
C         Before using the vector BY, the user should check that
C         NCALC=NB, i.e., all orders have been calculated to
C         the desired accuracy.  See error returns below.
C
C
C*******************************************************************
C*******************************************************************
C
C Explanation of machine-dependent constants.  Let
C
C   beta   = Radix for the floating-point system
C   p      = Number of significant base-beta digits in the
C            significand of a floating-point number
C   minexp = Smallest representable power of beta
C   maxexp = Smallest power of beta that overflows
C
C Then the following machine-dependent constants must be declared
C   in DATA statements.  IEEE values are provided as a default.
C
C   EPS    = beta ** (-p)
C   DEL    = Machine number below which sin(x)/x = 1; approximately
C            SQRT(EPS).
C   XMIN   = Smallest acceptable argument for RBESY; approximately
C            max(2*beta**minexp,2/XINF), rounded up
C   XINF   = Largest positive machine number; approximately
C            beta**maxexp
C   THRESH = Lower bound for use of the asymptotic form; approximately
C            AINT(-LOG10(EPS/2.0))+1.0
C   XLARGE = Upper bound on X; approximately 1/DEL, because the sine
C            and cosine functions have lost about half of their
C            precision at that point.
C
C
C     Approximate values for some important machines are:
C
C                        beta    p     minexp      maxexp      EPS
C
C  CRAY-1        (S.P.)    2    48     -8193        8191    3.55E-15
C  Cyber 180/185
C    under NOS   (S.P.)    2    48      -975        1070    3.55E-15
C  IEEE (IBM/XT,
C    SUN, etc.)  (S.P.)    2    24      -126         128    5.96E-8
C  IEEE (IBM/XT,
C    SUN, etc.)  (D.P.)    2    53     -1022        1024    1.11D-16
C  IBM 3033      (D.P.)   16    14       -65          63    1.39D-17
C  VAX           (S.P.)    2    24      -128         127    5.96E-8
C  VAX D-Format  (D.P.)    2    56      -128         127    1.39D-17
C  VAX G-Format  (D.P.)    2    53     -1024        1023    1.11D-16
C
C
C                         DEL      XMIN      XINF     THRESH  XLARGE
C
C CRAY-1        (S.P.)  5.0E-8  3.67E-2466 5.45E+2465  15.0E0  2.0E7
C Cyber 180/855
C   under NOS   (S.P.)  5.0E-8  6.28E-294  1.26E+322   15.0E0  2.0E7
C IEEE (IBM/XT,
C   SUN, etc.)  (S.P.)  1.0E-4  2.36E-38   3.40E+38     8.0E0  1.0E4
C IEEE (IBM/XT,
C   SUN, etc.)  (D.P.)  1.0D-8  4.46D-308  1.79D+308   16.0D0  1.0D8
C IBM 3033      (D.P.)  1.0D-8  2.77D-76   7.23D+75    17.0D0  1.0D8
C VAX           (S.P.)  1.0E-4  1.18E-38   1.70E+38     8.0E0  1.0E4
C VAX D-Format  (D.P.)  1.0D-9  1.18D-38   1.70D+38    17.0D0  1.0D9
C VAX G-Format  (D.P.)  1.0D-8  2.23D-308  8.98D+307   16.0D0  1.0D8
C
C*******************************************************************
C*******************************************************************
C
C Error returns
C
C  In case of an error, NCALC .NE. NB, and not all Y's are
C  calculated to the desired accuracy.
C
C  NCALC .LE. -1:  An argument is out of range. For example,
C       NB .LE. 0, or ABS(X) .GE. XLARGE.  In this case,
C       BY(1) = 0.0, the remainder of the BY-vector is not
C       calculated, and NCALC is set to MIN0(NB,0)-1  so that
C       NCALC .NE. NB.
C  1 .LT. NCALC .LT. NB: Not all requested function values could
C       be calculated accurately.  BY(I) contains correct function
C       values for I .LE. NCALC, and and the remaining NB-NCALC
C       array elements contain 0.0.
C
C
C Intrinsic functions required are:
C
C     ABS, AINT, COS, INT, LOG, SIN, SQRT
C
C
C Acknowledgement
C
C  This program draws heavily on Temme's Algol program for Y(a,x)
C  and Y(a+1,x) and on Campbell's programs for Y_nu(x).  Temme's
C  scheme is used for  x < THRESH, and Campbell's scheme is used
C  in the asymptotic region.  Segments of code from both sources
C  have been translated into Fortran 77, merged, and heavily modified.
C  Modifications include parameterization of machine dependencies,
C  use of a new approximation for ln(gamma(x)), and built-in
C  protection against overflow and destructive underflow.
C
C References: "Bessel functions J_nu(x) and Y_nu(x) of real
C              order and real argument," Campbell, J. B.,
C              Comp. Phy. Comm. 18, 1979, pp. 133-142.
C
C             "On the numerical evaluation of the ordinary
C              Bessel function of the second kind," Temme,
C              N. M., J. Comput. Phys. 21, 1976, pp. 343-350.
C
C  Latest modification: March 15, 1992
C
C  Modified by: W. J. Cody
C               Applied Mathematics Division
C               Argonne National Laboratory
C               Argonne, IL  60439
C
C----------------------------------------------------------------------
      INTEGER I,K,NA,NB,NCALC
CS    REAL
CD    DOUBLE PRECISION
     1  ALFA,ALPHA,AYE,B,BY,C,CH,COSMU,D,DEL,DEN,DDIV,DIV,DMU,D1,D2,
     2  E,EIGHT,EN,ENU,EN1,EPS,EVEN,EX,F,FIVPI,G,GAMMA,H,HALF,ODD,
     3  ONBPI,ONE,ONE5,P,PA,PA1,PI,PIBY2,PIM5,Q,QA,QA1,Q0,R,S,SINMU,
     4  SQ2BPI,TEN9,TERM,THREE,THRESH,TWO,TWOBYX,X,XINF,XLARGE,XMIN,
     5  XNA,X2,YA,YA1,ZERO
      DIMENSION BY(NB),CH(21)
C----------------------------------------------------------------------
C  Mathematical constants
C    FIVPI = 5*PI
C    PIM5 = 5*PI - 15
C    ONBPI = 1/PI
C    PIBY2 = PI/2
C    SQ2BPI = SQUARE ROOT OF 2/PI
C----------------------------------------------------------------------
CS    DATA ZERO,HALF,ONE,TWO,THREE/0.0E0,0.5E0,1.0E0,2.0E0,3.0E0/
CS    DATA EIGHT,ONE5,TEN9/8.0E0,15.0E0,1.9E1/
CS    DATA FIVPI,PIBY2/1.5707963267948966192E1,1.5707963267948966192E0/
CS    DATA PI,SQ2BPI/3.1415926535897932385E0,7.9788456080286535588E-1/
CS    DATA PIM5,ONBPI/7.0796326794896619231E-1,3.1830988618379067154E-1/
CD    DATA ZERO,HALF,ONE,TWO,THREE/0.0D0,0.5D0,1.0D0,2.0D0,3.0D0/
CD    DATA EIGHT,ONE5,TEN9/8.0D0,15.0D0,1.9D1/
CD    DATA FIVPI,PIBY2/1.5707963267948966192D1,1.5707963267948966192D0/
CD    DATA PI,SQ2BPI/3.1415926535897932385D0,7.9788456080286535588D-1/
CD    DATA PIM5,ONBPI/7.0796326794896619231D-1,3.1830988618379067154D-1/
C----------------------------------------------------------------------
C  Machine-dependent constants
C----------------------------------------------------------------------
CS    DATA DEL,XMIN,XINF,EPS/1.0E-4,2.36E-38,3.40E38,5.96E-8/
CS    DATA THRESH,XLARGE/8.0E0,1.0E4/
CD    DATA DEL,XMIN,XINF,EPS/1.0D-8,4.46D-308,1.79D308,1.11D-16/
CD    DATA THRESH,XLARGE/16.0D0,1.0D8/
C----------------------------------------------------------------------
C  Coefficients for Chebyshev polynomial expansion of
C         1/gamma(1-x), abs(x) .le. .5
C----------------------------------------------------------------------
CS    DATA CH/-0.67735241822398840964E-23,-0.61455180116049879894E-22,
CS   1         0.29017595056104745456E-20, 0.13639417919073099464E-18,
CS   2         0.23826220476859635824E-17,-0.90642907957550702534E-17,
CS   3        -0.14943667065169001769E-14,-0.33919078305362211264E-13,
CS   4        -0.17023776642512729175E-12, 0.91609750938768647911E-11,
CS   5         0.24230957900482704055E-09, 0.17451364971382984243E-08,
CS   6        -0.33126119768180852711E-07,-0.86592079961391259661E-06,
CS   7        -0.49717367041957398581E-05, 0.76309597585908126618E-04,
CS   8         0.12719271366545622927E-02, 0.17063050710955562222E-02,
CS   9        -0.76852840844786673690E-01,-0.28387654227602353814E+00,
CS   A         0.92187029365045265648E+00/
CD    DATA CH/-0.67735241822398840964D-23,-0.61455180116049879894D-22,
CD   1         0.29017595056104745456D-20, 0.13639417919073099464D-18,
CD   2         0.23826220476859635824D-17,-0.90642907957550702534D-17,
CD   3        -0.14943667065169001769D-14,-0.33919078305362211264D-13,
CD   4        -0.17023776642512729175D-12, 0.91609750938768647911D-11,
CD   5         0.24230957900482704055D-09, 0.17451364971382984243D-08,
CD   6        -0.33126119768180852711D-07,-0.86592079961391259661D-06,
CD   7        -0.49717367041957398581D-05, 0.76309597585908126618D-04,
CD   8         0.12719271366545622927D-02, 0.17063050710955562222D-02,
CD   9        -0.76852840844786673690D-01,-0.28387654227602353814D+00,
CD   A         0.92187029365045265648D+00/
C----------------------------------------------------------------------
      EX = X
      ENU = ALPHA
      IF ((NB .GT. 0) .AND. (X .GE. XMIN) .AND. (EX .LT. XLARGE)
     1       .AND. (ENU .GE. ZERO) .AND. (ENU .LT. ONE))  THEN
            XNA = AINT(ENU+HALF)
            NA = INT(XNA)
            IF (NA .EQ. 1) ENU = ENU - XNA
            IF (ENU .EQ. -HALF) THEN
                  P = SQ2BPI/SQRT(EX)
                  YA = P * SIN(EX)
                  YA1 = -P * COS(EX)
               ELSE IF (EX .LT. THREE) THEN
C----------------------------------------------------------------------
C  Use Temme's scheme for small X
C----------------------------------------------------------------------
                  B = EX * HALF
                  D = -LOG(B)
                  F = ENU * D
                  E = B**(-ENU)
                  IF (ABS(ENU) .LT. DEL) THEN
                        C = ONBPI
                     ELSE
                        C = ENU / SIN(ENU*PI)
                  END IF
C----------------------------------------------------------------------
C  Computation of sinh(f)/f
C----------------------------------------------------------------------
                  IF (ABS(F) .LT. ONE) THEN
                        X2 = F*F
                        EN = TEN9
                        S = ONE
                        DO 80 I = 1, 9
                           S = S*X2/EN/(EN-ONE)+ONE
                           EN = EN - TWO
   80                   CONTINUE
                     ELSE
                        S = (E - ONE/E) * HALF / F
                  END IF
C----------------------------------------------------------------------
C  Computation of 1/gamma(1-a) using Chebyshev polynomials
C----------------------------------------------------------------------
                  X2 = ENU*ENU*EIGHT
                  AYE = CH(1)
                  EVEN = ZERO
                  ALFA = CH(2)
                  ODD = ZERO
                  DO 40 I = 3, 19, 2
                     EVEN = -(AYE+AYE+EVEN)
                     AYE = -EVEN*X2 - AYE + CH(I)
                     ODD = -(ALFA+ALFA+ODD)
                     ALFA = -ODD*X2 - ALFA + CH(I+1)
   40             CONTINUE
                  EVEN = (EVEN*HALF+AYE)*X2 - AYE + CH(21)
                  ODD = (ODD+ALFA)*TWO
                  GAMMA = ODD*ENU + EVEN
C----------------------------------------------------------------------
C  End of computation of 1/gamma(1-a)
C----------------------------------------------------------------------
                  G = E * GAMMA
                  E = (E + ONE/E) * HALF
                  F = TWO*C*(ODD*E+EVEN*S*D)
                  E = ENU*ENU
                  P = G*C
                  Q = ONBPI / G
                  C = ENU*PIBY2
                  IF (ABS(C) .LT. DEL) THEN
                        R = ONE
                     ELSE
                        R = SIN(C)/C
                  END IF
                  R = PI*C*R*R
                  C = ONE
                  D = - B*B
                  H = ZERO
                  YA = F + R*Q
                  YA1 = P
                  EN = ZERO
  100             EN = EN + ONE
                  IF (ABS(G/(ONE+ABS(YA)))
     1                      + ABS(H/(ONE+ABS(YA1))) .GT. EPS) THEN
                        F = (F*EN+P+Q)/(EN*EN-E)
                        C = C * D/EN
                        P = P/(EN-ENU)
                        Q = Q/(EN+ENU)
                        G = C*(F+R*Q)
                        H = C*P - EN*G
                        YA = YA + G
                        YA1 = YA1+H
                        GO TO 100
                  END IF
                  YA = -YA
                  YA1 = -YA1/B
               ELSE IF (EX .LT. THRESH) THEN
C----------------------------------------------------------------------
C  Use Temme's scheme for moderate X
C----------------------------------------------------------------------
                  C = (HALF-ENU)*(HALF+ENU)
                  B = EX + EX
                  E = (EX*ONBPI*COS(ENU*PI)/EPS)
                  E = E*E
                  P = ONE
                  Q = -EX
                  R = ONE + EX*EX
                  S = R
                  EN = TWO
  200             IF (R*EN*EN .LT. E) THEN
                        EN1 = EN+ONE
                        D = (EN-ONE+C/EN)/S
                        P = (EN+EN-P*D)/EN1
                        Q = (-B+Q*D)/EN1
                        S = P*P + Q*Q
                        R = R*S
                        EN = EN1
                        GO TO 200
                  END IF
                  F = P/S
                  P = F
                  G = -Q/S
                  Q = G
  220             EN = EN - ONE
                  IF (EN .GT. ZERO) THEN
                        R = EN1*(TWO-P)-TWO
                        S = B + EN1*Q
                        D = (EN-ONE+C/EN)/(R*R+S*S)
                        P = D*R
                        Q = D*S
                        E = F + ONE
                        F = P*E - G*Q
                        G = Q*E + P*G
                        EN1 = EN
                        GO TO 220
                  END IF
                  F = ONE + F
                  D = F*F + G*G
                  PA = F/D
                  QA = -G/D
                  D = ENU + HALF -P
                  Q = Q + EX
                  PA1 = (PA*Q-QA*D)/EX
                  QA1 = (QA*Q+PA*D)/EX
                  B = EX - PIBY2*(ENU+HALF)
                  C = COS(B)
                  S = SIN(B)
                  D = SQ2BPI/SQRT(EX)
                  YA = D*(PA*S+QA*C)
                  YA1 = D*(QA1*S-PA1*C)
               ELSE
C----------------------------------------------------------------------
C  Use Campbell's asymptotic scheme.
C----------------------------------------------------------------------
                  NA = 0
                  D1 = AINT(EX/FIVPI)
                  I = INT(D1)
                  DMU = ((EX-ONE5*D1)-D1*PIM5)-(ALPHA+HALF)*PIBY2
                  IF (I-2*(I/2) .EQ. 0) THEN
                        COSMU = COS(DMU)
                        SINMU = SIN(DMU)
                     ELSE
                        COSMU = -COS(DMU)
                        SINMU = -SIN(DMU)
                  END IF
                  DDIV = EIGHT * EX
                  DMU = ALPHA
                  DEN = SQRT(EX)
                  DO 350 K = 1, 2
                     P = COSMU
                     COSMU = SINMU
                     SINMU = -P
                     D1 = (TWO*DMU-ONE)*(TWO*DMU+ONE)
                     D2 = ZERO
                     DIV = DDIV
                     P = ZERO
                     Q = ZERO
                     Q0 = D1/DIV
                     TERM = Q0
                     DO 310 I = 2, 20
                        D2 = D2 + EIGHT
                        D1 = D1 - D2
                        DIV = DIV + DDIV
                        TERM = -TERM*D1/DIV
                        P = P + TERM
                        D2 = D2 + EIGHT
                        D1 = D1 - D2
                        DIV = DIV + DDIV
                        TERM = TERM*D1/DIV
                        Q = Q + TERM
                        IF (ABS(TERM) .LE. EPS) GO TO 320
  310                CONTINUE
  320                P = P + ONE
                     Q = Q + Q0
                     IF (K .EQ. 1) THEN
                           YA = SQ2BPI * (P*COSMU-Q*SINMU) / DEN
                        ELSE
                           YA1 = SQ2BPI * (P*COSMU-Q*SINMU) / DEN
                     END IF
                     DMU = DMU + ONE
  350             CONTINUE
            END IF
            IF (NA .EQ. 1) THEN
               H = TWO*(ENU+ONE)/EX
               IF (H .GT. ONE) THEN
                  IF (ABS(YA1) .GT. XINF/H) THEN
                     H = ZERO
                     YA = ZERO
                  END IF
               END IF
               H = H*YA1 - YA
               YA = YA1
               YA1 = H
            END IF
C----------------------------------------------------------------------
C  Now have first one or two Y's
C----------------------------------------------------------------------
            BY(1) = YA
            BY(2) = YA1
            IF (YA1 .EQ. ZERO) THEN
                  NCALC = 1
               ELSE
                  AYE = ONE + ALPHA
                  TWOBYX = TWO/EX
                  NCALC = 2
                  DO 400 I = 3, NB
                     IF (TWOBYX .LT. ONE) THEN
                           IF (ABS(BY(I-1))*TWOBYX .GE. XINF/AYE)
     1                                                     GO TO 450
                        ELSE
                           IF (ABS(BY(I-1)) .GE. XINF/AYE/TWOBYX )
     1                                                     GO TO 450
                     END IF
                     BY(I) = TWOBYX*AYE*BY(I-1) - BY(I-2)
                     AYE = AYE + ONE
                     NCALC = NCALC + 1
  400             CONTINUE
            END IF
  450       DO 460 I = NCALC+1, NB
               BY(I) = ZERO
  460       CONTINUE
         ELSE
            BY(1) = ZERO
            NCALC = MIN(NB,0) - 1
      END IF
  900 RETURN
C---------- Last line of RYBESL ----------
      END



      PROGRAM RYTEST
C----------------------------------------------------------------------
C FORTRAN 77 program to test RYBESL
C
C  Method:
C
C     Two different accuracy tests are used.  In the first interval,
C     function values are compared against values generated with the
C     multiplication formula, where the Bessel values used in the
C     multiplication formula are obtained from the function program.
C     In the remaining intervals, function values are compared
C     against values generated with a local Taylor series expansion.
C     Derivatives in the expansion are expressed in terms of the
C     first two Bessel functions, which are in turn obtained from
C     the function program.
C
C  Data required
C
C     None
C
C  Subprograms required from this package
C
C     MACHAR - An environmental inquiry program providing
C         information on the floating-point arithmetic
C         system.  Note that the call to MACHAR can
C         be deleted provided the following five
C         parameters are assigned the values indicated
C
C              IBETA  - the radix of the floating-point system
C              IT     - the number of base-IBETA digits in the
C                       significant of a floating-point number
C              EPS    - the smallest positive floating-point
C                       number such that 1.0+EPS .NE. 1.0
C              XMIN   - the smallest positive normalized
C                       floating-point number
C              XMAX   - the largest finite floating-point number
C
C     REN(K) - a function subprogram returning random real
C              numbers uniformly distributed over (0,1)
C
C
C  Intrinsic functions required are:
C
C      ABS, DBLE, INT, LOG, MAX, REAL, SQRT
C
C  Reference: "Performance evaluation of programs for certain
C              Bessel functions", W. J. Cody and L. Stoltz,
C              ACM Trans. on Math. Software, Vol. 15, 1989,
C              pp 41-48.
C
C             "Use of Taylor series to test accuracy of function
C              programs," W. J. Cody and L. Stoltz, submitted for
C              publication.
C
C  Latest modification: March 14, 1992
C
C  Author: W. J. Cody 
C          Mathematics and Computer Science Division
C          Argonne National Laboratory
C          Argonne, IL 60439
C
C Acknowledgement: this program is a minor modification of the test
C          driver for RIBESL whose primary author was Laura Stoltz.
C
C----------------------------------------------------------------------
      INTEGER I,IBETA,IEXP,II,III,IND,IOUT,IRND,IT,J,JT,J1,J2,K,KK,
     1    K1,K2,K3,LAST,M,MACHEP,MAXEXP,MB,MINEXP,MVR,N,NCALC,NDUM,
     2    NDX,NDX2,NEGEP,NGRD,NK,NO1,NUM
CS    REAL  
CD    DOUBLE PRECISION  
     1    A,AIT,ALBETA,ALPHA,ALPHSQ,A1,AR1,AR2,B,BETA,CONV,D,DEL,
     2    DELTA,DERIV,EPS,EPSNEG,F,FXMX,G,HALF,ONE,ONEP25,P875,REN,
     3    R6,R7,SIXTEN,SUM,TEN,TWO,TWOBPI,T1,T2,U,U2,W,X,XJ1,XL,XLAM,
     4    XMAX,XMB,XMIN,XN,X1,X99,Y,YSQ,Z,ZERO,ZZ
      DIMENSION AR1(11,6),AR2(13,9),G(5),NDX(24),NDX2(8),U(20),U2(20)
CS    DATA ZERO,HALF,ONE,ONEP25,TWO/0.0E0,0.5E0,1.0E0,1.25E0,2.0E0/,
CS   1    P875,TEN,SIXTEN,X99/0.875E0,10.0E0,1.6E1,-999.0E0/,
CS   2    XLAM,TWOBPI/1.03125E0,0.6366E0/
CD    DATA ZERO,HALF,ONE,ONEP25,TWO/0.0D0,0.5D0,1.0D0,1.25D0,2.0D0/,
CD   1    P875,TEN,SIXTEN,X99/0.875D0,10.0D0,1.6D1,-999.0D0/,
CD   2    XLAM,TWOBPI/1.03125D0,0.6366D0/
C----------------------------------------------------------------------
C  Arrays related to expansion of the derivatives in terms
C   of the first two Bessel functions.
C----------------------------------------------------------------------
      DATA  NDX/9,7,5,3,1,8,6,4,2,7,5,3,1,6,4,2,5,3,1,4,2,3,1,2/
      DATA  NDX2/5,9,13,16,19,21,23,24/
CS    DATA AR1/0.0E0,-1.0E0,0.0E0,1.0E0,0.0E0,1.0E0,-3.0E0,0.0E0,-2.0E0,
CS   1         1.2E1,0.0E0,1.0E0,0.0E0,-1.0E0,-1.0E0,2.0E0,0.0E0,
CS   2         2.0E0,-6.0E0,1.0E0,-7.0E0,2.4E1,0.0E0,0.0E0,1.0E0,0.0E0,
CS   3         -3.0E0,0.0E0,-2.0E0,1.1E1,0.0E0,1.2E1,-5.0E1,0.0E0,
CS   4         0.0E0,0.0E0,0.0E0,1.0E0,0.0E0,0.0E0,-6.0E0,0.0E0,-2.0E0,
CS   5         3.5E1,0.0E0,0.0E0,0.0E0,0.0E0,0.0E0,0.0E0,0.0E0,1.0E0,
CS   6         0.0E0,0.0E0,-1.0E1,0.0E0,0.0E0,0.0E0,0.0E0,0.0E0,0.0E0,
CS   7         0.0E0,0.0E0,0.0E0,0.0E0,1.0E0/
CS    DATA AR2/-1.0E0,9.0E0,-6.0E1,0.0E0,3.0E0,-5.1E1,3.6E2,0.0E0,
CS   1          1.0E0,-1.8E1,3.45E2,-2.52E3,0.0E0,0.0E0,-3.0E0,3.3E1,
CS   2          -1.2E2,-1.0E0,1.5E1,-1.92E2,7.2E2,0.0E0,4.0E0,-9.6E1,
CS   3          1.32E3,-5.04E3,0.0E0,3.0E0,-7.8E1,2.74E2,0.0E0,-2.7E1,
CS   4          5.7E2,-1.764E3,0.0E0,-4.0E0,2.46E2,-4.666E3,1.3068E4,
CS   5          0.0E0,0.0E0,1.8E1,-2.25E2,0.0E0,3.0E0,-1.5E2,1.624E3,
CS   6          0.0E0,0.0E0,-3.6E1,1.32E3,-1.3132E4,0.0E0,0.0E0,-3.0E0,
CS   7          8.5E1,0.0E0,0.0E0,4.5E1,-7.35E2,0.0E0,0.0E0,6.0E0,
CS   8          -5.5E2,6.769E3,0.0E0,0.0E0,0.0E0,-1.5E1,0.0E0,0.0E0,
CS   9          -3.0E0,1.75E2,0.0E0,0.0E0,0.0E0,6.0E1,-1.96E3,0.0E0,
CS   a          0.0E0,0.0E0,1.0E0,0.0E0,0.0E0,0.0E0,-2.1E1,0.0E0,0.0E0,
CS   b          0.0E0,-4.0E0,3.22E2,0.0E0,0.0E0,0.0E0,0.0E0,0.0E0,0.0E0,
CS   c          0.0E0,1.0E0,0.0E0,0.0E0,0.0E0,0.0E0,-2.8E1,0.0E0,0.0E0,
CS   d          0.0E0,0.0E0,0.0E0,0.0E0,0.0E0,0.0E0,0.0E0,0.0E0,0.0E0,
CS   e          0.0E0,1.0E0/
CD    DATA AR1/0.0D0,-1.0D0,0.0D0,1.0D0,0.0D0,1.0D0,-3.0D0,0.0D0,-2.0D0,
CD   1         1.2D1,0.0D0,1.0D0,0.0D0,-1.0D0,-1.0D0,2.0D0,0.0D0,
CD   2         2.0D0,-6.0D0,1.0D0,-7.0D0,2.4D1,0.0D0,0.0D0,1.0D0,0.0D0,
CD   3         -3.0D0,0.0D0,-2.0D0,1.1D1,0.0D0,1.2D1,-5.0D1,0.0D0,
CD   4         0.0D0,0.0D0,0.0D0,1.0D0,0.0D0,0.0D0,-6.0D0,0.0D0,-2.0D0,
CD   5         3.5D1,0.0D0,0.0D0,0.0D0,0.0D0,0.0D0,0.0D0,0.0D0,1.0D0,
CD   6         0.0D0,0.0D0,-1.0D1,0.0D0,0.0D0,0.0D0,0.0D0,0.0D0,0.0D0,
CD   7         0.0D0,0.0D0,0.0D0,0.0D0,1.0D0/
CD    DATA AR2/-1.0D0,9.0D0,-6.0D1,0.0D0,3.0D0,-5.1D1,3.6D2,0.0D0,
CD   1          1.0D0,-1.8D1,3.45D2,-2.52D3,0.0D0,0.0D0,-3.0D0,3.3D1,
CD   2          -1.2D2,-1.0D0,1.5D1,-1.92D2,7.2D2,0.0D0,4.0D0,-9.6D1,
CD   3          1.32D3,-5.04D3,0.0D0,3.0D0,-7.8D1,2.74D2,0.0D0,-2.7D1,
CD   4          5.7D2,-1.764D3,0.0D0,-4.0D0,2.46D2,-4.666D3,1.3068D4,
CD   5          0.0D0,0.0D0,1.8D1,-2.25D2,0.0D0,3.0D0,-1.5D2,1.624D3,
CD   6          0.0D0,0.0D0,-3.6D1,1.32D3,-1.3132D4,0.0D0,0.0D0,-3.0D0,
CD   7          8.5D1,0.0D0,0.0D0,4.5D1,-7.35D2,0.0D0,0.0D0,6.0D0,
CD   8          -5.5D2,6.769D3,0.0D0,0.0D0,0.0D0,-1.5D1,0.0D0,0.0D0,
CD   9          -3.0D0,1.75D2,0.0D0,0.0D0,0.0D0,6.0D1,-1.96D3,0.0D0,
CD   a          0.0D0,0.0D0,1.0D0,0.0D0,0.0D0,0.0D0,-2.1D1,0.0D0,0.0D0,
CD   b          0.0D0,-4.0D0,3.22D2,0.0D0,0.0D0,0.0D0,0.0D0,0.0D0,0.0D0,
CD   c          0.0D0,1.0D0,0.0D0,0.0D0,0.0D0,0.0D0,-2.8D1,0.0D0,0.0D0,
CD   d          0.0D0,0.0D0,0.0D0,0.0D0,0.0D0,0.0D0,0.0D0,0.0D0,0.0D0,
CD   e          0.0D0,1.0D0/
      DATA IOUT/6/
C----------------------------------------------------------------------
C  Statement function for integer to float conversion
C----------------------------------------------------------------------
CS    CONV(NDUM) = REAL(NDUM)
CD    CONV(NDUM) = DBLE(NDUM)
C----------------------------------------------------------------------
C  Determine machine parameters and set constants
C----------------------------------------------------------------------
      CALL MACHAR(IBETA,IT,IRND,NGRD,MACHEP,NEGEP,IEXP,MINEXP,
     1            MAXEXP,EPS,EPSNEG,XMIN,XMAX)
      BETA = CONV(IBETA)
      AIT = CONV(IT)
      ALBETA = LOG(BETA)
      A = ZERO
      B = TWO
      JT = 0
      DELTA = XLAM - ONE 
      F = (DELTA) * (XLAM+ONE) * HALF
C----------------------------------------------------------------------
C  Random argument accuracy tests
C----------------------------------------------------------------------
      DO 300 J = 1, 4
         N = 2000
         XN = CONV(N)
         K1 = 0
         K2 = 0
         K3 = 0
         X1 = ZERO
         A1 = ZERO
         R6 = ZERO
         R7 = ZERO
         DEL = (B - A) / XN
         XL = A
         DO 200 I = 1, N
            X = DEL * REN(JT) + XL
  110       ALPHA = REN(JT)
C----------------------------------------------------------------------
C   Carefully purify arguments
C----------------------------------------------------------------------
            IF (J .LE. 1) THEN
                  Y = X/XLAM
               ELSE
                  Y = X - DELTA
            END IF
            W = SIXTEN * Y
            T1 = W + Y
            T1 = W + T1
            Y = T1 - W
            Y = Y - W
            IF (J .LE. 1) THEN
                  X = Y * XLAM
                  MB = 15
               ELSE
                  X = Y + DELTA
                  MB = 2
            END IF
            CALL RYBESL(Y,ALPHA,MB,U2,NCALC)
            CALL RYBESL(X,ALPHA,MB,U,NCALC)
            IF (J .LE. 1) THEN
C----------------------------------------------------------------------
C   Accuracy test is based on the multiplication theorem.
C   First, filter out cases where function values are small.
C----------------------------------------------------------------------
            IF (SIGN(ONE,U(1))*SIGN(ONE,U2(1)) .LT. ZERO) GO TO 110
                  D = -F*Y
                  MB = NCALC - 1
                  XMB = CONV(MB)
                  SUM = U2(MB+1)
                  Z = SUM
                  IND = MB
                  DO 125 II = 2, MB
                     SUM = SUM * D / XMB + U2(IND)
                     Z = Z * D / XMB
                     IND = IND - 1
                     XMB = XMB - ONE
  125             CONTINUE
                  Z = Z * D
C----------------------------------------------------------------------
C   Check for convergence.  
C----------------------------------------------------------------------
                  IF (ABS(Z/U2(IND)) .GT. EPS) THEN
                     XL = XL + DEL
                     GO TO 200
                  END IF
                  ZZ = SUM * D + U2(IND)
C----------------------------------------------------------------------
C   Check for numerical stability.  
C----------------------------------------------------------------------
                  D = ABS(ZZ/U2(IND))
                  IF ((D .GT. ONEP25) .OR. (D .LT. P875)) GO TO 110
                  ZZ = ZZ * XLAM ** ALPHA
               ELSE
C----------------------------------------------------------------------
C   Accuracy test is based on local Taylor's series expansion.
C   First, filter out cases where function values or derivatives
C   are small.
C----------------------------------------------------------------------
                  W = MIN(ABS(U(1)),ABS(U2(1)),ABS(U2(2)))
                  IF (W .LT. SQRT(TWOBPI/X)/SIXTEN) GO TO 110
                  IF (ABS(U(1)) .LT. ABS(U2(1))) THEN
                     Z = X
                     X = Y
                     Y = Z
                     DELTA = X - Y
                     DO 120 II = 1, 9
                        Z = U(II)
                        U(II) = U2(II)
                        U2(II) = Z
  120                CONTINUE
                  END IF
                  YSQ = Y * Y
                  ALPHSQ = ALPHA * ALPHA
                  MB = 8
                  J1 = MB
                  XJ1 = CONV(J1+1)
                  IEXP = 0
                  NK = 13
                  NUM = 2
                  DO 180 II = 1, MB
                     IF (NK .EQ. 0) THEN 
                           NK = 11 
                           NUM = 1
                     END IF
                     K = 9 - J1
                     IF (K .GT. 1) THEN
                           NO1 = NDX2(K-1) + 1
                        ELSE
                           NO1 = 1
                     END IF
                     MVR = NO1
                     LAST = NDX2(K)
                     K = LAST - NO1 + 1
C----------------------------------------------------------------------
C         Group I(ALPHA) terms in the derivative
C----------------------------------------------------------------------
                     DO 160 III = 1, K
                        J2 = NDX(MVR)
                        IF (NUM .EQ. 1) THEN
                              G(III) = AR1(NK,J2)
                           ELSE
                              G(III) = AR2(NK,J2)
                        END IF
                        IF (J2 .GT. 1) THEN
  157                         J2 = J2 - 1
                              IF (NUM .EQ. 1) THEN
                                    G(III) = G(III) * ALPHA + AR1(NK,J2)
                                 ELSE
                                    G(III) = G(III) * ALPHA + AR2(NK,J2)
                              END IF
                           IF (J2 .GT. 1) GO TO 157
                        END IF
                        MVR = MVR + 1
                        NK = NK - 1
  160                CONTINUE
                     T1 = G(1)
                     DO 162 III = 2, K
                        T1 = T1 / YSQ + G(III)
  162                CONTINUE
                     IF (IEXP .EQ. 1) T1 = T1 / Y
C----------------------------------------------------------------------
C         Group I(ALPHA+1) terms in the derivative
C----------------------------------------------------------------------
                     IEXP = 1 - IEXP
                     NK = NK + K
                     MVR = NO1
                     KK = K
                     DO 165 III = 1, K
                        J2 = NDX(MVR)
                        M = MOD(J2,2)
                        IF (M .EQ. 1) J2 = J2 - 1
                        IF (J2 .GE. 2) THEN
                              IF (NUM .EQ. 1) THEN
                                    G(III) = AR1(NK,J2)
                                 ELSE
                                    G(III) = AR2(NK,J2)
                              END IF
  163                         J2 = J2 - 2
                              IF (J2 .GE. 2) THEN
                                    IF (NUM .EQ. 1) THEN
                                          G(III) = G(III) * ALPHSQ +
     1                                             AR1(NK,J2)
                                       ELSE
                                          G(III) = G(III) * ALPHSQ +
     1                                             AR2(NK,J2)
                                    END IF
                                    GO TO 163
                              END IF
                           ELSE
                              KK = III - 1
                        END IF
                        MVR = MVR + 1
                        NK = NK - 1
  165                CONTINUE
                     T2 = G(1)
                     DO 167 III = 2, KK
                        T2 = T2 / YSQ + G(III)
  167                CONTINUE
                     IF (IEXP .EQ. 1) T2 = T2 / Y
                     DERIV = U2(1) * T1 - U2(2) * T2
                     IF (J1 .EQ. 8) THEN
                           SUM = DERIV
                        ELSE
                           SUM = SUM * DELTA / XJ1 + DERIV
                     END IF
                     J1 = J1 - 1
                     XJ1 = XJ1 - ONE
  180             CONTINUE
                  ZZ = SUM * DELTA + U2(1)
            END IF
            MB = 2 
            Z = U(1)
C----------------------------------------------------------------------
C   Accumulate Results
C----------------------------------------------------------------------
            W = (Z - ZZ) / Z
            IF (W .GT. ZERO) THEN 
                  K1 = K1 + 1
               ELSE IF (W .LT. ZERO) THEN 
                  K3 = K3 + 1
               ELSE
                  K2 = K2 + 1
            END IF
            W = ABS(W)
            IF (W .GT. R6) THEN
                  R6 = W
                  X1 = X
                  A1 = ALPHA
                  FXMX = Z
            END IF
            R7 = R7 + W * W
            XL = XL + DEL
  200    CONTINUE
C----------------------------------------------------------------------
C   Gather and print statistics for test
C----------------------------------------------------------------------
         N = K1 + K2 + K3
         R7 = SQRT(R7/XN)
         IF (J .LE. 1) THEN
               WRITE (IOUT,1000)
            ELSE
               WRITE (IOUT,1001)
         END IF
         WRITE (IOUT,1010) N,A,B
         WRITE (IOUT,1011) K1,K2,K3
         IF (N .NE. 2000) WRITE (IOUT,1012) 2000-N
         WRITE (IOUT,1020) IT,IBETA
         IF (R6 .NE. ZERO) THEN
               W = LOG(R6)/ALBETA
            ELSE
               W = X99
         END IF
         WRITE (IOUT,1021) R6,IBETA,W,X1,A1
         WRITE (IOUT,1024) FXMX
         W = MAX(AIT+W,ZERO)
         WRITE (IOUT,1022) IBETA,W
         IF (R7 .NE. ZERO) THEN
               W = LOG(R7)/ALBETA
            ELSE
               W = X99
         END IF
         WRITE (IOUT,1023) R7,IBETA,W
         W = MAX(AIT+W,ZERO)
         WRITE (IOUT,1022) IBETA,W
C----------------------------------------------------------------------
C   Initialize for next test
C----------------------------------------------------------------------
         A = B
         IF (J .EQ. 1) THEN
               B = TEN
            ELSE IF (J .EQ. 2) THEN
               B = B + B
            ELSE IF (J .EQ. 3) THEN
               A = B + TEN
               B = A + TEN
         END IF
  300 CONTINUE
C----------------------------------------------------------------------
C   Test of error returns
C
C   First, test with bad parameters
C----------------------------------------------------------------------
      WRITE (IOUT, 2006)
      X = ONE 
      ALPHA = ONE + HALF
      MB = 5
      CALL RYBESL(X,ALPHA,MB,U,NCALC)
      WRITE (IOUT, 2011) X,ALPHA,MB,U(1),NCALC
      ALPHA = HALF
      MB = -MB
      CALL RYBESL(X,ALPHA,MB,U,NCALC)
      WRITE (IOUT, 2011) X,ALPHA,MB,U(1),NCALC
C----------------------------------------------------------------------
C   Tests with small parameters
C----------------------------------------------------------------------
      IF (XMIN*XMAX .GT. ONE) THEN
            X = XMIN
         ELSE
            X = ONE / XMAX
      END IF
      ALPHA = ZERO
      MB = 2
      CALL RYBESL(X,ALPHA,MB,U,NCALC)
      WRITE (IOUT, 2011) X,ALPHA,MB,U(1),NCALC
      X = X + X + X
      MB = 2
      CALL RYBESL(X,ALPHA,MB,U,NCALC)
      WRITE (IOUT, 2011) X,ALPHA,MB,U(1),NCALC
      ALPHA = ONE - EPS
      MB = 2
      CALL RYBESL(X,ALPHA,MB,U,NCALC)
      WRITE (IOUT, 2011) X,ALPHA,MB,U(1),NCALC
C----------------------------------------------------------------------
C   Last tests are with large parameters
C----------------------------------------------------------------------
      WRITE (IOUT, 2015)
      X = HALF / SQRT(EPS)
      ALPHA = HALF
      MB = 2
      CALL RYBESL(X,ALPHA,MB,U,NCALC)
      WRITE (IOUT, 2012) X,ALPHA
      WRITE (IOUT, 2014) NCALC,U(1)
      X = X * SIXTEN
      MB = 2
      CALL RYBESL(X,ALPHA,MB,U,NCALC)
      WRITE (IOUT, 2012) X,ALPHA
      WRITE (IOUT, 2013)
      WRITE (IOUT, 2014) NCALC,U(1)
      WRITE (IOUT, 2020)
      STOP
C----------------------------------------------------------------------
 1000 FORMAT('1Test of Y(X,ALPHA) vs Multiplication Theorem'//)
 1001 FORMAT('1Test of Y(X,ALPHA) vs Taylor series'//)
 1010 FORMAT(I7,' Random arguments were tested from the interval ',
     1    '(',F5.2,',',F5.2,')'//)
 1011 FORMAT(' Y(X,ALPHA) was larger',I6,' times,'/
     1    15X,' agreed',I6,' times, and'/
     1    11X,'was smaller',I6,' times.'//)
 1012 FORMAT(' NOTE: first ',I3,' arguments in test interval skipped'/
     1    7x,'because multiplication theorem did not converge'//)
 1020 FORMAT(' There are',I4,' base',I4,
     1    ' significant digits in a floating-point number'//)
 1021 FORMAT(' The maximum relative error of',E15.4,' = ',I4,' **',
     1    F7.2/4X,'occurred for X =',E13.6,' and NU =',E13.6)
 1022 FORMAT(' The estimated loss of base',I4,
     1    ' significant digits is',F7.2//)
 1023 FORMAT(' The root mean square relative error was',E15.4,
     1    ' = ',I4,' **',F7.2)
 1024 FORMAT(4x,'with Y(X,ALPHA) = ',E13.6)
 2006 FORMAT('1Check of Error Returns'///
     1    ' The following summarizes calls with indicated parameters'//
     2    ' NCALC different from MB indicates some form of error'//
     3    ' See documentation for RYBESL for details'//
     4    7X,'ARG',12X,'ALPHA',6X,'MB',6X,'B(1)',6X,'NCALC'//)
 2011 FORMAT(2E15.7,I5,E15.7,I5//)
 2012 FORMAT(' RYBESL will be called with the arguments',2E13.6)
 2013 FORMAT(' This should trigger an error message.')
 2014 FORMAT(' NCALC returned the value',I5/
     1    ' and RYBESL returned U(1) = ',E13.6/)
 2015 FORMAT(' Tests near the largest acceptable argument for RYBESL'/)
 2020 FORMAT(' This concludes the tests.') 
C     ---------- Last line of RYBESL test program ---------- 
      END

CS    REAL FUNCTION ANORM(ARG)
CD    DOUBLE PRECISION FUNCTION ANORM(ARG)
C------------------------------------------------------------------
C
C This function evaluates the normal distribution function:
C
C                              / x    
C                     1       |       -t*t/2
C          P(x) = ----------- |      e       dt
C                 sqrt(2 pi)  |
C                             /-oo
C
C   The main computation evaluates near-minimax approximations
C   derived from those in "Rational Chebyshev approximations for
C   the error function" by W. J. Cody, Math. Comp., 1969, 631-637.
C   This transportable program uses rational functions that
C   theoretically approximate the normal distribution function to
C   at least 18 significant decimal digits.  The accuracy achieved
C   depends on the arithmetic system, the compiler, the intrinsic
C   functions, and proper selection of the machine-dependent
C   constants.
C
C*******************************************************************
C*******************************************************************
C
C Explanation of machine-dependent constants.  Let
C
C   XMIN  = the smallest positive floating-point number.
C
C Then the following machine-dependent constants must be declared 
C   in DATA statements.  IEEE values are provided as a default.
C
C   EPS   = argument below which anorm(x) may be represented by
C           0.5  and above which  x*x  will not underflow.
C           A conservative value is the largest machine number X
C           such that   1.0 + X = 1.0   to machine precision.
C   XLOW  = the most negative argument for which ANORM does not
C           vanish.  This is the negative of the solution to 
C                    W(x) * (1-1/x**2) = XMIN,
C           where W(x) = exp(-x*x/2)/[x*sqrt(2*pi)].
C   XUPPR = positive argument beyond which anorm = 1.0.  A
C           conservative value is the solution to the equation
C                    exp(-x*x/2) = EPS,
C           i.e., XUPPR = sqrt[-2 ln(eps)].
C
C   Approximate values for some important machines are:
C
C                          XMIN        EPS        XLOW    XUPPR
C
C  CDC 7600      (S.P.)  3.13E-294   7.11E-15   -36.641   8.072
C  CRAY-1        (S.P.)  4.58E-246   7.11E-157 -106.521  26.816
C  IEEE (IBM/XT,
C    SUN, etc.)  (S.P.)  1.18E-38    5.96E-8    -12.949   5.768
C  IEEE (IBM/XT,
C    SUN, etc.)  (D.P.)  2.23D-308   1.11D-16   -37.519   8.572
C  IBM 195       (D.P.)  5.40D-79    1.39D-17   -18.781   8.811
C  VAX D-Format  (D.P.)  2.94D-39    1.39D-17   -13.055   8.811
C  VAX G-Format  (D.P.)  5.56D-309   1.11D-16   -37.556   8.572
C
C*******************************************************************
C*******************************************************************
C
C Error returns
C
C  The program returns  ANORM = 0     for  ARG .LE. XLOW.
C
C
C Intrinsic functions required are:
C
C     ABS, AINT, EXP
C
C
C  Author: W. J. Cody
C          Mathematics and Computer Science Division
C          Argonne National Laboratory
C          Argonne, IL 60439
C
C  Latest modification: March 15, 1992
C
C------------------------------------------------------------------
      INTEGER I
CS    REAL
CD    DOUBLE PRECISION
     1     A,ANORM,ARG,B,C,D,DEL,EPS,HALF,P,ONE,Q,RESULT,SIXTEN,
     2     SQRPI,THRSH,ROOT32,X,XLOW,XDEN,XNUM,Y,XSQ,XUPPR,ZERO
      DIMENSION A(5),B(4),C(9),D(8),P(6),Q(5)
C------------------------------------------------------------------
C  Mathematical constants
C
C  SQRPI = 1 / sqrt(2*pi), ROOT32 = sqrt(32), and
C  THRSH is the argument for which anorm = 0.75.
C------------------------------------------------------------------
CS    DATA ONE,HALF,ZERO,SIXTEN/1.0E0,0.5E0,0.0E0,1.60E1/,
CS   1     SQRPI/3.9894228040143267794E-1/,THRSH/0.66291E0/,
CS   2     ROOT32/5.656854248E0/
CD    DATA ONE,HALF,ZERO,SIXTEN/1.0D0,0.5D0,0.0D0,1.60D1/,
CD   1     SQRPI/3.9894228040143267794D-1/,THRSH/0.66291D0/,
CD   2     ROOT32/5.656854248D0/
C------------------------------------------------------------------
C  Machine-dependent constants
C------------------------------------------------------------------
CS    DATA EPS/5.96E-8/,XLOW/-12.949E0/,XUPPR/5.768E0/
CD    DATA EPS/1.11D-16/,XLOW/-37.519D0/,XUPPR/8.572D0/
C------------------------------------------------------------------
C  Coefficients for approximation in first interval
C------------------------------------------------------------------
CS    DATA A/2.2352520354606839287E00,1.6102823106855587881E02,
CS   1       1.0676894854603709582E03,1.8154981253343561249E04,
CS   2       6.5682337918207449113E-2/
CS    DATA B/4.7202581904688241870E01,9.7609855173777669322E02,
CS   1       1.0260932208618978205E04,4.5507789335026729956E04/
CD    DATA A/2.2352520354606839287D00,1.6102823106855587881D02,
CD   1       1.0676894854603709582D03,1.8154981253343561249D04,
CD   2       6.5682337918207449113D-2/
CD    DATA B/4.7202581904688241870D01,9.7609855173777669322D02,
CD   1       1.0260932208618978205D04,4.5507789335026729956D04/
C------------------------------------------------------------------
C  Coefficients for approximation in second interval
C------------------------------------------------------------------
CS    DATA C/3.9894151208813466764E-1,8.8831497943883759412E00,
CS   1       9.3506656132177855979E01,5.9727027639480026226E02,
CS   2       2.4945375852903726711E03,6.8481904505362823326E03,
CS   3       1.1602651437647350124E04,9.8427148383839780218E03,
CS   4       1.0765576773720192317E-8/
CS    DATA D/2.2266688044328115691E01,2.3538790178262499861E02,
CS   1       1.5193775994075548050E03,6.4855582982667607550E03,
CS   2       1.8615571640885098091E04,3.4900952721145977266E04,
CS   3       3.8912003286093271411E04,1.9685429676859990727E04/
CD    DATA C/3.9894151208813466764D-1,8.8831497943883759412D00,
CD   1       9.3506656132177855979D01,5.9727027639480026226D02,
CD   2       2.4945375852903726711D03,6.8481904505362823326D03,
CD   3       1.1602651437647350124D04,9.8427148383839780218D03,
CD   4       1.0765576773720192317D-8/
CD    DATA D/2.2266688044328115691D01,2.3538790178262499861D02,
CD   1       1.5193775994075548050D03,6.4855582982667607550D03,
CD   2       1.8615571640885098091D04,3.4900952721145977266D04,
CD   3       3.8912003286093271411D04,1.9685429676859990727D04/
C------------------------------------------------------------------
C  Coefficients for approximation in third interval
C------------------------------------------------------------------
CS    DATA P/2.1589853405795699E-1,1.274011611602473639E-1,
CS   1       2.2235277870649807E-2,1.421619193227893466E-3,
CS   2       2.9112874951168792E-5,2.307344176494017303E-2/
CS    DATA Q/1.28426009614491121E00,4.68238212480865118E-1,
CS   1       6.59881378689285515E-2,3.78239633202758244E-3,
CS   2       7.29751555083966205E-5/
CD    DATA P/2.1589853405795699D-1,1.274011611602473639D-1,
CD   1       2.2235277870649807D-2,1.421619193227893466D-3,
CD   2       2.9112874951168792D-5,2.307344176494017303D-2/
CD    DATA Q/1.28426009614491121D00,4.68238212480865118D-1,
CD   1       6.59881378689285515D-2,3.78239633202758244D-3,
CD   2       7.29751555083966205D-5/
C------------------------------------------------------------------
      X = ARG
      Y = ABS(X)
      IF (Y .LE. THRSH) THEN
C------------------------------------------------------------------
C  Evaluate  anorm  for  |X| <= 0.66291
C------------------------------------------------------------------
            XSQ = ZERO
            IF (Y .GT. EPS) XSQ = X * X
            XNUM = A(5)*XSQ
            XDEN = XSQ
            DO 20 I = 1, 3
               XNUM = (XNUM + A(I)) * XSQ
               XDEN = (XDEN + B(I)) * XSQ
   20       CONTINUE
            RESULT = X * (XNUM + A(4)) / (XDEN + B(4))
            RESULT = HALF + RESULT
C------------------------------------------------------------------
C  Evaluate  anorm  for 0.66291 <= |X| <= sqrt(32)
C------------------------------------------------------------------
         ELSE IF (Y .LE. ROOT32) THEN
            XNUM = C(9)*Y
            XDEN = Y
            DO 120 I = 1, 7
               XNUM = (XNUM + C(I)) * Y
               XDEN = (XDEN + D(I)) * Y
  120       CONTINUE
            RESULT = (XNUM + C(8)) / (XDEN + D(8)) 
            XSQ = AINT(Y*SIXTEN)/SIXTEN
            DEL = (Y-XSQ)*(Y+XSQ)
            RESULT = EXP(-XSQ*XSQ*HALF)*EXP(-DEL*HALF)*RESULT
            IF (X .GT. ZERO) RESULT = ONE - RESULT
C------------------------------------------------------------------
C  Evaluate  anorm  for |X| > sqrt(32)
C------------------------------------------------------------------
         ELSE
            RESULT = ZERO
            IF ((X .GE. XLOW) .AND. (X .LT. XUPPR)) THEN
               XSQ = ONE / (X * X)
               XNUM = P(6)*XSQ
               XDEN = XSQ
               DO 240 I = 1, 4
                  XNUM = (XNUM + P(I)) * XSQ
                  XDEN = (XDEN + Q(I)) * XSQ
  240          CONTINUE
               RESULT = XSQ *(XNUM + P(5)) / (XDEN + Q(5))
               RESULT = (SQRPI -  RESULT) / Y
               XSQ = AINT(X*SIXTEN)/SIXTEN
               DEL = (X-XSQ)*(X+XSQ)
               RESULT = EXP(-XSQ*XSQ*HALF)*EXP(-DEL*HALF)*RESULT
            END IF
            IF (X .GT. ZERO) RESULT = ONE - RESULT
      END IF
C------------------------------------------------------------------
C  Fix up for negative argument, erf, etc.
C------------------------------------------------------------------
      ANORM = RESULT
C---------- Last card of ANORM ----------
      END
      PROGRAM ANRTST
C------------------------------------------------------------------
C FORTRAN 77 program to test ANORM, the normal probability integral.
C
C  Method:
C
C     Accuracy test compares function values against local Taylor's
C     series expansions.  Derivatives for anorm(x) are expressed as
C     repeated integrals of erfc(-x/sqrt(2)).  These are generated
C     from the recurrence relation using a technique due to Gautschi
C     (see references).
C
C  Data required
C
C     None
C
C  Subprograms required from this package
C
C     MACHAR - An environmental inquiry program providing
C              information on the floating-point arithmetic
C              system.  Note that the call to MACHAR can
C              be deleted provided the following five
C              parameters are assigned the values indicated
C
C              IBETA  - The radix of the floating-point system
C              IT     - The number of base-ibeta digits in the
C                       significant of a floating-point number
C              EPS    - The smallest positive floating-point
C                       number such that 1.0+EPS .NE. 1.0
C              XMIN   - The smallest non-vanishing floating-point
C                       integral power of the radix
C              XMAX   - The largest finite floating-point number
C
C     REN(K) - A function subprogram returning random real
C              numbers uniformly distributed over (0,1)
C
C
C  Intrinsic functions required are:
C
C      ABS, DBLE, LOG, MAX, REAL, SQRT
C
C  References: "Performance evaluation of programs for the error
C               and complementary error functions", W. J. Cody,
C               TOMS 16, 1990, pp. 29-37.
C
C              "Evaluation of the repeated integrals of the coerror
C               function", W. Gautschi, TOMS 3, 1977, pp. 240-252.
C
C  Latest modification: March 15, 1992
C
C  Author: W. J. Cody
C          Mathematics and Computer Science Division 
C          Argonne National Laboratory
C          Argonne, IL 60439
C
C------------------------------------------------------------------
      INTEGER I,IBETA,IEXP,IOUT,IRND,IT,J,JT,K,K1,K2,K3,
     1        MACHEP,MAXEXP,MINEXP,N,NEGEP,NGRD,N0,N1
CS    REAL  ANORM,
CD    DOUBLE PRECISION ANORM,
     1    A,AIT,ALBETA,B,BETA,C,CONV,C1,C2,DEL,EPS,EPSCON,EPSNEG,FF,
     2    F0,HALF,ONE,R,REN,ROOT32,R1,R6,R7,SC,SIXTEN,SQRTWO,THRESH,
     3    TEN,TWO,U,V,W,X,XBIG,XC,XL,XMAX,XMIN,XN,XN1,X99,Y,Z,ZERO
      DIMENSION R1(500)
C------------------------------------------------------------------
C   C1 = 1/sqrt(pi)
C------------------------------------------------------------------
CS    DATA HALF,ZERO,ONE,TWO,TEN/0.5E0,0.0E0,1.0E0,2.0E0,10.0E0/,
CS   1     SIXTEN,THRESH,X99/16.0E0,0.66291E0,-999.0E0/,
CS   2     C1/5.6418958354775628695E-1/,ROOT32/-5.65685E0/,
CS   3     SQRTWO/7.0710678118654752440E-1/
CD    DATA HALF,ZERO,ONE,TWO,TEN/0.5D0,0.0D0,1.0D0,2.0D0,10.0D0/,
CD   1     SIXTEN,THRESH,X99/16.0D0,0.66291D0,-999.0D0/,
CD   2     C1/5.6418958354775628695D-1/,ROOT32/-5.65685D0/,
CD   3     SQRTWO/7.0710678118654752440D-1/
      DATA IOUT/6/
C------------------------------------------------------------------
C  Statement functions for conversion 
C------------------------------------------------------------------
CS    CONV(I) = REAL(I)
CD    CONV(I) = DBLE(I)
C------------------------------------------------------------------
C  Determine machine parameters and set constants
C------------------------------------------------------------------
      CALL MACHAR(IBETA,IT,IRND,NGRD,MACHEP,NEGEP,IEXP,MINEXP,
     1            MAXEXP,EPS,EPSNEG,XMIN,XMAX)
      BETA = CONV(IBETA)
      ALBETA = LOG(BETA)
      AIT = CONV(IT)
      C = ABS(AIT*ALBETA) + TEN
      A = -THRESH
      B = THRESH
      N = 2000
      XN = CONV(N)
      JT = 0
      N0 = (IBETA/2)*(IT+5)/6+4
C-----------------------------------------------------------------
C  Determine largest argument for ANORM test by Newton iteration
C-----------------------------------------------------------------
      C2 = LOG(XMIN/C1/SQRTWO)
      XBIG = SQRT(-C2)
   50 X = XBIG
         F0 = X*X
         FF = F0 *HALF + ONE/F0 + LOG(X) + C2
         F0 = X + ONE/X - TWO/(X*F0-X)
         XBIG = X - FF/F0
         IF (ABS(X-XBIG)/X .GT. TEN*EPS) GO TO 50
C-----------------------------------------------------------------
C  Random argument accuracy tests
C-----------------------------------------------------------------
      DO 300 J = 1, 3
         K1 = 0
         K3 = 0
         XC = ZERO
         R6 = ZERO
         R7 = ZERO
         DEL = (B - A) / XN
         XL = A
         DO 200 I = 1, N
            X = DEL * REN(JT) + XL
            IF (J .EQ. 1) THEN
C-----------------------------------------------------------------
C  Test anorm against double series expansion
C-----------------------------------------------------------------
                  F0 = CONV(N0)
                  FF = F0+F0+ONE 
                  W = X*X
                  Z = W*HALF
                  U = ZERO
                  V = ZERO
                  DO 60 K = 1, N0
                     U = -Z/F0*(ONE+U)
                     V = W/FF*(ONE+V)
                     F0 = F0 - ONE
                     FF = FF - TWO
   60             CONTINUE
                  V = HALF + SQRTWO*C1*X*(((U*V+(U+V))+HALF)+HALF)
                  U = ANORM(X)
               ELSE
C-----------------------------------------------------------------
C  Test anorm against expansion in repeated
C   integrals of the coerror function.
C-----------------------------------------------------------------
                  Y = X - HALF
                  X = Y + HALF
                  U = ANORM(X)
                  Z = -Y/SQRT(TWO)
                  R = ZERO
                  IF (Z .LE. ONE) THEN
                        N0 = 499
                     ELSE
                        N0 = MIN(499,INT(C/(ABS(LOG(Z)))))
                  END IF
                  N1 = N0 
                  XN1 = CONV(N1+1)
                  DO 100 K=1,N0
                     R = HALF/(Z+XN1*R)
                     R1(N1) = R
                     N1 = N1 - 1
                     XN1 = XN1 - ONE
  100             CONTINUE
                  FF = C1/(Z+R1(1))
                  F0 = ANORM(Y)*EXP((-Y-HALF*HALF)*HALF)
                  SC = F0/FF
C-----------------------------------------------------------------
C  Scale things to avoid premature underflow
C-----------------------------------------------------------------
                  EPSCON = F0 
                  FF = SIXTEN*FF/EPS
                  DO 110 N1=1,N0
                     FF = R1(N1)*FF
                     R1(N1) = FF * SC
                     IF (R1(N1) .LT. EPSCON ) THEN
                        K = N1
                        GO TO 111
                     END IF
  110             CONTINUE
  111             V = SQRTWO*R1(K)
                  DO 120 N1 = 1, K-1
                     V = (V + R1(K-N1))*SQRTWO
  120             CONTINUE
C-----------------------------------------------------------------
C  Remove scaling here
C-----------------------------------------------------------------
                  V = V*EPS/SIXTEN + F0
            END IF
C--------------------------------------------------------------------
C  Accumulate results
C--------------------------------------------------------------------
            W = (U - V) / U
            IF (W .GT. ZERO) THEN
                  K1 = K1 + 1
               ELSE IF (W .LT. ZERO) THEN
                  K3 = K3 + 1
            END IF
            W = ABS(W)
            IF (W .GT. R6) THEN
                  R6 = W
                  XC = X
            END IF
            R7 = R7 + W * W
            XL = XL + DEL
  200    CONTINUE
C------------------------------------------------------------------
C  Gather and print statistics for test
C------------------------------------------------------------------
         K2 = N - K3 - K1
         R7 = SQRT(R7/XN)
         IF (J .EQ. 1) THEN
               WRITE (IOUT,1000)
            ELSE 
               WRITE (IOUT,1001)
         END IF
         WRITE (IOUT,1010) N,A,B
         WRITE (IOUT,1011) K1
         WRITE (IOUT,1015) K2,K3
         WRITE (IOUT,1020) IT,IBETA
         IF (R6 .NE. ZERO) THEN
               W = LOG(ABS(R6))/ALBETA
            ELSE
               W = X99
         END IF
         WRITE (IOUT,1021) R6,IBETA,W,XC
         W = MAX(AIT+W,ZERO)
         WRITE (IOUT,1022) IBETA,W
         IF (R7 .NE. ZERO) THEN
               W = LOG(ABS(R7))/ALBETA
            ELSE
               W = X99
         END IF
         WRITE (IOUT,1023) R7,IBETA,W
         W = MAX(AIT+W,ZERO)
         WRITE (IOUT,1022) IBETA,W
C------------------------------------------------------------------
C  Initialize for next test
C------------------------------------------------------------------
         IF (J .EQ. 1) THEN
               B = A
               A = ROOT32
            ELSE
               B = A
               A = -AINT(XBIG*SIXTEN)/SIXTEN+HALF
         END IF
  300 CONTINUE
C-----------------------------------------------------------------
C  Special tests
C  First check values for positive arguments.
C-----------------------------------------------------------------
      WRITE (IOUT,1025)
      WRITE (IOUT,1030)
      DEL = TEN
      DO 350 I = 1, 10
         X = REN(JT) * DEL
         U = ANORM(-X)
         A = U + ANORM(X)
         Y = (A - HALF) - HALF
         WRITE (IOUT,1032) X, U, Y
  350 CONTINUE
C-----------------------------------------------------------------
C  Test with special arguments
C-----------------------------------------------------------------
      WRITE (IOUT,1040)
      Z = XMAX
      Y = ANORM(Z)
      WRITE (IOUT,1041) Z,Y
      Z = ZERO
      Y = ANORM(Z)
      WRITE (IOUT,1041) Z,Y
      Z = -XMAX
      Y = ANORM(Z)
      WRITE (IOUT,1041) Z,Y
C-----------------------------------------------------------------
C  Test of error returns
C-----------------------------------------------------------------
      WRITE (IOUT,1050)
      W = XBIG
      Z = -W*(ONE-HALF*HALF)
      WRITE (IOUT,1052) Z
      Y = ANORM(Z)
      WRITE (IOUT,1062) Y
      Z = -W*(ONE+TEN*EPS)
      WRITE (IOUT,1053) Z
      Y = ANORM(Z)
      WRITE (IOUT,1062) Y
      WRITE (IOUT,1100)
      STOP
C-----------------------------------------------------------------
 1000 FORMAT('1Test of anorm(x) vs double series expansion'//)
 1001 FORMAT(///' Test of anorm(x) vs Taylor series about x-1/2'//)
 1010 FORMAT(I7,' Random arguments were tested from the interval (',
     1    F7.3,',',F7.3,')'//)
 1011 FORMAT('  ANORM(X) was larger',I6,' times,')
 1015 FORMAT(14X,' agreed',I6,' times, and'/
     1    10X,'was smaller',I6,' times.'//)
 1020 FORMAT(' There are',I4,' base',I4,
     1    ' significant digits in a floating-point number'//)
 1021 FORMAT(' The maximum relative error of',E15.4,' = ',I4,' **',
     1    F7.2/4X,'occurred for X =',E13.6)
 1022 FORMAT(' The estimated loss of base',I4,
     1    ' significant digits is',F7.2//)
 1023 FORMAT(' The root mean square relative error was',E15.4,
     1    ' = ',I4,' **',F7.2)
 1025 FORMAT('1Special Tests'//)
 1030 FORMAT(7X,'Check of identity anorm(X) + anorm(-X) = 1.0'//
     1       9X,'X',12X,'ANORM(-x)',3X,'ANORM(x)+ANORM(-x)-1'/)
 1032 FORMAT(3(3X,E13.6)/)
 1040 FORMAT(//' Test of special arguments'//)
 1041 FORMAT(' ANORM (',E13.6,') = ',E13.6//)
 1050 FORMAT(' Test of Error Returns'///)
 1052 FORMAT(' ANORM will be called with the argument ',E13.6,/
     1    ' The result should not underflow'//)
 1053 FORMAT(' ANORM will be called with the argument ',E13.6,/
     1    ' The result may underflow'//)
 1062 FORMAT(' ANORM returned the value',E13.6///)
 1100 FORMAT(' This concludes the tests')
C---------- Last line of ANORM test program ----------
      END
CS    REAL FUNCTION ALGAMA(X)
CD    DOUBLE PRECISION FUNCTION DLGAMA(X)
C----------------------------------------------------------------------
C
C This routine calculates the LOG(GAMMA) function for a positive real
C   argument X.  Computation is based on an algorithm outlined in
C   references 1 and 2.  The program uses rational functions that
C   theoretically approximate LOG(GAMMA) to at least 18 significant
C   decimal digits.  The approximation for X > 12 is from reference
C   3, while approximations for X < 12.0 are similar to those in
C   reference 1, but are unpublished.  The accuracy achieved depends
C   on the arithmetic system, the compiler, the intrinsic functions,
C   and proper selection of the machine-dependent constants.
C
C
C*********************************************************************
C*********************************************************************
C
C Explanation of machine-dependent constants.  Let
C
C beta   - radix for the floating-point representation
C maxexp - the smallest positive power of beta that overflows
C XBIG   - largest argument for which LN(GAMMA(X)) is representable
C          in the machine, i.e., the solution to the equation
C                  LN(GAMMA(XBIG)) = beta**maxexp
C
C Then the following machine-dependent constants must be declared 
C   in DATA statements.  IEEE values are provided as a default.
C
C XINF   - largest machine representable floating-point number;
C          approximately beta**maxexp.
C EPS    - The smallest positive floating-point number such that
C          1.0+EPS .GT. 1.0
C FRTBIG - Rough estimate of the fourth root of XBIG
C
C
C     Approximate values for some important machines are:
C
C                           beta      maxexp         XBIG
C
C CRAY-1        (S.P.)        2        8191       9.62E+2461
C Cyber 180/855
C   under NOS   (S.P.)        2        1070       1.72E+319
C IEEE (IBM/XT,
C   SUN, etc.)  (S.P.)        2         128       4.08E+36
C IEEE (IBM/XT,
C   SUN, etc.)  (D.P.)        2        1024       2.55D+305
C IBM 3033      (D.P.)       16          63       4.29D+73
C VAX D-Format  (D.P.)        2         127       2.05D+36
C VAX G-Format  (D.P.)        2        1023       1.28D+305
C
C
C                           XINF        EPS        FRTBIG
C
C CRAY-1        (S.P.)   5.45E+2465   7.11E-15    3.13E+615
C Cyber 180/855
C   under NOS   (S.P.)   1.26E+322    3.55E-15    6.44E+79
C IEEE (IBM/XT,
C   SUN, etc.)  (S.P.)   3.40E+38     1.19E-7     1.42E+9
C IEEE (IBM/XT,
C   SUN, etc.)  (D.P.)   1.79D+308    2.22D-16    2.25D+76
C IBM 3033      (D.P.)   7.23D+75     2.22D-16    2.56D+18
C VAX D-Format  (D.P.)   1.70D+38     1.39D-17    1.20D+9
C VAX G-Format  (D.P.)   8.98D+307    1.11D-16    1.89D+76
C
C**************************************************************
C**************************************************************
C
C Error returns
C
C  The program returns the value XINF for X .LE. 0.0 or when
C     overflow would occur.  The computation is believed to 
C     be free of underflow and overflow.
C
C
C Intrinsic functions required are:
C
C      LOG
C
C
C References:
C
C  1) W. J. Cody and K. E. Hillstrom, 'Chebyshev Approximations for
C     the Natural Logarithm of the Gamma Function,' Math. Comp. 21,
C     1967, pp. 198-203.
C
C  2) K. E. Hillstrom, ANL/AMD Program ANLC366S, DGAMMA/DLGAMA, May,
C     1969.
C 
C  3) Hart, Et. Al., Computer Approximations, Wiley and sons, New
C     York, 1968.
C
C
C  Authors: W. J. Cody and L. Stoltz
C           Argonne National Laboratory
C
C  Latest modification: March 9, 1992
C
C----------------------------------------------------------------------
      INTEGER I
CS    REAL      
CD    DOUBLE PRECISION
     1    C,CORR,D1,D2,D4,EPS,FRTBIG,FOUR,HALF,ONE,PNT68,P1,P2,P4,
     2    Q1,Q2,Q4,RES,SQRTPI,THRHAL,TWELVE,TWO,X,XBIG,XDEN,XINF,
     3    XM1,XM2,XM4,XNUM,Y,YSQ,ZERO
      DIMENSION C(7),P1(8),P2(8),P4(8),Q1(8),Q2(8),Q4(8)
C----------------------------------------------------------------------
C  Mathematical constants
C----------------------------------------------------------------------
CS    DATA ONE,HALF,TWELVE,ZERO/1.0E0,0.5E0,12.0E0,0.0E0/,
CS   1     FOUR,THRHAL,TWO,PNT68/4.0E0,1.5E0,2.0E0,0.6796875E0/,
CS   2     SQRTPI/0.9189385332046727417803297E0/
CD    DATA ONE,HALF,TWELVE,ZERO/1.0D0,0.5D0,12.0D0,0.0D0/,
CD   1     FOUR,THRHAL,TWO,PNT68/4.0D0,1.5D0,2.0D0,0.6796875D0/,
CD   2     SQRTPI/0.9189385332046727417803297D0/
C----------------------------------------------------------------------
C  Machine dependent parameters
C----------------------------------------------------------------------
CS    DATA XBIG,XINF,EPS,FRTBIG/4.08E36,3.401E38,1.19E-7,1.42E9/
CD    DATA XBIG,XINF,EPS,FRTBIG/2.55D305,1.79D308,2.22D-16,2.25D76/
C----------------------------------------------------------------------
C  Numerator and denominator coefficients for rational minimax
C     approximation over (0.5,1.5).
C----------------------------------------------------------------------
CS    DATA D1/-5.772156649015328605195174E-1/
CS    DATA P1/4.945235359296727046734888E0,2.018112620856775083915565E2,
CS   1        2.290838373831346393026739E3,1.131967205903380828685045E4,
CS   2        2.855724635671635335736389E4,3.848496228443793359990269E4,
CS   3        2.637748787624195437963534E4,7.225813979700288197698961E3/
CS    DATA Q1/6.748212550303777196073036E1,1.113332393857199323513008E3,
CS   1        7.738757056935398733233834E3,2.763987074403340708898585E4,
CS   2        5.499310206226157329794414E4,6.161122180066002127833352E4,
CS   3        3.635127591501940507276287E4,8.785536302431013170870835E3/
CD    DATA D1/-5.772156649015328605195174D-1/
CD    DATA P1/4.945235359296727046734888D0,2.018112620856775083915565D2,
CD   1        2.290838373831346393026739D3,1.131967205903380828685045D4,
CD   2        2.855724635671635335736389D4,3.848496228443793359990269D4,
CD   3        2.637748787624195437963534D4,7.225813979700288197698961D3/
CD    DATA Q1/6.748212550303777196073036D1,1.113332393857199323513008D3,
CD   1        7.738757056935398733233834D3,2.763987074403340708898585D4,
CD   2        5.499310206226157329794414D4,6.161122180066002127833352D4,
CD   3        3.635127591501940507276287D4,8.785536302431013170870835D3/
C----------------------------------------------------------------------
C  Numerator and denominator coefficients for rational minimax
C     Approximation over (1.5,4.0).
C----------------------------------------------------------------------
CS    DATA D2/4.227843350984671393993777E-1/
CS    DATA P2/4.974607845568932035012064E0,5.424138599891070494101986E2,
CS   1        1.550693864978364947665077E4,1.847932904445632425417223E5,
CS   2        1.088204769468828767498470E6,3.338152967987029735917223E6,
CS   3        5.106661678927352456275255E6,3.074109054850539556250927E6/
CS    DATA Q2/1.830328399370592604055942E2,7.765049321445005871323047E3,
CS   1        1.331903827966074194402448E5,1.136705821321969608938755E6,
CS   2        5.267964117437946917577538E6,1.346701454311101692290052E7,
CS   3        1.782736530353274213975932E7,9.533095591844353613395747E6/
CD    DATA D2/4.227843350984671393993777D-1/
CD    DATA P2/4.974607845568932035012064D0,5.424138599891070494101986D2,
CD   1        1.550693864978364947665077D4,1.847932904445632425417223D5,
CD   2        1.088204769468828767498470D6,3.338152967987029735917223D6,
CD   3        5.106661678927352456275255D6,3.074109054850539556250927D6/
CD    DATA Q2/1.830328399370592604055942D2,7.765049321445005871323047D3,
CD   1        1.331903827966074194402448D5,1.136705821321969608938755D6,
CD   2        5.267964117437946917577538D6,1.346701454311101692290052D7,
CD   3        1.782736530353274213975932D7,9.533095591844353613395747D6/
C----------------------------------------------------------------------
C  Numerator and denominator coefficients for rational minimax
C     Approximation over (4.0,12.0).
C----------------------------------------------------------------------
CS    DATA D4/1.791759469228055000094023E0/
CS    DATA P4/1.474502166059939948905062E4,2.426813369486704502836312E6,
CS   1        1.214755574045093227939592E8,2.663432449630976949898078E9,
CS   2      2.940378956634553899906876E10,1.702665737765398868392998E11,
CS   3      4.926125793377430887588120E11,5.606251856223951465078242E11/
CS    DATA Q4/2.690530175870899333379843E3,6.393885654300092398984238E5,
CS   2        4.135599930241388052042842E7,1.120872109616147941376570E9,
CS   3      1.488613728678813811542398E10,1.016803586272438228077304E11,
CS   4      3.417476345507377132798597E11,4.463158187419713286462081E11/
CD    DATA D4/1.791759469228055000094023D0/
CD    DATA P4/1.474502166059939948905062D4,2.426813369486704502836312D6,
CD   1        1.214755574045093227939592D8,2.663432449630976949898078D9,
CD   2      2.940378956634553899906876D10,1.702665737765398868392998D11,
CD   3      4.926125793377430887588120D11,5.606251856223951465078242D11/
CD    DATA Q4/2.690530175870899333379843D3,6.393885654300092398984238D5,
CD   2        4.135599930241388052042842D7,1.120872109616147941376570D9,
CD   3      1.488613728678813811542398D10,1.016803586272438228077304D11,
CD   4      3.417476345507377132798597D11,4.463158187419713286462081D11/
C----------------------------------------------------------------------
C  Coefficients for minimax approximation over (12, INF).
C----------------------------------------------------------------------
CS    DATA C/-1.910444077728E-03,8.4171387781295E-04,
CS   1     -5.952379913043012E-04,7.93650793500350248E-04,
CS   2     -2.777777777777681622553E-03,8.333333333333333331554247E-02,
CS   3      5.7083835261E-03/
CD    DATA C/-1.910444077728D-03,8.4171387781295D-04,
CD   1     -5.952379913043012D-04,7.93650793500350248D-04,
CD   2     -2.777777777777681622553D-03,8.333333333333333331554247D-02,
CD   3      5.7083835261D-03/
C----------------------------------------------------------------------
      Y = X
      IF ((Y .GT. ZERO) .AND. (Y .LE. XBIG)) THEN
            IF (Y .LE. EPS) THEN
                  RES = -LOG(Y)
               ELSE IF (Y .LE. THRHAL) THEN
C----------------------------------------------------------------------
C  EPS .LT. X .LE. 1.5
C----------------------------------------------------------------------
                  IF (Y .LT. PNT68) THEN
                        CORR = -LOG(Y)
                        XM1 = Y
                     ELSE
                        CORR = ZERO
                        XM1 = (Y - HALF) - HALF
                  END IF
                  IF ((Y .LE. HALF) .OR. (Y .GE. PNT68)) THEN
                        XDEN = ONE
                        XNUM = ZERO
                        DO 140 I = 1, 8
                           XNUM = XNUM*XM1 + P1(I)
                           XDEN = XDEN*XM1 + Q1(I)
  140                   CONTINUE
                        RES = CORR + (XM1 * (D1 + XM1*(XNUM/XDEN)))
                     ELSE
                        XM2 = (Y - HALF) - HALF
                        XDEN = ONE
                        XNUM = ZERO
                        DO 220 I = 1, 8
                           XNUM = XNUM*XM2 + P2(I)
                           XDEN = XDEN*XM2 + Q2(I)
  220                   CONTINUE
                        RES = CORR + XM2 * (D2 + XM2*(XNUM/XDEN))
                  END IF
               ELSE IF (Y .LE. FOUR) THEN
C----------------------------------------------------------------------
C  1.5 .LT. X .LE. 4.0
C----------------------------------------------------------------------
                  XM2 = Y - TWO
                  XDEN = ONE
                  XNUM = ZERO
                  DO 240 I = 1, 8
                     XNUM = XNUM*XM2 + P2(I)
                     XDEN = XDEN*XM2 + Q2(I)
  240             CONTINUE
                  RES = XM2 * (D2 + XM2*(XNUM/XDEN))
               ELSE IF (Y .LE. TWELVE) THEN
C----------------------------------------------------------------------
C  4.0 .LT. X .LE. 12.0
C----------------------------------------------------------------------
                  XM4 = Y - FOUR
                  XDEN = -ONE
                  XNUM = ZERO
                  DO 340 I = 1, 8
                     XNUM = XNUM*XM4 + P4(I)
                     XDEN = XDEN*XM4 + Q4(I)
  340             CONTINUE
                  RES = D4 + XM4*(XNUM/XDEN)
               ELSE 
C----------------------------------------------------------------------
C  Evaluate for argument .GE. 12.0,
C----------------------------------------------------------------------
                  RES = ZERO
                  IF (Y .LE. FRTBIG) THEN
                        RES = C(7)
                        YSQ = Y * Y
                        DO 450 I = 1, 6
                           RES = RES / YSQ + C(I)
  450                   CONTINUE
                  END IF
                  RES = RES/Y
                  CORR = LOG(Y)
                  RES = RES + SQRTPI - HALF*CORR
                  RES = RES + Y*(CORR-ONE)
            END IF
         ELSE
C----------------------------------------------------------------------
C  Return for bad arguments
C----------------------------------------------------------------------
            RES = XINF
      END IF
C----------------------------------------------------------------------
C  Final adjustments and return
C----------------------------------------------------------------------
CS    ALGAMA = RES
CD    DLGAMA = RES
      RETURN
C ---------- Last line of DLGAMA ----------
      END


      PROGRAM ALGTST
C------------------------------------------------------------------
C FORTRAN 77 program to test ALGAMA or DLGAMA
C
C   Method:
C
C      Accuracy tests compare function values against values
C      generated with the duplication formula.
C
C   Data required
C
C      None
C
C   Subprograms required from this package
C
C      MACHAR - An environmental inquiry program providing
C               information on the floating-point arithmetic
C               system.  Note that the call to MACHAR can
C               be deleted provided the following five
C               parameters are assigned the values indicated
C
C               IBETA  - The radix of the floating-point system
C               IT     - The number of base-ibeta digits in the
C                        significant of a floating-point number
C               EPS    - The smallest positive floating-point
C                        number such that 1.0+EPS .NE. 1.0
C               XMIN   - The smallest non-vanishing floating-point
C                        integral power of the radix
C               XMAX   - The largest finite floating-point number
C
C      REN(K) - A function subprogram returning random real
C               numbers uniformly distributed over (0,1)
C
C
C    Intrinsic functions required are:
C
C         ABS, ANINT, DBLE, LOG, MAX, REAL, SQRT
C
C  Reference: "Performance evaluation of programs related
C              to the real gamma function", W. J. Cody, 
C              submitted for publication.
C
C  Latest modification: March 9, 1992
C
C  Authors: W. J. Cody and L. Stoltz
C           Mathematics and Computer Science Division 
C           Argonne National Laboratory
C           Argonne, IL 60439
C
C--------------------------------------------------------------------
      INTEGER I,IBETA,IEXP,IOUT,IRND,IT,J,JT,K1,K2,K3,
     1        MACHEP,MAXEXP,MINEXP,N,NEGEP,NGRD
CS    REAL  ALGAMA,           
CD    DOUBLE PRECISION DLGAMA, 
     1    A,AIT,ALBETA,ALL9,B,BETA,CL,CONV,C1,C2,C3,DEL,EPS,EPSNEG,
     2    FUNC,HALF,ONE,P875,P3125,P625,P6875,REN,R6,R7,SIXTEN,TEN,
     3    TWO,U,V,W,X,XC,XL,XMAX,XMIN,XN,XP99,Y,Z,ZERO,ZZ
C------------------------------------------------------------------
C   C1 = 0.5 - LN(SQRT(PI))
C   C2 = LN(2)
C   C3 = LN(2) - 11/16
C------------------------------------------------------------------
CS    DATA C1,C2/-7.2364942924700087072E-2,6.9314718055994530942E-1/,
CS   1     C3,ZERO,HALF/5.6471805599453094172E-3,0.0E0,0.5E0/,
CS   2     ONE,TWO,TEN,SIXTEN/1.0E0,2.0E0,10.0E0,16.0E0/,
CS   3     P6875,P875,P3125,P625/0.6875E0,0.875E0,1.3125E0,1.625E0/,
CS   4     ALL9,XP99/-999.0E0,0.99E0/
CD    DATA C1,C2/-7.2364942924700087072D-2,6.9314718055994530942D-1/,
CD   1     C3,ZERO,HALF/5.6471805599453094172D-3,0.0D0,0.5D0/,
CD   2     ONE,TWO,TEN,SIXTEN/1.0D0,2.0D0,10.0D0,16.0D0/,
CD   3     P6875,P875,P3125,P625/0.6875D0,0.875D0,1.3125D0,1.625D0/,
CD   4     ALL9,XP99/-999.0D0,0.99D0/
      DATA IOUT/6/
C------------------------------------------------------------------
C  Statement functions for conversion 
C------------------------------------------------------------------
CS    CONV(I) = REAL(I)
CD    CONV(I) = DBLE(I)
CS    FUNC(X) = ALGAMA(X)
CD    FUNC(X) = DLGAMA(X) 
C------------------------------------------------------------------
C  Determine machine parameters and set constants
C------------------------------------------------------------------
      CALL MACHAR(IBETA,IT,IRND,NGRD,MACHEP,NEGEP,IEXP,MINEXP,
     1            MAXEXP,EPS,EPSNEG,XMIN,XMAX)
      BETA = CONV(IBETA)
      ALBETA = LOG(BETA)
      AIT = CONV(IT)
      A = ZERO
      B = P875
      N = 2000
      XN = CONV(N)
      JT = 0
C-----------------------------------------------------------------
C  Determine largest argument for DLGAMA by iteration
C-----------------------------------------------------------------
      CL = XP99 * XMAX
      Z = -CL / ALL9
   80 ZZ = CL / (LOG(Z)-ONE)
      IF (ABS(ZZ/Z-ONE) .GT. (TWO*BETA*EPS)) THEN
         Z = ZZ
         GO TO 80
      END IF
      CL = ZZ
C-----------------------------------------------------------------
C  Random argument accuracy tests
C-----------------------------------------------------------------
      DO 300 J = 1, 3
         K1 = 0
         K3 = 0
         XC = ZERO
         R6 = ZERO
         R7 = ZERO
         DEL = (B - A) / XN
         XL = A
         DO 200 I = 1, N
            X = DEL * REN(JT) + XL
C-----------------------------------------------------------------
C  Use duplication formula
C-----------------------------------------------------------------
            IF (J .NE. 3) THEN
                  IF (J .EQ. 1) THEN
                        Z = X + HALF
                        X = Z - HALF
                        Y = X + X
                     ELSE 
                        X = X + X
                        X = X * HALF
                        Y = (X + X) - ONE
                        Z = X - HALF
                  END IF
                  U = FUNC(X)
                  W = (Y-HALF)-HALF
                  ZZ = ANINT(W*SIXTEN)/SIXTEN
                  W = W - ZZ
                  V = (((HALF-ZZ*P6875) - C1) - W*P6875)-C3*(W+ZZ)
                  V = ((V + FUNC(Y)) - FUNC(Z))
               ELSE
                  Z = X * HALF + HALF
                  Y = Z - HALF
                  X = Y + Y
                  U = FUNC(X)
                  V = (C1 + ((X-HALF)-HALF)*C2)+FUNC(Y)+FUNC(Z)-HALF
            END IF
C--------------------------------------------------------------------
C  Accumulate results
C--------------------------------------------------------------------
            W = (U - V) / U
            IF (W .GT. ZERO) THEN
                  K1 = K1 + 1
               ELSE IF (W .LT. ZERO) THEN
                  K3 = K3 + 1
            END IF
            W = ABS(W)
            IF (W .GT. R6) THEN
                  R6 = W
                  XC = X
            END IF
            R7 = R7 + W * W
            XL = XL + DEL
  200    CONTINUE
C------------------------------------------------------------------
C  Gather and print statistics for test
C------------------------------------------------------------------
         K2 = N - K3 - K1
         R7 = SQRT(R7/XN)
         IF (J .EQ. 1) THEN
               WRITE (IOUT,1000)
            ELSE IF (J .EQ. 2) THEN
               WRITE (IOUT,1001)
            ELSE
               WRITE (IOUT,1002)
         END IF
         WRITE (IOUT,1010) N,A,B
         WRITE (IOUT,1011) K1,K2,K3
         WRITE (IOUT,1020) IT,IBETA
         IF (R6 .NE. ZERO) THEN
               W = LOG(ABS(R6))/ALBETA
            ELSE
               W = ALL9
         END IF
         WRITE (IOUT,1021) R6,IBETA,W,XC
         W = MAX(AIT+W,ZERO)
         WRITE (IOUT,1022) IBETA,W
         IF (R7 .NE. ZERO) THEN
               W = LOG(ABS(R7))/ALBETA
            ELSE
               W = ALL9
         END IF
         WRITE (IOUT,1023) R7,IBETA,W
         W = MAX(AIT+W,ZERO)
         WRITE (IOUT,1022) IBETA,W
C------------------------------------------------------------------
C  Initialize for next test
C------------------------------------------------------------------
         A = P3125
         B = P625
         IF (J .EQ. 2) THEN
               A = TWO + TWO
               B = TEN + TEN
         END IF
  300 CONTINUE
C-----------------------------------------------------------------
C  Special tests
C  First test with special arguments
C-----------------------------------------------------------------
      WRITE (IOUT,1025)
      WRITE (IOUT,1040)
      Z = EPS
      ZZ = FUNC(Z)
      WRITE (IOUT,1041) Z,ZZ
      Z = HALF
      ZZ = FUNC(Z)
      WRITE (IOUT,1041) Z,ZZ
      Z = ONE
      ZZ = FUNC(Z)
      WRITE (IOUT,1041) Z,ZZ
      Z = TWO
      ZZ = FUNC(Z)
      WRITE (IOUT,1041) Z,ZZ
C-----------------------------------------------------------------
C  Test of error returns
C-----------------------------------------------------------------
      WRITE (IOUT,1050)
      Z = XMIN
      WRITE (IOUT,1053) Z
      ZZ = FUNC(Z)
      WRITE (IOUT,1061) ZZ
      Z = CL
      WRITE (IOUT,1053) Z
      ZZ = FUNC(Z)
      WRITE (IOUT,1061) ZZ
      Z = -ONE
      WRITE (IOUT,1052) Z
      ZZ = FUNC(Z)
      WRITE (IOUT,1061) ZZ
      Z = ZERO
      WRITE (IOUT,1052) Z
      ZZ = FUNC(Z)
      WRITE (IOUT,1061) ZZ
      Z = XP99 * XMAX
      WRITE (IOUT,1052) Z
      ZZ = FUNC(Z)
      WRITE (IOUT,1061) ZZ
      WRITE (IOUT,1100)
      STOP
C-----------------------------------------------------------------
 1000 FORMAT('1Test of LGAMA(X) vs LN(2*SQRT(PI))-2X*LN(2)+',
     1    'LGAMA(2X)-LGAMA(X+1/2)'//)
 1001 FORMAT('1Test of LGAMA(X) vs LN(2*SQRT(PI))-(2X-1)*LN(2)+',
     1    'LGAMA(X-1/2)-LGAMA(2X-1)'//)
 1002 FORMAT('1Test of LGAMA(X) vs -LN(2*SQRT(PI))+X*LN(2)+',
     1    'LGAMA(X/2)+LGAMA(X/2+1/2)'//)
 1010 FORMAT(I7,' Random arguments were tested from the interval (',
     1    F5.1,',',F5.1,')'//)
 1011 FORMAT('  LGAMA(X) was larger',I6,' times,'/
     1    14X,' agreed',I6,' times, and'/
     2    10X,'was smaller',I6,' times.'//)
 1020 FORMAT(' There are',I4,' base',I4,
     1    ' significant digits in a floating-point number'//)
 1021 FORMAT(' The maximum relative error of',E15.4,' = ',I4,' **',
     1    F7.2/4X,'occurred for X =',E13.6)
 1022 FORMAT(' The estimated loss of base',I4,
     1    ' significant digits is',F7.2//)
 1023 FORMAT(' The root mean square relative error was',E15.4,
     1    ' = ',I4,' **',F7.2)
 1025 FORMAT('1Special Tests'//)
 1040 FORMAT(//' Test of special arguments'//)
 1041 FORMAT(' LGAMA (',E13.6,') = ',E13.6//)
 1050 FORMAT('1Test of Error Returns'///)
 1052 FORMAT(' LGAMA will be called with the argument',E13.6,/
     1    ' This should trigger an error message'//)
 1053 FORMAT(' LGAMA will be called with the argument',E13.6,/
     1    ' This should not trigger an error message'//)
 1061 FORMAT(' LGAMA returned the value',E13.6///)
 1100 FORMAT(' This concludes the tests')
C---------- Last line of ALGAMA/DLGAMA test program ----------
      END
CS    REAL FUNCTION DAW(XX)
CD    DOUBLE PRECISION FUNCTION DAW(XX)
C----------------------------------------------------------------------
C
C This function program evaluates Dawson's integral, 
C
C                       2  / x   2
C                     -x   |    t
C             F(x) = e     |   e    dt
C                          |
C                          / 0
C
C   for a real argument x.
C
C   The calling sequence for this function is 
C
C                   Y=DAW(X)
C
C   The main computation uses rational Chebyshev approximations
C   published in Math. Comp. 24, 171-178 (1970) by Cody, Paciorek
C   and Thacher.  This transportable program is patterned after the
C   machine-dependent FUNPACK program DDAW(X), but cannot match that
C   version for efficiency or accuracy.  This version uses rational
C   approximations that are theoretically accurate to about 19
C   significant decimal digits.  The accuracy achieved depends on the
C   arithmetic system, the compiler, the intrinsic functions, and
C   proper selection of the machine-dependent constants.
C
C*******************************************************************
C*******************************************************************
C
C Explanation of machine-dependent constants.  Let
C
C   XINF   = largest positive machine number
C   XMIN   = the smallest positive machine number.
C   EPS    = smallest positive number such that 1+eps > 1.
C            Approximately  beta**(-p), where beta is the machine
C            radix and p is the number of significant base-beta
C            digits in a floating-point number.
C
C Then the following machine-dependent constants must be declared 
C   in DATA statements.  IEEE values are provided as a default.
C
C   XMAX   = absolute argument beyond which DAW(X) underflows.
C            XMAX = min(0.5/xmin, xinf).
C   XSMALL = absolute argument below DAW(X)  may be represented
C            by X.  We recommend XSMALL = sqrt(eps).
C   XLARGE = argument beyond which DAW(X) may be represented by
C            1/(2x).  We recommend XLARGE = 1/sqrt(eps).
C
C     Approximate values for some important machines are
C
C                        beta  p     eps     xmin       xinf  
C
C  CDC 7600      (S.P.)    2  48  7.11E-15  3.14E-294  1.26E+322
C  CRAY-1        (S.P.)    2  48  7.11E-15  4.58E-2467 5.45E+2465
C  IEEE (IBM/XT,
C    SUN, etc.)  (S.P.)    2  24  1.19E-07  1.18E-38   3.40E+38
C  IEEE (IBM/XT,
C    SUN, etc.)  (D.P.)    2  53  1.11D-16  2.23E-308  1.79D+308
C  IBM 3033      (D.P.)   16  14  1.11D-16  5.40D-79   7.23D+75
C  VAX 11/780    (S.P.)    2  24  5.96E-08  2.94E-39   1.70E+38
C                (D.P.)    2  56  1.39D-17  2.94D-39   1.70D+38
C   (G Format)   (D.P.)    2  53  1.11D-16  5.57D-309  8.98D+307
C
C                         XSMALL     XLARGE     XMAX    
C
C  CDC 7600      (S.P.)  5.96E-08   1.68E+07  1.59E+293
C  CRAY-1        (S.P.)  5.96E-08   1.68E+07  5.65E+2465
C  IEEE (IBM/XT,
C    SUN, etc.)  (S.P.)  2.44E-04   4.10E+03  4.25E+37
C  IEEE (IBM/XT,
C    SUN, etc.)  (D.P.)  1.05E-08   9.49E+07  2.24E+307
C  IBM 3033      (D.P.)  3.73D-09   2.68E+08  7.23E+75
C  VAX 11/780    (S.P.)  2.44E-04   4.10E+03  1.70E+38
C                (D.P.)  3.73E-09   2.68E+08  1.70E+38
C   (G Format)   (D.P.)  1.05E-08   9.49E+07  8.98E+307
C
C*******************************************************************
C*******************************************************************
C
C Error Returns
C
C  The program returns 0.0 for |X| > XMAX.
C
C Intrinsic functions required are:
C
C     ABS
C
C
C  Author: W. J. Cody
C          Mathematics and Computer Science Division 
C          Argonne National Laboratory
C          Argonne, IL 60439
C
C  Latest modification: March 9, 1992
C
C----------------------------------------------------------------------
      INTEGER I
CS    REAL
CD    DOUBLE PRECISION
     1     FRAC,HALF,ONE,ONE225,P1,P2,P3,P4,Q1,Q2,Q3,Q4,SIX25,
     2     SUMP,SUMQ,TWO5,W2,X,XX,Y,XLARGE,XMAX,XSMALL,ZERO
      DIMENSION P1(10),P2(10),P3(10),P4(10),Q1(10),Q2(9),Q3(9),Q4(9)
C----------------------------------------------------------------------
C  Mathematical constants.
C----------------------------------------------------------------------
CS    DATA ZERO,HALF,ONE/0.0E0,0.5E0,1.0E0/,
CS   1     SIX25,ONE225,TWO5/6.25E0,12.25E0,25.0E0/
CD    DATA ZERO,HALF,ONE/0.0D0,0.5D0,1.0D0/,
CD   1     SIX25,ONE225,TWO5/6.25D0,12.25D0,25.0D0/
C----------------------------------------------------------------------
C  Machine-dependent constants
C----------------------------------------------------------------------
CS    DATA XSMALL/2.44E-04/, XLARGE/4.10E+03/, XMAX/4.25E+37/
CD    DATA XSMALL/1.05D-08/, XLARGE/9.49D+07/, XMAX/2.24D+307/
C----------------------------------------------------------------------
C  Coefficients for R(9,9) approximation for  |x| < 2.5
C----------------------------------------------------------------------
CS    DATA P1/-2.69020398788704782410E-12, 4.18572065374337710778E-10,
CS   1        -1.34848304455939419963E-08, 9.28264872583444852976E-07,
CS   2        -1.23877783329049120592E-05, 4.07205792429155826266E-04,
CS   3        -2.84388121441008500446E-03, 4.70139022887204722217E-02,
CS   4        -1.38868086253931995101E-01, 1.00000000000000000004E+00/
CS    DATA Q1/ 1.71257170854690554214E-10, 1.19266846372297253797E-08,
CS   1         4.32287827678631772231E-07, 1.03867633767414421898E-05,
CS   2         1.78910965284246249340E-04, 2.26061077235076703171E-03,
CS   3         2.07422774641447644725E-02, 1.32212955897210128811E-01,
CS   4         5.27798580412734677256E-01, 1.00000000000000000000E+00/
CD    DATA P1/-2.69020398788704782410D-12, 4.18572065374337710778D-10,
CD   1        -1.34848304455939419963D-08, 9.28264872583444852976D-07,
CD   2        -1.23877783329049120592D-05, 4.07205792429155826266D-04,
CD   3        -2.84388121441008500446D-03, 4.70139022887204722217D-02,
CD   4        -1.38868086253931995101D-01, 1.00000000000000000004D+00/
CD    DATA Q1/ 1.71257170854690554214D-10, 1.19266846372297253797D-08,
CD   1         4.32287827678631772231D-07, 1.03867633767414421898D-05,
CD   2         1.78910965284246249340D-04, 2.26061077235076703171D-03,
CD   3         2.07422774641447644725D-02, 1.32212955897210128811D-01,
CD   4         5.27798580412734677256D-01, 1.00000000000000000000D+00/
C----------------------------------------------------------------------
C  Coefficients for R(9,9) approximation in J-fraction form
C     for  x in [2.5, 3.5)
C----------------------------------------------------------------------
CS    DATA P2/-1.70953804700855494930E+00,-3.79258977271042880786E+01,
CS   1         2.61935631268825992835E+01, 1.25808703738951251885E+01,
CS   2        -2.27571829525075891337E+01, 4.56604250725163310122E+00,
CS   3        -7.33080089896402870750E+00, 4.65842087940015295573E+01,
CS   4        -1.73717177843672791149E+01, 5.00260183622027967838E-01/
CS    DATA Q2/ 1.82180093313514478378E+00, 1.10067081034515532891E+03,
CS   1        -7.08465686676573000364E+00, 4.53642111102577727153E+02,
CS   2         4.06209742218935689922E+01, 3.02890110610122663923E+02,
CS   3         1.70641269745236227356E+02, 9.51190923960381458747E+02,
CS   4         2.06522691539642105009E-01/
CD    DATA P2/-1.70953804700855494930D+00,-3.79258977271042880786D+01,
CD   1         2.61935631268825992835D+01, 1.25808703738951251885D+01,
CD   2        -2.27571829525075891337D+01, 4.56604250725163310122D+00,
CD   3        -7.33080089896402870750D+00, 4.65842087940015295573D+01,
CD   4        -1.73717177843672791149D+01, 5.00260183622027967838D-01/
CD    DATA Q2/ 1.82180093313514478378D+00, 1.10067081034515532891D+03,
CD   1        -7.08465686676573000364D+00, 4.53642111102577727153D+02,
CD   2         4.06209742218935689922D+01, 3.02890110610122663923D+02,
CD   3         1.70641269745236227356D+02, 9.51190923960381458747D+02,
CD   4         2.06522691539642105009D-01/
C----------------------------------------------------------------------
C  Coefficients for R(9,9) approximation in J-fraction form
C     for  x in [3.5, 5.0]
C----------------------------------------------------------------------
CS    DATA P3/-4.55169503255094815112E+00,-1.86647123338493852582E+01,
CS   1        -7.36315669126830526754E+00,-6.68407240337696756838E+01,
CS   2         4.84507265081491452130E+01, 2.69790586735467649969E+01,
CS   3        -3.35044149820592449072E+01, 7.50964459838919612289E+00,
CS   4        -1.48432341823343965307E+00, 4.99999810924858824981E-01/
CS    DATA Q3/ 4.47820908025971749852E+01, 9.98607198039452081913E+01,
CS   1         1.40238373126149385228E+01, 3.48817758822286353588E+03,
CS   2        -9.18871385293215873406E+00, 1.24018500009917163023E+03,
CS   3        -6.88024952504512254535E+01,-2.31251575385145143070E+00,
CS   4         2.50041492369922381761E-01/
CD    DATA P3/-4.55169503255094815112D+00,-1.86647123338493852582D+01,
CD   1        -7.36315669126830526754D+00,-6.68407240337696756838D+01,
CD   2         4.84507265081491452130D+01, 2.69790586735467649969D+01,
CD   3        -3.35044149820592449072D+01, 7.50964459838919612289D+00,
CD   4        -1.48432341823343965307D+00, 4.99999810924858824981D-01/
CD    DATA Q3/ 4.47820908025971749852D+01, 9.98607198039452081913D+01,
CD   1         1.40238373126149385228D+01, 3.48817758822286353588D+03,
CD   2        -9.18871385293215873406D+00, 1.24018500009917163023D+03,
CD   3        -6.88024952504512254535D+01,-2.31251575385145143070D+00,
CD   4         2.50041492369922381761D-01/
C----------------------------------------------------------------------
C  Coefficients for R(9,9) approximation in J-fraction form
C     for  |x| > 5.0
C----------------------------------------------------------------------
CS    DATA P4/-8.11753647558432685797E+00,-3.84043882477454453430E+01,
CS   1        -2.23787669028751886675E+01,-2.88301992467056105854E+01,
CS   2        -5.99085540418222002197E+00,-1.13867365736066102577E+01,
CS   3        -6.52828727526980741590E+00,-4.50002293000355585708E+00,
CS   4        -2.50000000088955834952E+00, 5.00000000000000488400E-01/
CS    DATA Q4/ 2.69382300417238816428E+02, 5.04198958742465752861E+01,
CS   1         6.11539671480115846173E+01, 2.08210246935564547889E+02,
CS   2         1.97325365692316183531E+01,-1.22097010558934838708E+01,
CS   3        -6.99732735041547247161E+00,-2.49999970104184464568E+00,
CS   4         7.49999999999027092188E-01/
CD    DATA P4/-8.11753647558432685797D+00,-3.84043882477454453430D+01,
CD   1        -2.23787669028751886675D+01,-2.88301992467056105854D+01,
CD   2        -5.99085540418222002197D+00,-1.13867365736066102577D+01,
CD   3        -6.52828727526980741590D+00,-4.50002293000355585708D+00,
CD   4        -2.50000000088955834952D+00, 5.00000000000000488400D-01/
CD    DATA Q4/ 2.69382300417238816428D+02, 5.04198958742465752861D+01,
CD   1         6.11539671480115846173D+01, 2.08210246935564547889D+02,
CD   2         1.97325365692316183531D+01,-1.22097010558934838708D+01,
CD   3        -6.99732735041547247161D+00,-2.49999970104184464568D+00,
CD   4         7.49999999999027092188D-01/
C----------------------------------------------------------------------
      X = XX
      IF (ABS(X) .GT. XLARGE) THEN
            IF (ABS(X) .LE. XMAX) THEN
                  DAW = HALF / X
               ELSE
                  DAW = ZERO
            END IF
         ELSE IF (ABS(X) .LT. XSMALL) THEN
            DAW = X
         ELSE
            Y = X * X
            IF (Y .LT. SIX25) THEN
C----------------------------------------------------------------------
C  ABS(X) .LT. 2.5 
C----------------------------------------------------------------------
                  SUMP = P1(1)
                  SUMQ = Q1(1)
                  DO 100 I = 2, 10
                     SUMP = SUMP * Y + P1(I)
                     SUMQ = SUMQ * Y + Q1(I)
  100             CONTINUE
                  DAW = X * SUMP / SUMQ
               ELSE IF (Y .LT. ONE225) THEN
C----------------------------------------------------------------------
C  2.5 .LE. ABS(X) .LT. 3.5 
C----------------------------------------------------------------------
                  FRAC = ZERO
                  DO 200 I = 1, 9
  200                FRAC = Q2(I) / (P2(I) + Y + FRAC)
                  DAW = (P2(10) + FRAC) / X
               ELSE IF (Y .LT. TWO5) THEN
C----------------------------------------------------------------------
C  3.5 .LE. ABS(X) .LT. 5.0 
C---------------------------------------------------------------------
                  FRAC = ZERO
                  DO 300 I = 1, 9
  300                FRAC = Q3(I) / (P3(I) + Y + FRAC)
                  DAW = (P3(10) + FRAC) / X
               ELSE
C----------------------------------------------------------------------
C  5.0 .LE. ABS(X) .LE. XLARGE 
C------------------------------------------------------------------
                  W2 = ONE / X / X
                  FRAC = ZERO
                  DO 400 I = 1, 9
  400                FRAC = Q4(I) / (P4(I) + Y + FRAC)
                  FRAC = P4(10) + FRAC
                  DAW = (HALF + HALF * W2 * FRAC) / X
            END IF
      END IF
      RETURN
C---------- Last line of DAW ----------
      END
      PROGRAM DAWTST
C------------------------------------------------------------------
C FORTRAN 77 program to test DAW
C
C  Method:
C
C     Accuracy test compare function values against a local
C     Taylor's series expansion.  Derivatives are generated
C     from the recurrence relation.
C
C  Data required
C
C     None
C
C  Subprograms required from this package
C
C     MACHAR - An environmental inquiry program providing
C         information on the floating-point arithmetic
C         system.  Note that the call to MACHAR can
C         be deleted provided the following five
C         parameters are assigned the values indicated
C
C              IBETA  - the radix of the floating-point system
C              IT     - the number of base-IBETA digits in the
C                       significant of a floating-point number
C              XMIN   - the smallest positive floating-point number
C              XMAX   - the largest floating-point number
C
C     REN(K) - a function subprogram returning random real
C              numbers uniformly distributed over (0,1)
C
C
C  Intrinsic functions required are:
C
C         ABS, DBLE, LOG, MAX, REAL, SQRT
C
C  Reference: "The use of Taylor series to test accuracy of
C              function programs", W. J. Cody and L. Stoltz,
C              submitted for publication.
C
C  Latest modification: March 9, 1992
C
C  Author: W. J. Cody
C          Mathematics and Computer Science Division
C          Argonne National Laboratory
C          Argonne, IL 60439
C
C------------------------------------------------------------------
      INTEGER I,IBETA,IEXP,II,IOUT,IRND,IT,J,JT,K1,
     1    K2,K3,MACHEP,MAXEXP,MINEXP,N,NDUM,NEGEP,NGRD
CS    REAL  
CD    DOUBLE PRECISION  
     1    A,AIT,ALBETA,B,BETA,CONV,DAW,DEL,DELTA,EPS,EPSNEG,
     2    FORTEN,HALF,ONE,P,REN,R6,R7,SIXTEN,TWO,T1,W,X,
     3    XBIG,XKAY,XL,XMAX,XMIN,XN,X1,X99,Y,Z,ZERO,ZZ
      DIMENSION P(0:14)
C------------------------------------------------------------------
CS    DATA ZERO,HALF,ONE,TWO/0.0E0,0.5E0,1.0E0,2.0E0/, 
CS   1   FORTEN,SIXTEN,X99,DELTA/14.0E0,1.6E1,-999.0E0,6.25E-2/
CD    DATA ZERO,HALF,ONE,TWO/0.0D0,0.5D0,1.0D0,2.0D0/,
CD   1   FORTEN,SIXTEN,X99,DELTA/14.0D0,1.6D1,-999.0D0,6.25D-2/
      DATA IOUT/6/
C------------------------------------------------------------------
C  Define statement functions for conversions
C------------------------------------------------------------------
CS    CONV(NDUM) = REAL(NDUM)
CD    CONV(NDUM) = DBLE(NDUM)
C------------------------------------------------------------------
C  Determine machine parameters and set constants
C------------------------------------------------------------------
      CALL MACHAR(IBETA,IT,IRND,NGRD,MACHEP,NEGEP,IEXP,MINEXP,
     1            MAXEXP,EPS,EPSNEG,XMIN,XMAX)
      BETA = CONV(IBETA)
      AIT = CONV(IT)
      ALBETA = LOG(BETA)
      A = DELTA
      B = ONE
      JT = 0
C-----------------------------------------------------------------
C  Random argument accuracy tests based on local Taylor expansion.
C-----------------------------------------------------------------
      DO 300 J = 1, 4
         N = 2000 
         XN = CONV(N)
         K1 = 0
         K2 = 0
         K3 = 0
         X1 = ZERO
         R6 = ZERO
         R7 = ZERO
         DEL = (B - A) / XN
         XL = A
         DO 200 I = 1, N
            X = DEL * REN(JT) + XL
C------------------------------------------------------------------
C  Purify arguments
C------------------------------------------------------------------
            Y = X - DELTA
            W = SIXTEN * Y
            T1 = W + Y
            Y = T1 - W
            X = Y + DELTA
C------------------------------------------------------------------
C  Use Taylor's Series Expansion
C------------------------------------------------------------------
            P(0) = DAW(Y)
            Z = Y + Y
            P(1) = ONE - Z * P(0)
            XKAY = TWO
            DO 100 II = 2, 14
               P(II) = -(Z*P(II-1)+XKAY*P(II-2))
               XKAY = XKAY + TWO
  100       CONTINUE
            ZZ = P(14)
            XKAY = FORTEN
            DO 110 II = 1, 14
               ZZ = ZZ*DELTA/XKAY + P(14-II)
               XKAY = XKAY - ONE
  110       CONTINUE
            Z = DAW(X)
C------------------------------------------------------------------
C  Accumulate Results
C------------------------------------------------------------------
            W = (Z - ZZ) / Z
            IF (W .GT. ZERO) THEN 
                  K1 = K1 + 1
               ELSE IF (W .LT. ZERO) THEN 
                  K3 = K3 + 1
            END IF
            W = ABS(W)
            IF (W .GT. R6) THEN
                  R6 = W
                  X1 = X
            END IF
            R7 = R7 + W * W
            XL = XL + DEL
  200    CONTINUE
C------------------------------------------------------------------
C  Gather and print statistics for test
C------------------------------------------------------------------
         K2 = N - K1 - K3
         R7 = SQRT(R7/XN)
         WRITE (IOUT,1000)
         WRITE (IOUT,1010) N,A,B
         WRITE (IOUT,1011) K1,K2,K3
         WRITE (IOUT,1020) IT,IBETA
         W = X99
         IF (R6 .NE. ZERO) W = LOG(R6)/ALBETA
         WRITE (IOUT,1021) R6,IBETA,W,X1
         W = MAX(AIT+W,ZERO)
         WRITE (IOUT,1022) IBETA,W
         W = X99
         IF (R7 .NE. ZERO) W = LOG(R7)/ALBETA
         WRITE (IOUT,1023) R7,IBETA,W
         W = MAX(AIT+W,ZERO)
         WRITE (IOUT,1022) IBETA,W
C------------------------------------------------------------------
C  Initialize for next test
C------------------------------------------------------------------
         A = B
         B = B + B
         IF (J .EQ. 1) B = B + HALF
  300 CONTINUE
C-----------------------------------------------------------------
C  Special tests.  First check values for negative arguments.
C-----------------------------------------------------------------
      WRITE (IOUT,1025)
      WRITE (IOUT,1030) IBETA
      DO 350 I = 1, 10
         X = REN(J)*(TWO+TWO)
         B = DAW(X)
         A = B + DAW(-X)
         IF (A*B .NE. ZERO) A = AIT + LOG(ABS(A/B))/ALBETA
         WRITE (IOUT,1031) X,A
         X = X + DEL
  350 CONTINUE
C-----------------------------------------------------------------
C  Next, test with special arguments
C-----------------------------------------------------------------
      WRITE (IOUT,1040)
      Z = XMIN
      ZZ = DAW(Z)
      WRITE (IOUT,1041) ZZ
C-----------------------------------------------------------------
C  Test of error return for arguments > xmax.  First, determine
C    xmax
C-----------------------------------------------------------------
      IF (HALF .LT. XMIN*XMAX ) THEN
            XBIG = HALF/XMIN
         ELSE
            XBIG = XMAX
      END IF
      WRITE (IOUT,1050)
      Z = XBIG*(ONE-DELTA*DELTA)
      WRITE (IOUT,1052) Z
      ZZ = DAW(Z)
      WRITE (IOUT,1062) ZZ
      Z = XBIG
      WRITE (IOUT,1053) Z
      ZZ = DAW(Z)
      WRITE (IOUT,1062) ZZ
      W = ONE + DELTA*DELTA
      IF (W .LT. XMAX/XBIG ) THEN
            Z = XBIG*W
            WRITE (IOUT,1053) Z
            ZZ = DAW(Z)
            WRITE (IOUT,1062) ZZ
      END IF
      WRITE (IOUT,1100)
      STOP
C-----------------------------------------------------------------
 1000 FORMAT('1Test of Dawson''s Integral vs Taylor expansion'//)
 1010 FORMAT(I7,' Random arguments were tested from the interval ',
     1    '(',F5.2,',',F5.2,')'//)
 1011 FORMAT('  F(X) was larger',I6,' times,'/
     1    10X,' agreed',I6,' times, and'/
     1    6X,'was smaller',I6,' times.'//)
 1020 FORMAT(' There are',I4,' base',I4,
     1    ' significant digits in a floating-point number'//)
 1021 FORMAT(' The maximum relative error of',E15.4,' = ',I4,' **',
     1    F7.2/4X,'occurred for X =',E13.6)
 1022 FORMAT(' The estimated loss of base',I4,
     1    ' significant digits is',F7.2//)
 1023 FORMAT(' The root mean square relative error was',E15.4,
     1    ' = ',I4,' **',F7.2)
 1025 FORMAT('1Special Tests'//)
 1030 FORMAT(7X,'Estimated loss of base',i3,' significant digits in'//
     1       8X'X',10X,'F(x)+F(-x)'/)
 1031 FORMAT(3XF7.3,F16.2)
 1040 FORMAT(//' Test of special arguments'//)
 1041 FORMAT('  F(XMIN) = ',E24.17/)
 1050 FORMAT(' Test of Error Returns'///)
 1052 FORMAT(' DAW will be called with the argument',E13.6,/
     1    ' This should not underflow'//)
 1053 FORMAT(' DAW will be called with the argument',E13.6,/
     1    ' This may underflow'//)
 1062 FORMAT(' DAW returned the value',E13.6///)
 1100 FORMAT(' This concludes the tests')
C---------- Last line of DAW test program ---------- 
      END
      SUBROUTINE CALCEI(ARG,RESULT,INT)
C----------------------------------------------------------------------
C
C This Fortran 77 packet computes the exponential integrals Ei(x),
C  E1(x), and  exp(-x)*Ei(x)  for real arguments  x  where
C
C           integral (from t=-infinity to t=x) (exp(t)/t),  x > 0,
C  Ei(x) =
C          -integral (from t=-x to t=infinity) (exp(t)/t),  x < 0,
C
C  and where the first integral is a principal value integral.
C  The packet contains three function type subprograms: EI, EONE,
C  and EXPEI;  and one subroutine type subprogram: CALCEI.  The
C  calling statements for the primary entries are
C
C                 Y = EI(X),            where  X .NE. 0,
C
C                 Y = EONE(X),          where  X .GT. 0,
C  and
C                 Y = EXPEI(X),         where  X .NE. 0,
C
C  and where the entry points correspond to the functions Ei(x),
C  E1(x), and exp(-x)*Ei(x), respectively.  The routine CALCEI
C  is intended for internal packet use only, all computations within
C  the packet being concentrated in this routine.  The function
C  subprograms invoke CALCEI with the Fortran statement
C         CALL CALCEI(ARG,RESULT,INT)
C  where the parameter usage is as follows
C
C     Function                  Parameters for CALCEI
C       Call                 ARG             RESULT         INT
C
C      EI(X)              X .NE. 0          Ei(X)            1
C      EONE(X)            X .GT. 0         -Ei(-X)           2
C      EXPEI(X)           X .NE. 0          exp(-X)*Ei(X)    3
C
C  The main computation involves evaluation of rational Chebyshev
C  approximations published in Math. Comp. 22, 641-649 (1968), and
C  Math. Comp. 23, 289-303 (1969) by Cody and Thacher.  This
C  transportable program is patterned after the machine-dependent
C  FUNPACK packet  NATSEI,  but cannot match that version for
C  efficiency or accuracy.  This version uses rational functions
C  that theoretically approximate the exponential integrals to
C  at least 18 significant decimal digits.  The accuracy achieved
C  depends on the arithmetic system, the compiler, the intrinsic
C  functions, and proper selection of the machine-dependent
C  constants.
C
C
C*******************************************************************
C*******************************************************************
C
C Explanation of machine-dependent constants.  Let
C
C   beta = radix for the floating-point system.
C   minexp = smallest representable power of beta.
C   maxexp = smallest power of beta that overflows.
C
C Then the following machine-dependent constants must be declared
C   in DATA statements.  IEEE values are provided as a default.
C
C   XBIG = largest argument acceptable to EONE; solution to
C          equation:
C                     exp(-x)/x * (1 + 1/x) = beta ** minexp.
C   XINF = largest positive machine number; approximately
C                     beta ** maxexp
C   XMAX = largest argument acceptable to EI; solution to
C          equation:  exp(x)/x * (1 + 1/x) = beta ** maxexp.
C
C     Approximate values for some important machines are:
C
C                           beta      minexp      maxexp
C
C  CRAY-1        (S.P.)       2       -8193        8191
C  Cyber 180/185
C    under NOS   (S.P.)       2        -975        1070
C  IEEE (IBM/XT,
C    SUN, etc.)  (S.P.)       2        -126         128
C  IEEE (IBM/XT,
C    SUN, etc.)  (D.P.)       2       -1022        1024
C  IBM 3033      (D.P.)      16         -65          63
C  VAX D-Format  (D.P.)       2        -128         127
C  VAX G-Format  (D.P.)       2       -1024        1023
C
C                           XBIG       XINF       XMAX
C
C  CRAY-1        (S.P.)    5670.31  5.45E+2465   5686.21
C  Cyber 180/185
C    under NOS   (S.P.)     669.31  1.26E+322     748.28
C  IEEE (IBM/XT,
C    SUN, etc.)  (S.P.)      82.93  3.40E+38       93.24
C  IEEE (IBM/XT,
C    SUN, etc.)  (D.P.)     701.84  1.79D+308     716.35
C  IBM 3033      (D.P.)     175.05  7.23D+75      179.85
C  VAX D-Format  (D.P.)      84.30  1.70D+38       92.54
C  VAX G-Format  (D.P.)     703.22  8.98D+307     715.66
C
C*******************************************************************
C*******************************************************************
C
C Error returns
C
C  The following table shows the types of error that may be
C  encountered in this routine and the function value supplied
C  in each case.
C
C       Error       Argument         Function values for
C                    Range         EI      EXPEI     EONE
C
C     UNDERFLOW  (-)X .GT. XBIG     0        -         0
C     OVERFLOW      X .GE. XMAX    XINF      -         -
C     ILLEGAL X       X = 0       -XINF    -XINF     XINF
C     ILLEGAL X      X .LT. 0       -        -     USE ABS(X)
C
C Intrinsic functions required are:
C
C     ABS, SQRT, EXP
C
C
C  Author: W. J. Cody
C          Mathematics abd Computer Science Division
C          Argonne National Laboratory
C          Argonne, IL 60439
C
C  Latest modification: March 9, 1992
C
C----------------------------------------------------------------------
      INTEGER I,INT
CS    REAL
CD    DOUBLE PRECISION
     1       A,ARG,B,C,D,EXP40,E,EI,F,FOUR,FOURTY,FRAC,HALF,ONE,P,
     2       PLG,PX,P037,P1,P2,Q,QLG,QX,Q1,Q2,R,RESULT,S,SIX,SUMP,
     3       SUMQ,T,THREE,TWELVE,TWO,TWO4,W,X,XBIG,XINF,XMAX,XMX0,
     4       X0,X01,X02,X11,Y,YSQ,ZERO
      DIMENSION  A(7),B(6),C(9),D(9),E(10),F(10),P(10),Q(10),R(10),
     1   S(9),P1(10),Q1(9),P2(10),Q2(9),PLG(4),QLG(4),PX(10),QX(10)
C----------------------------------------------------------------------
C  Mathematical constants
C   EXP40 = exp(40)
C   X0 = zero of Ei
C   X01/X11 + X02 = zero of Ei to extra precision
C----------------------------------------------------------------------
CS    DATA ZERO,P037,HALF,ONE,TWO/0.0E0,0.037E0,0.5E0,1.0E0,2.0E0/,
CS   1     THREE,FOUR,SIX,TWELVE,TWO4/3.0E0,4.0E0,6.0E0,12.E0,24.0E0/,
CS   2     FOURTY,EXP40/40.0E0,2.3538526683701998541E17/,
CS   3     X01,X11,X02/381.5E0,1024.0E0,-5.1182968633365538008E-5/,
CS   4     X0/3.7250741078136663466E-1/
CD    DATA ZERO,P037,HALF,ONE,TWO/0.0D0,0.037D0,0.5D0,1.0D0,2.0D0/,
CD   1     THREE,FOUR,SIX,TWELVE,TWO4/3.0D0,4.0D0,6.0D0,12.D0,24.0D0/,
CD   2     FOURTY,EXP40/40.0D0,2.3538526683701998541D17/,
CD   3     X01,X11,X02/381.5D0,1024.0D0,-5.1182968633365538008D-5/,
CD   4     X0/3.7250741078136663466D-1/
C----------------------------------------------------------------------
C Machine-dependent constants
C----------------------------------------------------------------------
CS    DATA XINF/3.40E+38/,XMAX/93.246E0/,XBIG/82.93E0/
CD    DATA XINF/1.79D+308/,XMAX/716.351D0/,XBIG/701.84D0/
C----------------------------------------------------------------------
C Coefficients  for -1.0 <= X < 0.0
C----------------------------------------------------------------------
CS    DATA A/1.1669552669734461083368E2, 2.1500672908092918123209E3,
CS   1       1.5924175980637303639884E4, 8.9904972007457256553251E4,
CS   2       1.5026059476436982420737E5,-1.4815102102575750838086E5,
CS   3       5.0196785185439843791020E0/
CS    DATA B/4.0205465640027706061433E1, 7.5043163907103936624165E2,
CS   1       8.1258035174768735759855E3, 5.2440529172056355429883E4,
CS   2       1.8434070063353677359298E5, 2.5666493484897117319268E5/
CD    DATA A/1.1669552669734461083368D2, 2.1500672908092918123209D3,
CD   1       1.5924175980637303639884D4, 8.9904972007457256553251D4,
CD   2       1.5026059476436982420737D5,-1.4815102102575750838086D5,
CD   3       5.0196785185439843791020D0/
CD    DATA B/4.0205465640027706061433D1, 7.5043163907103936624165D2,
CD   1       8.1258035174768735759855D3, 5.2440529172056355429883D4,
CD   2       1.8434070063353677359298D5, 2.5666493484897117319268D5/
C----------------------------------------------------------------------
C Coefficients for -4.0 <= X < -1.0
C----------------------------------------------------------------------
CS    DATA C/3.828573121022477169108E-1, 1.107326627786831743809E+1,
CS   1       7.246689782858597021199E+1, 1.700632978311516129328E+2,
CS   2       1.698106763764238382705E+2, 7.633628843705946890896E+1,
CS   3       1.487967702840464066613E+1, 9.999989642347613068437E-1,
CS   4       1.737331760720576030932E-8/
CS    DATA D/8.258160008564488034698E-2, 4.344836335509282083360E+0,
CS   1       4.662179610356861756812E+1, 1.775728186717289799677E+2,
CS   2       2.953136335677908517423E+2, 2.342573504717625153053E+2,
CS   3       9.021658450529372642314E+1, 1.587964570758947927903E+1,
CS   4       1.000000000000000000000E+0/
CD    DATA C/3.828573121022477169108D-1, 1.107326627786831743809D+1,
CD   1       7.246689782858597021199D+1, 1.700632978311516129328D+2,
CD   2       1.698106763764238382705D+2, 7.633628843705946890896D+1,
CD   3       1.487967702840464066613D+1, 9.999989642347613068437D-1,
CD   4       1.737331760720576030932D-8/
CD    DATA D/8.258160008564488034698D-2, 4.344836335509282083360D+0,
CD   1       4.662179610356861756812D+1, 1.775728186717289799677D+2,
CD   2       2.953136335677908517423D+2, 2.342573504717625153053D+2,
CD   3       9.021658450529372642314D+1, 1.587964570758947927903D+1,
CD   4       1.000000000000000000000D+0/
C----------------------------------------------------------------------
C Coefficients for X < -4.0
C----------------------------------------------------------------------
CS    DATA E/1.3276881505637444622987E+2,3.5846198743996904308695E+4,
CS   1       1.7283375773777593926828E+5,2.6181454937205639647381E+5,
CS   2       1.7503273087497081314708E+5,5.9346841538837119172356E+4,
CS   3       1.0816852399095915622498E+4,1.0611777263550331766871E03,
CS   4       5.2199632588522572481039E+1,9.9999999999999999087819E-1/
CS    DATA F/3.9147856245556345627078E+4,2.5989762083608489777411E+5,
CS   1       5.5903756210022864003380E+5,5.4616842050691155735758E+5,
CS   2       2.7858134710520842139357E+5,7.9231787945279043698718E+4,
CS   3       1.2842808586627297365998E+4,1.1635769915320848035459E+3,
CS   4       5.4199632588522559414924E+1,1.0E0/
CD    DATA E/1.3276881505637444622987D+2,3.5846198743996904308695D+4,
CD   1       1.7283375773777593926828D+5,2.6181454937205639647381D+5,
CD   2       1.7503273087497081314708D+5,5.9346841538837119172356D+4,
CD   3       1.0816852399095915622498D+4,1.0611777263550331766871D03,
CD   4       5.2199632588522572481039D+1,9.9999999999999999087819D-1/
CD    DATA F/3.9147856245556345627078D+4,2.5989762083608489777411D+5,
CD   1       5.5903756210022864003380D+5,5.4616842050691155735758D+5,
CD   2       2.7858134710520842139357D+5,7.9231787945279043698718D+4,
CD   3       1.2842808586627297365998D+4,1.1635769915320848035459D+3,
CD   4       5.4199632588522559414924D+1,1.0D0/
C----------------------------------------------------------------------
C  Coefficients for rational approximation to ln(x/a), |1-x/a| < .1
C----------------------------------------------------------------------
CS    DATA PLG/-2.4562334077563243311E+01,2.3642701335621505212E+02,
CS   1         -5.4989956895857911039E+02,3.5687548468071500413E+02/
CS    DATA QLG/-3.5553900764052419184E+01,1.9400230218539473193E+02,
CS   1         -3.3442903192607538956E+02,1.7843774234035750207E+02/
CD    DATA PLG/-2.4562334077563243311D+01,2.3642701335621505212D+02,
CD   1         -5.4989956895857911039D+02,3.5687548468071500413D+02/
CD    DATA QLG/-3.5553900764052419184D+01,1.9400230218539473193D+02,
CD   1         -3.3442903192607538956D+02,1.7843774234035750207D+02/
C----------------------------------------------------------------------
C Coefficients for  0.0 < X < 6.0,
C  ratio of Chebyshev polynomials
C----------------------------------------------------------------------
CS    DATA P/-1.2963702602474830028590E01,-1.2831220659262000678155E03,
CS   1       -1.4287072500197005777376E04,-1.4299841572091610380064E06,
CS   2       -3.1398660864247265862050E05,-3.5377809694431133484800E08,
CS   3        3.1984354235237738511048E08,-2.5301823984599019348858E10,
CS   4        1.2177698136199594677580E10,-2.0829040666802497120940E11/
CS    DATA Q/ 7.6886718750000000000000E01,-5.5648470543369082846819E03,
CS   1        1.9418469440759880361415E05,-4.2648434812177161405483E06,
CS   2        6.4698830956576428587653E07,-7.0108568774215954065376E08,
CS   3        5.4229617984472955011862E09,-2.8986272696554495342658E10,
CS   4        9.8900934262481749439886E10,-8.9673749185755048616855E10/
CD    DATA P/-1.2963702602474830028590D01,-1.2831220659262000678155D03,
CD   1       -1.4287072500197005777376D04,-1.4299841572091610380064D06,
CD   2       -3.1398660864247265862050D05,-3.5377809694431133484800D08,
CD   3        3.1984354235237738511048D08,-2.5301823984599019348858D10,
CD   4        1.2177698136199594677580D10,-2.0829040666802497120940D11/
CD    DATA Q/ 7.6886718750000000000000D01,-5.5648470543369082846819D03,
CD   1        1.9418469440759880361415D05,-4.2648434812177161405483D06,
CD   2        6.4698830956576428587653D07,-7.0108568774215954065376D08,
CD   3        5.4229617984472955011862D09,-2.8986272696554495342658D10,
CD   4        9.8900934262481749439886D10,-8.9673749185755048616855D10/
C----------------------------------------------------------------------
C J-fraction coefficients for 6.0 <= X < 12.0
C----------------------------------------------------------------------
CS    DATA R/-2.645677793077147237806E00,-2.378372882815725244124E00,
CS   1       -2.421106956980653511550E01, 1.052976392459015155422E01,
CS   2        1.945603779539281810439E01,-3.015761863840593359165E01,
CS   3        1.120011024227297451523E01,-3.988850730390541057912E00,
CS   4        9.565134591978630774217E00, 9.981193787537396413219E-1/
CS    DATA S/ 1.598517957704779356479E-4, 4.644185932583286942650E00,
CS   1        3.697412299772985940785E02,-8.791401054875438925029E00,
CS   2        7.608194509086645763123E02, 2.852397548119248700147E01,
CS   3        4.731097187816050252967E02,-2.369210235636181001661E02,
CS   4        1.249884822712447891440E00/
CD    DATA R/-2.645677793077147237806D00,-2.378372882815725244124D00,
CD   1       -2.421106956980653511550D01, 1.052976392459015155422D01,
CD   2        1.945603779539281810439D01,-3.015761863840593359165D01,
CD   3        1.120011024227297451523D01,-3.988850730390541057912D00,
CD   4        9.565134591978630774217D00, 9.981193787537396413219D-1/
CD    DATA S/ 1.598517957704779356479D-4, 4.644185932583286942650D00,
CD   1        3.697412299772985940785D02,-8.791401054875438925029D00,
CD   2        7.608194509086645763123D02, 2.852397548119248700147D01,
CD   3        4.731097187816050252967D02,-2.369210235636181001661D02,
CD   4        1.249884822712447891440D00/
C----------------------------------------------------------------------
C J-fraction coefficients for 12.0 <= X < 24.0
C----------------------------------------------------------------------
CS    DATA P1/-1.647721172463463140042E00,-1.860092121726437582253E01,
CS   1        -1.000641913989284829961E01,-2.105740799548040450394E01,
CS   2        -9.134835699998742552432E-1,-3.323612579343962284333E01,
CS   3         2.495487730402059440626E01, 2.652575818452799819855E01,
CS   4        -1.845086232391278674524E00, 9.999933106160568739091E-1/
CS    DATA Q1/ 9.792403599217290296840E01, 6.403800405352415551324E01,
CS   1         5.994932325667407355255E01, 2.538819315630708031713E02,
CS   2         4.429413178337928401161E01, 1.192832423968601006985E03,
CS   3         1.991004470817742470726E02,-1.093556195391091143924E01,
CS   4         1.001533852045342697818E00/
CD    DATA P1/-1.647721172463463140042D00,-1.860092121726437582253D01,
CD   1        -1.000641913989284829961D01,-2.105740799548040450394D01,
CD   2        -9.134835699998742552432D-1,-3.323612579343962284333D01,
CD   3         2.495487730402059440626D01, 2.652575818452799819855D01,
CD   4        -1.845086232391278674524D00, 9.999933106160568739091D-1/
CD    DATA Q1/ 9.792403599217290296840D01, 6.403800405352415551324D01,
CD   1         5.994932325667407355255D01, 2.538819315630708031713D02,
CD   2         4.429413178337928401161D01, 1.192832423968601006985D03,
CD   3         1.991004470817742470726D02,-1.093556195391091143924D01,
CD   4         1.001533852045342697818D00/
C----------------------------------------------------------------------
C J-fraction coefficients for  X .GE. 24.0
C----------------------------------------------------------------------
CS    DATA P2/ 1.75338801265465972390E02,-2.23127670777632409550E02,
CS   1        -1.81949664929868906455E01,-2.79798528624305389340E01,
CS   2        -7.63147701620253630855E00,-1.52856623636929636839E01,
CS   3        -7.06810977895029358836E00,-5.00006640413131002475E00,
CS   4        -3.00000000320981265753E00, 1.00000000000000485503E00/
CS    DATA Q2/ 3.97845977167414720840E04, 3.97277109100414518365E00,
CS   1         1.37790390235747998793E02, 1.17179220502086455287E02,
CS   2         7.04831847180424675988E01,-1.20187763547154743238E01,
CS   3        -7.99243595776339741065E00,-2.99999894040324959612E00,
CS   4         1.99999999999048104167E00/
CD    DATA P2/ 1.75338801265465972390D02,-2.23127670777632409550D02,
CD   1        -1.81949664929868906455D01,-2.79798528624305389340D01,
CD   2        -7.63147701620253630855D00,-1.52856623636929636839D01,
CD   3        -7.06810977895029358836D00,-5.00006640413131002475D00,
CD   4        -3.00000000320981265753D00, 1.00000000000000485503D00/
CD    DATA Q2/ 3.97845977167414720840D04, 3.97277109100414518365D00,
CD   1         1.37790390235747998793D02, 1.17179220502086455287D02,
CD   2         7.04831847180424675988D01,-1.20187763547154743238D01,
CD   3        -7.99243595776339741065D00,-2.99999894040324959612D00,
CD   4         1.99999999999048104167D00/
C----------------------------------------------------------------------
      X = ARG
      IF (X .EQ. ZERO) THEN
            EI = -XINF
            IF (INT .EQ. 2) EI = -EI
         ELSE IF ((X .LT. ZERO) .OR. (INT .EQ. 2)) THEN
C----------------------------------------------------------------------
C Calculate EI for negative argument or for E1.
C----------------------------------------------------------------------
            Y = ABS(X)
            IF (Y .LE. ONE) THEN
                  SUMP = A(7) * Y + A(1)
                  SUMQ = Y + B(1)
                  DO 110 I = 2, 6
                     SUMP = SUMP * Y + A(I)
                     SUMQ = SUMQ * Y + B(I)
  110             CONTINUE
                  EI = LOG(Y) - SUMP / SUMQ
                  IF (INT .EQ. 3) EI = EI * EXP(Y)
               ELSE IF (Y .LE. FOUR) THEN
                  W = ONE / Y
                  SUMP = C(1)
                  SUMQ = D(1)
                  DO 130 I = 2, 9
                     SUMP = SUMP * W + C(I)
                     SUMQ = SUMQ * W + D(I)
  130             CONTINUE
                  EI = - SUMP / SUMQ
                  IF (INT .NE. 3) EI = EI * EXP(-Y)
               ELSE
                  IF ((Y .GT. XBIG) .AND. (INT .LT. 3)) THEN
                        EI = ZERO
                     ELSE
                        W = ONE / Y
                        SUMP = E(1)
                        SUMQ = F(1)
                        DO 150 I = 2, 10
                           SUMP = SUMP * W + E(I)
                           SUMQ = SUMQ * W + F(I)
  150                   CONTINUE
                        EI = -W * (ONE - W * SUMP / SUMQ )
                        IF (INT .NE. 3) EI = EI * EXP(-Y)
                  END IF
            END IF
            IF (INT .EQ. 2) EI = -EI
         ELSE IF (X .LT. SIX) THEN
C----------------------------------------------------------------------
C  To improve conditioning, rational approximations are expressed
C    in terms of Chebyshev polynomials for 0 <= X < 6, and in
C    continued fraction form for larger X.
C----------------------------------------------------------------------
            T = X + X
            T = T / THREE - TWO
            PX(1) = ZERO
            QX(1) = ZERO
            PX(2) = P(1)
            QX(2) = Q(1)
            DO 210 I = 2, 9
               PX(I+1) = T * PX(I) - PX(I-1) + P(I)
               QX(I+1) = T * QX(I) - QX(I-1) + Q(I)
  210       CONTINUE
            SUMP = HALF * T * PX(10) - PX(9) + P(10)
            SUMQ = HALF * T * QX(10) - QX(9) + Q(10)
            FRAC = SUMP / SUMQ
            XMX0 = (X - X01/X11) - X02
            IF (ABS(XMX0) .GE. P037) THEN
                  EI = LOG(X/X0) + XMX0 * FRAC
                  IF (INT .EQ. 3) EI = EXP(-X) * EI
               ELSE
C----------------------------------------------------------------------
C Special approximation to  ln(X/X0)  for X close to X0
C----------------------------------------------------------------------
                  Y = XMX0 / (X + X0)
                  YSQ = Y*Y
                  SUMP = PLG(1)
                  SUMQ = YSQ + QLG(1)
                  DO 220 I = 2, 4
                     SUMP = SUMP*YSQ + PLG(I)
                     SUMQ = SUMQ*YSQ + QLG(I)
  220             CONTINUE
                  EI = (SUMP / (SUMQ*(X+X0)) + FRAC) * XMX0
                  IF (INT .EQ. 3) EI = EXP(-X) * EI
            END IF
         ELSE IF (X .LT. TWELVE) THEN
            FRAC = ZERO
            DO 230 I = 1, 9
               FRAC = S(I) / (R(I) + X + FRAC)
  230       CONTINUE
            EI = (R(10) + FRAC) / X
            IF (INT .NE. 3) EI = EI * EXP(X)
         ELSE IF (X .LE. TWO4) THEN
            FRAC = ZERO
            DO 240 I = 1, 9
               FRAC = Q1(I) / (P1(I) + X + FRAC)
  240       CONTINUE
            EI = (P1(10) + FRAC) / X
            IF (INT .NE. 3) EI = EI * EXP(X)
         ELSE
            IF ((X .GE. XMAX) .AND. (INT .LT. 3)) THEN
                  EI = XINF
               ELSE
                  Y = ONE / X
                  FRAC = ZERO
                  DO 250 I = 1, 9
                     FRAC = Q2(I) / (P2(I) + X + FRAC)
  250             CONTINUE
                  FRAC = P2(10) + FRAC
                  EI = Y + Y * Y * FRAC
                  IF (INT .NE. 3) THEN
                        IF (X .LE. XMAX-TWO4) THEN
                              EI = EI * EXP(X)
                           ELSE
C----------------------------------------------------------------------
C Calculation reformulated to avoid premature overflow
C----------------------------------------------------------------------
                              EI = (EI * EXP(X-FOURTY)) * EXP40
                        END IF
                  END IF
            END IF
      END IF
      RESULT = EI
      RETURN
C---------- Last line of CALCEI ----------
      END
CS    REAL FUNCTION EI(X)
CD    DOUBLE PRECISION FUNCTION EI(X)
C--------------------------------------------------------------------
C
C This function program computes approximate values for the
C   exponential integral  Ei(x), where  x  is real.
C
C  Author: W. J. Cody
C
C  Latest modification: March 9, 1992
C
C--------------------------------------------------------------------
      INTEGER INT
CS    REAL  X, RESULT
CD    DOUBLE PRECISION  X, RESULT
C--------------------------------------------------------------------
      INT = 1
      CALL CALCEI(X,RESULT,INT)
      EI = RESULT
      RETURN
C---------- Last line of EI ----------
      END
CS    REAL FUNCTION EXPEI(X)
CD    DOUBLE PRECISION FUNCTION EXPEI(X)
C--------------------------------------------------------------------
C
C This function program computes approximate values for the
C   function  exp(-x) * Ei(x), where  Ei(x)  is the exponential
C   integral, and  x  is real.
C
C  Author: W. J. Cody
C
C  Latest modification: March 9, 1992
C
C--------------------------------------------------------------------
      INTEGER INT
CS    REAL  X, RESULT
CD    DOUBLE PRECISION  X, RESULT
C--------------------------------------------------------------------
      INT = 3
      CALL CALCEI(X,RESULT,INT)
      EXPEI = RESULT
      RETURN
C---------- Last line of EXPEI ----------
      END
CS    REAL FUNCTION EONE(X)
CD    DOUBLE PRECISION FUNCTION EONE(X)
C--------------------------------------------------------------------
C
C This function program computes approximate values for the
C   exponential integral E1(x), where  x  is real.
C
C  Author: W. J. Cody
C
C  Latest modification: March 9, 1992
C
C--------------------------------------------------------------------
      INTEGER INT
CS    REAL  X, RESULT
CD    DOUBLE PRECISION  X, RESULT
C--------------------------------------------------------------------
      INT = 2
      CALL CALCEI(X,RESULT,INT)
      EONE = RESULT
      RETURN
C---------- Last line of EONE ----------
      END
      PROGRAM EITEST
C------------------------------------------------------------------
C FORTRAN 77 program to test EI, EONE, and EXPEI.
C
C  Method:
C
C     Accuracy test compare function values against local Taylor's
C     series expansions.  Derivatives for Ei(x) are generated from
C     the recurrence relation using a technique due to Gautschi
C     (see references).  Special argument tests are run with the
C     related functions E1(x) and exp(-x)Ei(x).
C
C  Data required
C
C     None
C
C  Subprograms required from this package
C
C     MACHAR - An environmental inquiry program providing
C              information on the floating-point arithmetic
C              system.  Note that the call to MACHAR can
C              be deleted provided the following five
C              parameters are assigned the values indicated
C
C              IBETA  - The radix of the floating-point system
C              IT     - The number of base-ibeta digits in the
C                       significant of a floating-point number
C              XMAX   - The largest finite floating-point number
C
C     REN(K) - A function subprogram returning random real
C              numbers uniformly distributed over (0,1)
C
C
C  Intrinsic functions required are:
C
C      ABS, AINT, DBLE, LOG, MAX, REAL, SQRT
C
C  References: "The use of Taylor series to test accuracy of
C               function programs", Cody, W. J., and Stoltz, L.,
C               submitted for publication.
C
C              "Recursive computation of certain derivatives -
C               A study of error propagation", Gautschi, W., and
C               Klein, B. J., Comm. ACM 13 (1970), 7-9.
C
C              "Remark on Algorithm 282", Gautschi, W., and Klein,
C               B. J., Comm. ACM 13 (1970), 53-54.
C
C  Latest modification: March 9, 1992
C
C  Author: W. J. Cody
C          Mathematics and Computer Science Division 
C          Argonne National Laboratory
C          Argonne, IL 60439
C
C------------------------------------------------------------------
      INTEGER I,IBETA,IEXP,IOUT,IRND,IT,J,JT,K,K1,K2,K3,
     1        MACHEP,MAXEXP,MINEXP,N,NEGEP,NGRD,N1
CS    REAL
CD    DOUBLE PRECISION
     1    A,AIT,ALBETA,B,BETA,CONV,C1,D,DEL,DX,EN,EI,EONE,EPS,EPSNEG,
     2    EXPEI,FIV12,FOUR,FOURTH,ONE,P0625,REM,REN,R6,R7,SIX,SUM,
     3    TEN,TWO,U,V,W,X,XBIG,XC,XDEN,XL,XLGE,XMAX,XMIN,XN,XNP1,
     4    XNUM,X0,X99,Y,Z,ZERO
      DIMENSION D(0:25)
C------------------------------------------------------------------
CS    DATA ZERO,FOURTH,ONE,FOUR,SIX/0.0E0,0.25E0,1.0E0,4.0E0,6.0E0/,
CS   1     TEN,X0,X99,P0625/10.0E0,0.3725E0,-999.0E0,0.0625E0/,
CS   2     FIV12,REM/512.0E0,-7.424779065800051695596E-5/
CD    DATA ZERO,FOURTH,ONE,FOUR,SIX/0.0D0,0.25D0,1.0D0,4.0D0,6.0D0/,
CD   1     TEN,X0,X99,P0625/10.0D0,0.3725D0,-999.0D0,0.0625D0/,
CD   2     FIV12,REM/512.0D0,-7.424779065800051695596D-5/
      DATA IOUT/6/
C------------------------------------------------------------------
C  Statement functions for conversion 
C------------------------------------------------------------------
CS    CONV(I) = REAL(I)
CD    CONV(I) = DBLE(I)
C------------------------------------------------------------------
C  Determine machine parameters and set constants
C------------------------------------------------------------------
      CALL MACHAR(IBETA,IT,IRND,NGRD,MACHEP,NEGEP,IEXP,MINEXP,
     1            MAXEXP,EPS,EPSNEG,XMIN,XMAX)
      BETA = CONV(IBETA)
      ALBETA = LOG(BETA)
      AIT = CONV(IT)
      DX = -P0625
      A = FOURTH + DX
      B = X0 + DX
      N = 2000
      N1 = 25
      XN = CONV(N)
      JT = 0
C-----------------------------------------------------------------
C  Random argument accuracy tests
C-----------------------------------------------------------------
      DO 300 J = 1, 8
         K1 = 0
         K3 = 0
         XC = ZERO
         R6 = ZERO
         R7 = ZERO
         DEL = (B - A) / XN
         XL = A
         DO 200 I = 1, N
            Y = DEL * REN(JT) + XL
            X = Y - DX
            Y = X + DX
C-----------------------------------------------------------------
C  Test Ei against series expansion
C-----------------------------------------------------------------
            V = EI(X)
            Z = EI(Y)
            SUM = ZERO
            U = X
            CALL DSUBN(U,N1,XMAX,D)
            EN = CONV(N1)+ONE
            SUM = D(N1)*DX/EN
            DO 100 K = N1,1,-1
               EN = EN-ONE
               SUM = (SUM + D(K-1))*DX/EN
  100       CONTINUE
            U = V + SUM
C--------------------------------------------------------------------
C  Accumulate results
C--------------------------------------------------------------------
            W = Z - U
            W = W / Z
            IF (W .GT. ZERO) THEN
                  K1 = K1 + 1
               ELSE IF (W .LT. ZERO) THEN
                  K3 = K3 + 1
            END IF
            W = ABS(W)
            IF (W .GT. R6) THEN
                  R6 = W
                  XC = Y
            END IF
            R7 = R7 + W * W
            XL = XL + DEL
  200    CONTINUE
C------------------------------------------------------------------
C  Gather and print statistics for test
C------------------------------------------------------------------
         K2 = N - K3 - K1
         R7 = SQRT(R7/XN)
         WRITE (IOUT,1000)
         WRITE (IOUT,1010) N,A,B
         WRITE (IOUT,1011) K1
         WRITE (IOUT,1015) K2,K3
         WRITE (IOUT,1020) IT,IBETA
         IF (R6 .NE. ZERO) THEN
               W = LOG(ABS(R6))/ALBETA
            ELSE
               W = X99
         END IF
         WRITE (IOUT,1021) R6,IBETA,W,XC
         W = MAX(AIT+W,ZERO)
         WRITE (IOUT,1022) IBETA,W
         IF (R7 .NE. ZERO) THEN
               W = LOG(ABS(R7))/ALBETA
            ELSE
               W = X99
         END IF
         WRITE (IOUT,1023) R7,IBETA,W
         W = MAX(AIT+W,ZERO)
         WRITE (IOUT,1022) IBETA,W
C------------------------------------------------------------------
C  Initialize for next test
C------------------------------------------------------------------
         IF (J .EQ. 1) THEN
               DX = -DX
               A = X0 + DX
               B = SIX
            ELSE IF (J .LE. 4) THEN
               A = B
               B = B+B
            ELSE IF (J .EQ. 5) THEN
               A = -FOURTH
               B = -ONE
            ELSE IF (J .EQ. 6) THEN
               A = B
               B = -FOUR
            ELSE 
               A = B
               B = -TEN
         END IF
  300 CONTINUE
C-----------------------------------------------------------------
C  Special tests.  First, check accuracy near the zero of Ei(x)
C-----------------------------------------------------------------
      WRITE (IOUT,1040)
      X = (FOUR - ONE) / (FOUR + FOUR)
      Y = EI(X)
      WRITE (IOUT,1041) X,Y
      Z = ((Y - (FOUR+ONE)/(FIV12)) - REM)/Y
      IF (Z .NE. ZERO) THEN
            W = LOG(ABS(Z))/ALBETA
         ELSE
            W = X99
      END IF
      WRITE (IOUT,1042) Z,IBETA,W
      W = MAX(AIT+W,ZERO)
      WRITE (IOUT,1022) IBETA,W
C-----------------------------------------------------------------
C  Check near XBIG, the largest argument acceptable to EONE, i.e.,
C    the negative of the smallest argument acceptable to EI.
C    Determine XBIG with Newton iteration on the equation
C                  EONE(x) = XMIN.
C---------------------------------------------------------------------
      WRITE (IOUT,1050)
      TWO = ONE+ONE
      V = SQRT(EPS)
      C1 = CONV(MINEXP) * LOG(BETA)
      XN = -C1
  320 XNUM = -XN - LOG(XN) + LOG(ONE+ONE/XN) - C1
      XDEN = -(XN*XN+XN+XN+TWO) / (XN*(XN+ONE))
      XNP1 = XN - XNUM/XDEN
      W = (XN-XNP1)/XNP1
      IF (ABS(W) .GT. V) THEN
         XN = XNP1
         GO TO 320
      END IF
      XBIG = XNP1
      X = AINT(TEN*XBIG) / TEN
      WRITE (IOUT,1052) X
      Y = EONE(X)
      WRITE (IOUT,1062) Y
      X = XBIG * (ONE+V)
      WRITE (IOUT,1053) X
      Y = EONE(X)
      WRITE (IOUT,1062) Y
C---------------------------------------------------------------------
C  Check near XMAX, the largest argument acceptable to EI.  Determine
C    XLGE with Newton iteration on the equation
C                  EI(x) = XMAX.
C---------------------------------------------------------------------
      C1 = CONV(MAXEXP) * LOG(BETA)
      XN = C1
  330 XNUM = XN - LOG(XN) + LOG(ONE+ONE/XN) - C1
      XDEN = (XN*XN-TWO) / (XN*(XN+ONE))
      XNP1 = XN - XNUM/XDEN
      W = (XN-XNP1)/XNP1
      IF (ABS(W) .GT. V) THEN
         XN = XNP1
         GO TO 330
      END IF
      XLGE = XNP1
      X = AINT(TEN*XLGE) / TEN
      WRITE (IOUT,1054) X
      Y = EI(X)
      WRITE (IOUT,1064) Y
      X = XLGE * (ONE+V)
      WRITE (IOUT,1055) X
      Y = EI(X)
      WRITE (IOUT,1064) Y
C---------------------------------------------------------------------
C  Check with XHUGE, the largest acceptable argument for EXPEI
C---------------------------------------------------------------------
      IF (XMIN*XMAX .LE. ONE) THEN
            X = XMAX
         ELSE
            X = ONE/XMIN 
      END IF
      WRITE (IOUT,1056) X
      Y = EXPEI(X)
      WRITE (IOUT,1065) Y
      X = ZERO
      WRITE (IOUT,1055) X
      Y = EI(X)
      WRITE (IOUT,1064) Y
      WRITE (IOUT,1100)
      STOP
C-----------------------------------------------------------------
 1000 FORMAT('1Test of Ei(x) vs series expansion'//)
 1010 FORMAT(I7,' Random arguments were tested from the interval (',
     1    F7.3,',',F7.3,')'//)
 1011 FORMAT('     EI(X) was larger',I6,' times,')
 1015 FORMAT(14X,' agreed',I6,' times, and'/
     1    10X,'was smaller',I6,' times.'//)
 1020 FORMAT(' There are',I4,' base',I4,
     1    ' significant digits in a floating-point number'//)
 1021 FORMAT(' The maximum relative error of',E15.4,' = ',I4,' **',
     1    F7.2/4X,'occurred for X =',E13.6)
 1022 FORMAT(' The estimated loss of base',I4,
     1    ' significant digits is',F7.2//)
 1023 FORMAT(' The root mean square relative error was',E15.4,
     1    ' = ',I4,' **',F7.2)
 1040 FORMAT(//' Test of special arguments'//)
 1041 FORMAT('   EI (',E13.6,') = ',E13.6//)
 1042 FORMAT(' The relative error is',E15.4,' = ',I4,' **',F7.2/)
 1050 FORMAT(' Test of Error Returns'///)
 1052 FORMAT(' EONE will be called with the argument',E13.6,/
     1    ' This should not underflow'//)
 1053 FORMAT(' EONE will be called with the argument',E13.6,/
     1    ' This should underflow'//)
 1054 FORMAT(' EI will be called with the argument',E13.6,/
     1    ' This should not overflow'//)
 1055 FORMAT(' EI will be called with the argument',E13.6,/
     1    ' This should overflow'//)
 1056 FORMAT(' EXPEI will be called with the argument',E13.6,/
     1    ' This should not underflow'//)
 1062 FORMAT(' EONE returned the value',E13.6///)
 1064 FORMAT(' EI returned the value',E13.6///)
 1065 FORMAT(' EXPEI returned the value',E13.6///)
 1100 FORMAT(' This concludes the tests')
C---------- Last line of EI test program ----------
      END
      SUBROUTINE DSUBN(X,NMAX,XMAX,D)
C-------------------------------------------------------------------
C Translation of Gautschi'f CACM Algorithm 282 for
C   derivatives of Ei(x).
C
C  Intrinsic functions required are:
C
C      ABS, EXP, INT, LOG, MIN
C
C-------------------------------------------------------------------
      LOGICAL BOOL1, BOOL2
      INTEGER J,NMAX,N0,MINI,N,N1,LIM
CS    REAL
CD    DOUBLE PRECISION
     1     B0,B1,B2,B3,B4,B5,B6,C0,C1,D,E,EN,ONE,P,Q,T,TEN,
     2     TWO,X,XMAX,X1,Z,ZERO
      DIMENSION D(0:NMAX)
CS    DATA ZERO/0.0E0/,ONE/1.0E0/,TWO/2.0E0/,TEN/10.0E0/
CS    DATA C0/2.7183E0/,C1/4.67452E1/
CS    DATA B0/5.7941E-5/,B1/-1.76148E-3/,B2/2.08645E-2/,
CS   1     B3/-1.29013E-1/,B4/8.5777E-1/,B5/1.0125E0/,B6/7.75E-1/
CD    DATA ZERO/0.0D0/,ONE/1.0D0/,TWO/2.0D0/,TEN/10.0D0/
CD    DATA C0/2.7183D0/,C1/4.67452D1/
CD    DATA B0/5.7941D-5/,B1/-1.76148D-3/,B2/2.08645D-2/,
CD   1     B3/-1.29013D-1/,B4/8.5777D-1/,B5/1.0125D0/,B6/7.75D-1/
C-------------------------------------------------------------------
      X1 = ABS(X)
      N0 = INT(X1)
      E = EXP(X)
      D(0) = E/X
      BOOL1 = (X .LT. ZERO) .OR. (X1 .LE. TWO)
      BOOL2 = N0 .LT. NMAX
      MINI = MIN(N0,NMAX)
      IF (BOOL1) THEN
            LIM = NMAX
         ELSE
            LIM = MINI
      END IF
      N = 1
      EN = ONE
   50 D(N) = (E - EN*D(N-1))/X
         N = N +1
         EN = EN + ONE
         IF (X1 .LT. ONE) THEN
               IF ((ABS(D(N-1)) .LT. ABS(XMAX*X/EN)) .AND.
     1            (N .LE. LIM)) GO TO 50
            ELSE
               IF ((ABS(D(N-1)/X) .LT. XMAX/EN) .AND. (N .LE. LIM))
     1            GO TO 50
         END IF
         DO 100 J = N, LIM
            D(N) = ZERO
  100    CONTINUE
      IF ((.NOT. BOOL1) .AND. BOOL2) THEN
         T = (X1+C1)/(C0*X1)
         IF (T .LT. TEN) THEN
               T = ((((B0*T + B1)*T + B2)*T + B3)*T + B4)*T + B5
            ELSE
               Z = LOG(T) - B6
               P = (B6-LOG(Z))/(ONE+Z)
               P = ONE/(ONE+P)
               T = T*P/Z
         END IF
         N1 = C0*X1*T - ONE
         IF (N1 .LT. NMAX) N1 = NMAX
         Q = ONE/X
         EN = ONE
         DO 120 N = 1,N1+1
            Q = -EN*Q/X
            EN = EN+ONE
  120    CONTINUE
         DO 140 N = N1,N0+1,-1
            EN = EN - ONE
            Q = (E-X*Q)/EN
            IF (N .LE. NMAX) D(N) = Q
  140    CONTINUE
      END IF
      RETURN
C---------- Last line of DSUBN ----------
      END
      SUBROUTINE CALERF(ARG,RESULT,JINT)
C------------------------------------------------------------------
C
C This packet evaluates  erf(x),  erfc(x),  and  exp(x*x)*erfc(x)
C   for a real argument  x.  It contains three FUNCTION type
C   subprograms: ERF, ERFC, and ERFCX (or DERF, DERFC, and DERFCX),
C   and one SUBROUTINE type subprogram, CALERF.  The calling
C   statements for the primary entries are:
C
C                   Y=ERF(X)     (or   Y=DERF(X)),
C
C                   Y=ERFC(X)    (or   Y=DERFC(X)),
C   and
C                   Y=ERFCX(X)   (or   Y=DERFCX(X)).
C
C   The routine  CALERF  is intended for internal packet use only,
C   all computations within the packet being concentrated in this
C   routine.  The function subprograms invoke  CALERF  with the
C   statement
C
C          CALL CALERF(ARG,RESULT,JINT)
C
C   where the parameter usage is as follows
C
C      Function                     Parameters for CALERF
C       call              ARG                  Result          JINT
C
C     ERF(ARG)      ANY REAL ARGUMENT         ERF(ARG)          0
C     ERFC(ARG)     ABS(ARG) .LT. XBIG        ERFC(ARG)         1
C     ERFCX(ARG)    XNEG .LT. ARG .LT. XMAX   ERFCX(ARG)        2
C
C   The main computation evaluates near-minimax approximations
C   from "Rational Chebyshev approximations for the error function"
C   by W. J. Cody, Math. Comp., 1969, PP. 631-638.  This
C   transportable program uses rational functions that theoretically
C   approximate  erf(x)  and  erfc(x)  to at least 18 significant
C   decimal digits.  The accuracy achieved depends on the arithmetic
C   system, the compiler, the intrinsic functions, and proper
C   selection of the machine-dependent constants.
C
C*******************************************************************
C*******************************************************************
C
C Explanation of machine-dependent constants.  Let
C
C   XMIN   = the smallest positive floating-point number.
C
C Then the following machine-dependent constants must be declared
C   in DATA statements.  IEEE values are provided as a default.
C
C   XINF   = the largest positive finite floating-point number.
C   XNEG   = the largest negative argument acceptable to ERFCX;
C            the negative of the solution to the equation
C            2*exp(x*x) = XINF.
C   XSMALL = argument below which erf(x) may be represented by
C            2*x/sqrt(pi)  and above which  x*x  will not underflow.
C            A conservative value is the largest machine number X
C            such that   1.0 + X = 1.0   to machine precision.
C   XBIG   = largest argument acceptable to ERFC;  solution to
C            the equation:  W(x) * (1-0.5/x**2) = XMIN,  where
C            W(x) = exp(-x*x)/[x*sqrt(pi)].
C   XHUGE  = argument above which  1.0 - 1/(2*x*x) = 1.0  to
C            machine precision.  A conservative value is
C            1/[2*sqrt(XSMALL)]
C   XMAX   = largest acceptable argument to ERFCX; the minimum
C            of XINF and 1/[sqrt(pi)*XMIN].
C
C   Approximate values for some important machines are:
C
C                          XMIN       XINF        XNEG     XSMALL
C
C  CDC 7600      (S.P.)  3.13E-294   1.26E+322   -27.220  7.11E-15
C  CRAY-1        (S.P.)  4.58E-2467  5.45E+2465  -75.345  7.11E-15
C  IEEE (IBM/XT,
C    SUN, etc.)  (S.P.)  1.18E-38    3.40E+38     -9.382  5.96E-8
C  IEEE (IBM/XT,
C    SUN, etc.)  (D.P.)  2.23D-308   1.79D+308   -26.628  1.11D-16
C  IBM 195       (D.P.)  5.40D-79    7.23E+75    -13.190  1.39D-17
C  UNIVAC 1108   (D.P.)  2.78D-309   8.98D+307   -26.615  1.73D-18
C  VAX D-Format  (D.P.)  2.94D-39    1.70D+38     -9.345  1.39D-17
C  VAX G-Format  (D.P.)  5.56D-309   8.98D+307   -26.615  1.11D-16
C
C
C                          XBIG       XHUGE       XMAX
C
C  CDC 7600      (S.P.)  25.922      8.39E+6     1.80X+293
C  CRAY-1        (S.P.)  75.326      8.39E+6     5.45E+2465
C  IEEE (IBM/XT,
C    SUN, etc.)  (S.P.)   9.194      2.90E+3     4.79E+37
C  IEEE (IBM/XT,
C    SUN, etc.)  (D.P.)  26.543      6.71D+7     2.53D+307
C  IBM 195       (D.P.)  13.306      1.90D+8     7.23E+75
C  UNIVAC 1108   (D.P.)  26.582      5.37D+8     8.98D+307
C  VAX D-Format  (D.P.)   9.269      1.90D+8     1.70D+38
C  VAX G-Format  (D.P.)  26.569      6.71D+7     8.98D+307
C
C*******************************************************************
C*******************************************************************
C
C Error returns
C
C  The program returns  ERFC = 0      for  ARG .GE. XBIG;
C
C                       ERFCX = XINF  for  ARG .LT. XNEG;
C      and
C                       ERFCX = 0     for  ARG .GE. XMAX.
C
C
C Intrinsic functions required are:
C
C     ABS, AINT, EXP
C
C
C  Author: W. J. Cody
C          Mathematics and Computer Science Division
C          Argonne National Laboratory
C          Argonne, IL 60439
C
C  Latest modification: March 12, 1992
C
C------------------------------------------------------------------
      INTEGER I,JINT
CS    REAL
CD    DOUBLE PRECISION
     1     A,ARG,B,C,D,DEL,FOUR,HALF,P,ONE,Q,RESULT,SIXTEN,SQRPI,
     2     TWO,THRESH,X,XBIG,XDEN,XHUGE,XINF,XMAX,XNEG,XNUM,XSMALL,
     3     Y,YSQ,ZERO
      DIMENSION A(5),B(4),C(9),D(8),P(6),Q(5)
C------------------------------------------------------------------
C  Mathematical constants
C------------------------------------------------------------------
CS    DATA FOUR,ONE,HALF,TWO,ZERO/4.0E0,1.0E0,0.5E0,2.0E0,0.0E0/,
CS   1     SQRPI/5.6418958354775628695E-1/,THRESH/0.46875E0/,
CS   2     SIXTEN/16.0E0/
CD    DATA FOUR,ONE,HALF,TWO,ZERO/4.0D0,1.0D0,0.5D0,2.0D0,0.0D0/,
CD   1     SQRPI/5.6418958354775628695D-1/,THRESH/0.46875D0/,
CD   2     SIXTEN/16.0D0/
C------------------------------------------------------------------
C  Machine-dependent constants
C------------------------------------------------------------------
CS    DATA XINF,XNEG,XSMALL/3.40E+38,-9.382E0,5.96E-8/,
CS   1     XBIG,XHUGE,XMAX/9.194E0,2.90E3,4.79E37/
CD    DATA XINF,XNEG,XSMALL/1.79D308,-26.628D0,1.11D-16/,
CD   1     XBIG,XHUGE,XMAX/26.543D0,6.71D7,2.53D307/
C------------------------------------------------------------------
C  Coefficients for approximation to  erf  in first interval
C------------------------------------------------------------------
CS    DATA A/3.16112374387056560E00,1.13864154151050156E02,
CS   1       3.77485237685302021E02,3.20937758913846947E03,
CS   2       1.85777706184603153E-1/
CS    DATA B/2.36012909523441209E01,2.44024637934444173E02,
CS   1       1.28261652607737228E03,2.84423683343917062E03/
CD    DATA A/3.16112374387056560D00,1.13864154151050156D02,
CD   1       3.77485237685302021D02,3.20937758913846947D03,
CD   2       1.85777706184603153D-1/
CD    DATA B/2.36012909523441209D01,2.44024637934444173D02,
CD   1       1.28261652607737228D03,2.84423683343917062D03/
C------------------------------------------------------------------
C  Coefficients for approximation to  erfc  in second interval
C------------------------------------------------------------------
CS    DATA C/5.64188496988670089E-1,8.88314979438837594E0,
CS   1       6.61191906371416295E01,2.98635138197400131E02,
CS   2       8.81952221241769090E02,1.71204761263407058E03,
CS   3       2.05107837782607147E03,1.23033935479799725E03,
CS   4       2.15311535474403846E-8/
CS    DATA D/1.57449261107098347E01,1.17693950891312499E02,
CS   1       5.37181101862009858E02,1.62138957456669019E03,
CS   2       3.29079923573345963E03,4.36261909014324716E03,
CS   3       3.43936767414372164E03,1.23033935480374942E03/
CD    DATA C/5.64188496988670089D-1,8.88314979438837594D0,
CD   1       6.61191906371416295D01,2.98635138197400131D02,
CD   2       8.81952221241769090D02,1.71204761263407058D03,
CD   3       2.05107837782607147D03,1.23033935479799725D03,
CD   4       2.15311535474403846D-8/
CD    DATA D/1.57449261107098347D01,1.17693950891312499D02,
CD   1       5.37181101862009858D02,1.62138957456669019D03,
CD   2       3.29079923573345963D03,4.36261909014324716D03,
CD   3       3.43936767414372164D03,1.23033935480374942D03/
C------------------------------------------------------------------
C  Coefficients for approximation to  erfc  in third interval
C------------------------------------------------------------------
CS    DATA P/3.05326634961232344E-1,3.60344899949804439E-1,
CS   1       1.25781726111229246E-1,1.60837851487422766E-2,
CS   2       6.58749161529837803E-4,1.63153871373020978E-2/
CS    DATA Q/2.56852019228982242E00,1.87295284992346047E00,
CS   1       5.27905102951428412E-1,6.05183413124413191E-2,
CS   2       2.33520497626869185E-3/
CD    DATA P/3.05326634961232344D-1,3.60344899949804439D-1,
CD   1       1.25781726111229246D-1,1.60837851487422766D-2,
CD   2       6.58749161529837803D-4,1.63153871373020978D-2/
CD    DATA Q/2.56852019228982242D00,1.87295284992346047D00,
CD   1       5.27905102951428412D-1,6.05183413124413191D-2,
CD   2       2.33520497626869185D-3/
C------------------------------------------------------------------
      X = ARG
      Y = ABS(X)
      IF (Y .LE. THRESH) THEN
C------------------------------------------------------------------
C  Evaluate  erf  for  |X| <= 0.46875
C------------------------------------------------------------------
            YSQ = ZERO
            IF (Y .GT. XSMALL) YSQ = Y * Y
            XNUM = A(5)*YSQ
            XDEN = YSQ
            DO 20 I = 1, 3
               XNUM = (XNUM + A(I)) * YSQ
               XDEN = (XDEN + B(I)) * YSQ
   20       CONTINUE
            RESULT = X * (XNUM + A(4)) / (XDEN + B(4))
            IF (JINT .NE. 0) RESULT = ONE - RESULT
            IF (JINT .EQ. 2) RESULT = EXP(YSQ) * RESULT
            GO TO 800
C------------------------------------------------------------------
C  Evaluate  erfc  for 0.46875 <= |X| <= 4.0
C------------------------------------------------------------------
         ELSE IF (Y .LE. FOUR) THEN
            XNUM = C(9)*Y
            XDEN = Y
            DO 120 I = 1, 7
               XNUM = (XNUM + C(I)) * Y
               XDEN = (XDEN + D(I)) * Y
  120       CONTINUE
            RESULT = (XNUM + C(8)) / (XDEN + D(8))
            IF (JINT .NE. 2) THEN
               YSQ = AINT(Y*SIXTEN)/SIXTEN
               DEL = (Y-YSQ)*(Y+YSQ)
               RESULT = EXP(-YSQ*YSQ) * EXP(-DEL) * RESULT
            END IF
C------------------------------------------------------------------
C  Evaluate  erfc  for |X| > 4.0
C------------------------------------------------------------------
         ELSE
            RESULT = ZERO
            IF (Y .GE. XBIG) THEN
               IF ((JINT .NE. 2) .OR. (Y .GE. XMAX)) GO TO 300
               IF (Y .GE. XHUGE) THEN
                  RESULT = SQRPI / Y
                  GO TO 300
               END IF
            END IF
            YSQ = ONE / (Y * Y)
            XNUM = P(6)*YSQ
            XDEN = YSQ
            DO 240 I = 1, 4
               XNUM = (XNUM + P(I)) * YSQ
               XDEN = (XDEN + Q(I)) * YSQ
  240       CONTINUE
            RESULT = YSQ *(XNUM + P(5)) / (XDEN + Q(5))
            RESULT = (SQRPI -  RESULT) / Y
            IF (JINT .NE. 2) THEN
               YSQ = AINT(Y*SIXTEN)/SIXTEN
               DEL = (Y-YSQ)*(Y+YSQ)
               RESULT = EXP(-YSQ*YSQ) * EXP(-DEL) * RESULT
            END IF
      END IF
C------------------------------------------------------------------
C  Fix up for negative argument, erf, etc.
C------------------------------------------------------------------
  300 IF (JINT .EQ. 0) THEN
            RESULT = (HALF - RESULT) + HALF
            IF (X .LT. ZERO) RESULT = -RESULT
         ELSE IF (JINT .EQ. 1) THEN
            IF (X .LT. ZERO) RESULT = TWO - RESULT
         ELSE
            IF (X .LT. ZERO) THEN
               IF (X .LT. XNEG) THEN
                     RESULT = XINF
                  ELSE
                     YSQ = AINT(X*SIXTEN)/SIXTEN
                     DEL = (X-YSQ)*(X+YSQ)
                     Y = EXP(YSQ*YSQ) * EXP(DEL)
                     RESULT = (Y+Y) - RESULT
               END IF
            END IF
      END IF
  800 RETURN
C---------- Last card of CALERF ----------
      END
CS    REAL FUNCTION ERF(X)
CD    DOUBLE PRECISION FUNCTION DERF(X)
C--------------------------------------------------------------------
C
C This subprogram computes approximate values for erf(x).
C   (see comments heading CALERF).
C
C   Author/date: W. J. Cody, January 8, 1985
C
C--------------------------------------------------------------------
      INTEGER JINT
CS    REAL             X, RESULT
CD    DOUBLE PRECISION X, RESULT
C------------------------------------------------------------------
      JINT = 0
      CALL CALERF(X,RESULT,JINT)
CS    ERF = RESULT
CD    DERF = RESULT
      RETURN
C---------- Last card of DERF ----------
      END
CS    REAL FUNCTION ERFC(X)
CD    DOUBLE PRECISION FUNCTION DERFC(X)
C--------------------------------------------------------------------
C
C This subprogram computes approximate values for erfc(x).
C   (see comments heading CALERF).
C
C   Author/date: W. J. Cody, January 8, 1985
C
C--------------------------------------------------------------------
      INTEGER JINT
CS    REAL             X, RESULT
CD    DOUBLE PRECISION X, RESULT
C------------------------------------------------------------------
      JINT = 1
      CALL CALERF(X,RESULT,JINT)
CS    ERFC = RESULT
CD    DERFC = RESULT
      RETURN
C---------- Last card of DERFC ----------
      END
CS    REAL FUNCTION ERFCX(X)
CD    DOUBLE PRECISION FUNCTION DERFCX(X)
C------------------------------------------------------------------
C
C This subprogram computes approximate values for exp(x*x) * erfc(x).
C   (see comments heading CALERF).
C
C   Author/date: W. J. Cody, March 30, 1987
C
C------------------------------------------------------------------
      INTEGER JINT
CS    REAL             X, RESULT
CD    DOUBLE PRECISION X, RESULT
C------------------------------------------------------------------
      JINT = 2
      CALL CALERF(X,RESULT,JINT)
CS    ERFCX = RESULT
CD    DERFCX = RESULT
      RETURN
C---------- Last card of DERFCX ----------
      END
      PROGRAM ERFTST
C------------------------------------------------------------------
C FORTRAN 77 program to test ERF and related functions.
C
C  Method:
C
C     Accuracy test compare function values against local Taylor's
C     series expansions.  Derivatives for erfc(x) are expressed as
C     repeated integrals of erfc(x).  These are generated from the
C     recurrence relation using a technique due to Gautschi (see
C     references).
C
C  Data required
C
C     None
C
C  Subprograms required from this package
C
C     MACHAR - An environmental inquiry program providing
C              information on the floating-point arithmetic
C              system.  Note that the call to MACHAR can
C              be deleted provided the following five
C              parameters are assigned the values indicated
C
C              IBETA  - The radix of the floating-point system
C              IT     - The number of base-ibeta digits in the
C                       significant of a floating-point number
C              EPS    - The smallest positive floating-point
C                       number such that 1.0+EPS .NE. 1.0
C              XMIN   - The smallest non-vanishing floating-point
C                       integral power of the radix
C              XMAX   - The largest finite floating-point number
C
C     REN(K) - A function subprogram returning random real
C              numbers uniformly distributed over (0,1)
C
C
C  Intrinsic functions required are:
C
C      ABS, DBLE, LOG, MAX, REAL, SQRT
C
C  References: "Performance evaluation of programs for the error
C               and complementary error functions", W. J. Cody,
C               submitted for publication.
C
C              "Evaluation of the repeated integrals of the coerror
C               function", W. Gautschi, TOMS 3, 1977, pp. 240-252.
C
C  Latest modification: March 12, 1992
C
C  Author: W. J. Cody
C          Mathematics and Computer Science Division 
C          Argonne National Laboratory
C          Argonne, IL 60439
C
C------------------------------------------------------------------
      INTEGER I,IBETA,IEXP,IOUT,IRND,IT,J,JT,K,K1,K2,K3,
     1        MACHEP,MAXEXP,MINEXP,N,NEGEP,NGRD,N0,N1
CS    REAL  ERF,ERFC,ERFCX,
CD    DOUBLE PRECISION DERF,DERFC,DERFCX,
     1    A,AIT,ALBETA,B,BETA,C,CONV,C1,C2,DEL,EPS,EPSCON,EPSNEG,FF,
     2    FUNC1,FUNC2,FUNC3,F0,HALF,ONE,R,REN,R1,R6,R7,SC,SIXTEN,
     3    THRESH,TEN,TWO,U,V,W,X,XBIG,XC,XL,XMAX,XMIN,XN,XN1,X99,
     4    Z,ZERO,ZZ
      DIMENSION R1(500)
C------------------------------------------------------------------
C   C1 = 1/sqrt(pi)
C------------------------------------------------------------------
CS    DATA ZERO,HALF,ONE,TWO,TEN/0.0E0,0.5E0,1.0E0,2.0E0,10.0E0/,
CS   1     SIXTEN,THRESH,X99/16.0E0,0.46875E0,-999.0E0/,
CS   2     C1/5.6418958354775628695E-1/
CD    DATA ZERO,HALF,ONE,TWO,TEN/0.0D0,0.5D0,1.0D0,2.0D0,10.0D0/,
CD   1     SIXTEN,THRESH,X99/16.0D0,0.46875D0,-999.0D0/,
CD   2     C1/5.6418958354775628695D-1/
      DATA IOUT/6/
C------------------------------------------------------------------
C  Statement functions for conversion 
C------------------------------------------------------------------
CS    CONV(I) = REAL(I)
CS    FUNC1(X) = ERF(X)
CS    FUNC2(X) = ERFC(X)
CS    FUNC3(X) = ERFCX(X)
CD    CONV(I) = DBLE(I)
CD    FUNC1(X) = DERF(X)
CD    FUNC2(X) = DERFC(X) 
CD    FUNC3(X) = DERFCX(X) 
C------------------------------------------------------------------
C  Determine machine parameters and set constants
C------------------------------------------------------------------
      CALL MACHAR(IBETA,IT,IRND,NGRD,MACHEP,NEGEP,IEXP,MINEXP,
     1            MAXEXP,EPS,EPSNEG,XMIN,XMAX)
      BETA = CONV(IBETA)
      ALBETA = LOG(BETA)
      AIT = CONV(IT)
      C = ABS(AIT*ALBETA) + TEN
      A = ZERO
      B = THRESH
      N = 2000
      XN = CONV(N)
      JT = 0
      N0 = (IBETA/2)*(IT+5)/6+4
C-----------------------------------------------------------------
C  Determine largest argument for ERFC test by Newton iteration
C-----------------------------------------------------------------
      C2 = LOG(XMIN) + LOG(ONE/C1)
      XBIG = SQRT(-C2)
   50 X = XBIG
         F0 = X*X
         FF = F0 + HALF/F0 + LOG(X) + C2
         F0 = X+X + ONE/X - ONE/(X*F0)
         XBIG = X - FF/F0
         IF (ABS(X-XBIG)/X .GT. TEN*EPS) GO TO 50
C-----------------------------------------------------------------
C  Random argument accuracy tests
C-----------------------------------------------------------------
      DO 300 J = 1, 5
         K1 = 0
         K3 = 0
         XC = ZERO
         R6 = ZERO
         R7 = ZERO
         DEL = (B - A) / XN
         XL = A
         DO 200 I = 1, N
            X = DEL * REN(JT) + XL
            IF (J .EQ. 1) THEN
C-----------------------------------------------------------------
C  Test erf against double series expansion
C-----------------------------------------------------------------
                  F0 = CONV(N0)
                  FF = F0+F0+ONE 
                  Z = X*X
                  W = Z+Z
                  U = ZERO
                  V = ZERO
                  DO 60 K = 1, N0
                     U = -Z/F0*(ONE+U)
                     V = W/FF*(ONE+V)
                     F0 = F0 - ONE
                     FF = FF - TWO
   60             CONTINUE
                  V = C1*(X+X)*(((U*V+(U+V))+HALF)+HALF)
                  U = FUNC1(X)
               ELSE
C-----------------------------------------------------------------
C  Test erfc or scaled erfc against expansion in repeated
C   integrals of the coerror function.
C-----------------------------------------------------------------
                  Z = X + HALF
                  X = Z - HALF
                  R = ZERO
                  IF (X .LE. ONE) THEN
                        N0 = 499
                     ELSE
                        N0 = MIN(499,INT(C/(ABS(LOG(Z)))))
                  END IF
                  N1 = N0 
                  XN1 = CONV(N1+1)
                  DO 100 K=1,N0
                     R = HALF/(Z+XN1*R)
                     R1(N1) = R
                     N1 = N1 - 1
                     XN1 = XN1 - ONE
  100             CONTINUE
                  FF = C1/(Z+R1(1))
                  IF ((J/2)*2 .EQ. J) THEN
                        F0 = FUNC2(Z)*EXP(X+HALF*HALF)
                        U = FUNC2(X)
                     ELSE
                        F0 = FUNC3(Z) 
                        U = FUNC3(X)
                  END IF 
                  SC = F0/FF
C-----------------------------------------------------------------
C  Scale things to avoid premature underflow
C-----------------------------------------------------------------
                  EPSCON = F0 
                  FF = SIXTEN*FF/EPS
                  DO 110 N1=1,N0
                     FF = R1(N1)*FF
                     R1(N1) = FF * SC
                     IF (R1(N1) .LT. EPSCON ) THEN
                        K = N1
                        GO TO 111
                     END IF
  110             CONTINUE
  111             V = R1(K)
                  DO 120 N1 = 1, K-1
                     V = V + R1(K-N1)
  120             CONTINUE
C-----------------------------------------------------------------
C  Remove scaling here
C-----------------------------------------------------------------
                  V = V*EPS/SIXTEN + F0
            END IF
C--------------------------------------------------------------------
C  Accumulate results
C--------------------------------------------------------------------
            W = (U - V) / U
            IF (W .GT. ZERO) THEN
                  K1 = K1 + 1
               ELSE IF (W .LT. ZERO) THEN
                  K3 = K3 + 1
            END IF
            W = ABS(W)
            IF (W .GT. R6) THEN
                  R6 = W
                  XC = X
            END IF
            R7 = R7 + W * W
            XL = XL + DEL
  200    CONTINUE
C------------------------------------------------------------------
C  Gather and print statistics for test
C------------------------------------------------------------------
         K2 = N - K3 - K1
         R7 = SQRT(R7/XN)
         IF (J .EQ. 1) THEN
               WRITE (IOUT,1000)
               WRITE (IOUT,1010) N,A,B
               WRITE (IOUT,1011) K1
            ELSE IF ((J/2)*2 .EQ. J) THEN
               WRITE (IOUT,1001)
               WRITE (IOUT,1010) N,A,B
               WRITE (IOUT,1012) K1
            ELSE
               WRITE (IOUT,1002)
               WRITE (IOUT,1010) N,A,B
               WRITE (IOUT,1013) K1
         END IF
         WRITE (IOUT,1015) K2,K3
         WRITE (IOUT,1020) IT,IBETA
         IF (R6 .NE. ZERO) THEN
               W = LOG(ABS(R6))/ALBETA
            ELSE
               W = X99
         END IF
         WRITE (IOUT,1021) R6,IBETA,W,XC
         W = MAX(AIT+W,ZERO)
         WRITE (IOUT,1022) IBETA,W
         IF (R7 .NE. ZERO) THEN
               W = LOG(ABS(R7))/ALBETA
            ELSE
               W = X99
         END IF
         WRITE (IOUT,1023) R7,IBETA,W
         W = MAX(AIT+W,ZERO)
         WRITE (IOUT,1022) IBETA,W
C------------------------------------------------------------------
C  Initialize for next test
C------------------------------------------------------------------
         IF (J .EQ. 1) THEN
               A = B
               B = TWO
            ELSE IF (J .EQ. 3) THEN
               A = B
               B = AINT(XBIG*SIXTEN)/SIXTEN-HALF
            ELSE IF (J .EQ. 4) THEN
               B = TEN + TEN
         END IF
  300 CONTINUE
C-----------------------------------------------------------------
C  Special tests
C  First check values for negative arguments.
C-----------------------------------------------------------------
      WRITE (IOUT,1025)
      WRITE (IOUT,1030) IBETA
      X = ZERO
      DEL = -HALF
      DO 350 I = 1, 10
         U = FUNC1(X)
         A = U + FUNC1(-X)
         IF (A*U .NE. ZERO) A = AIT + LOG(ABS(A/U))/ALBETA
         V = FUNC2(X)
         B = U + V - ONE
         IF (B .NE. ZERO) B = AIT + LOG(ABS(B))/ALBETA
         W = FUNC3(X)
         C = AINT(X*SIXTEN)/SIXTEN
         R = (X-C)*(X+C)
         C = (EXP(C*C)*EXP(R)*V-W)/W
         IF (C .NE. ZERO) C = MAX(ZERO,AIT + LOG(ABS(C))/ALBETA)
         WRITE (IOUT,1031) X,A,B,C
         X = X + DEL
  350 CONTINUE
C-----------------------------------------------------------------
C  Next, test with special arguments
C-----------------------------------------------------------------
      WRITE (IOUT,1040)
      Z = XMAX
      ZZ = FUNC1(Z)
      WRITE (IOUT,1041) Z,ZZ
      Z = ZERO
      ZZ = FUNC1(Z)
      WRITE (IOUT,1041) Z,ZZ
      ZZ = FUNC2(Z)
      WRITE (IOUT,1042) Z,ZZ
      Z = -XMAX
      ZZ = FUNC2(Z)
      WRITE (IOUT,1042) Z,ZZ
C-----------------------------------------------------------------
C  Test of error returns
C-----------------------------------------------------------------
      WRITE (IOUT,1050)
      W = XBIG
      Z = W*(ONE-HALF*HALF)
      WRITE (IOUT,1052) Z
      ZZ = FUNC2(Z)
      WRITE (IOUT,1062) ZZ
      Z = W*(ONE+TEN*EPS)
      WRITE (IOUT,1053) Z
      ZZ = FUNC2(Z)
      WRITE (IOUT,1062) ZZ
      W = XMAX
      IF (C1 .LT. XMAX*XMIN) W = C1/XMIN
      Z = W*(ONE-ONE/SIXTEN)
      WRITE (IOUT,1054) Z
      ZZ = FUNC3(Z)
      WRITE (IOUT,1064) ZZ
      W = -SQRT(LOG(XMAX/TWO))
      Z = W*(ONE-ONE/TEN)
      WRITE (IOUT,1055) Z
      ZZ = FUNC3(Z)
      WRITE (IOUT,1064) ZZ
      Z = W*(ONE+TEN*EPS)
      WRITE (IOUT,1056) Z
      ZZ = FUNC3(Z)
      WRITE (IOUT,1064) ZZ
      WRITE (IOUT,1100)
      STOP
C-----------------------------------------------------------------
 1000 FORMAT('1Test of erf(x) vs double series expansion'//)
 1001 FORMAT(///' Test of erfc(x) vs exp(x+1/4) SUM i^n erfc(x+1/2)'//)
 1002 FORMAT('1Test of exp(x*x) erfc(x) vs SUM i^n erfc(x+1/2)'//)
 1010 FORMAT(I7,' Random arguments were tested from the interval (',
     1    F7.3,',',F7.3,')'//)
 1011 FORMAT('    ERF(X) was larger',I6,' times,')
 1012 FORMAT('   ERFC(X) was larger',I6,' times,')
 1013 FORMAT('  ERFCX(X) was larger',I6,' times,')
 1015 FORMAT(14X,' agreed',I6,' times, and'/
     1    10X,'was smaller',I6,' times.'//)
 1020 FORMAT(' There are',I4,' base',I4,
     1    ' significant digits in a floating-point number'//)
 1021 FORMAT(' The maximum relative error of',E15.4,' = ',I4,' **',
     1    F7.2/4X,'occurred for X =',E13.6)
 1022 FORMAT(' The estimated loss of base',I4,
     1    ' significant digits is',F7.2//)
 1023 FORMAT(' The root mean square relative error was',E15.4,
     1    ' = ',I4,' **',F7.2)
 1025 FORMAT('1Special Tests'//)
 1030 FORMAT(7X,'Estimated loss of base',i3,'significant digits in'//
     1       3X'X',5X,'Erf(x)+Erf(-x)',3X,'Erf(x)+Erfc(x)-1',
     1       3X,'Erfcx(x)-exp(x*x)*erfc(x)'/)
 1031 FORMAT(F7.3,3F16.2)
 1040 FORMAT(//' Test of special arguments'//)
 1041 FORMAT('   ERF (',E13.6,') = ',E13.6//)
 1042 FORMAT('  ERFC (',E13.6,') = ',E13.6//)
 1050 FORMAT(' Test of Error Returns'///)
 1052 FORMAT(' ERFC will be called with the argument',E13.6,/
     1    ' This should not underflow'//)
 1053 FORMAT(' ERFC will be called with the argument',E13.6,/
     1    ' This may underflow'//)
 1054 FORMAT(' ERFCX will be called with the argument',E13.6,/
     1    ' This should not underflow'//)
 1055 FORMAT(' ERFCX will be called with the argument',E13.6,/
     1    ' This should not overflow'//)
 1056 FORMAT(' ERFCX will be called with the argument',E13.6,/
     1    ' This may overflow'//)
 1062 FORMAT(' ERFC returned the value',E13.6///)
 1064 FORMAT(' ERFCX returned the value',E13.6///)
 1100 FORMAT(' This concludes the tests')
C---------- Last line of ERF test program ----------
      END




CS    REAL FUNCTION GAMMA(X)
CD    DOUBLE PRECISION FUNCTION DGAMMA(X)
C----------------------------------------------------------------------
C
C This routine calculates the GAMMA function for a real argument X.
C   Computation is based on an algorithm outlined in reference 1.
C   The program uses rational functions that approximate the GAMMA
C   function to at least 20 significant decimal digits.  Coefficients
C   for the approximation over the interval (1,2) are unpublished.
C   Those for the approximation for X .GE. 12 are from reference 2.
C   The accuracy achieved depends on the arithmetic system, the
C   compiler, the intrinsic functions, and proper selection of the
C   machine-dependent constants.
C
C
C*******************************************************************
C*******************************************************************
C
C Explanation of machine-dependent constants.  Let
C
C beta   - radix for the floating-point representation
C maxexp - the smallest positive power of beta that overflows
C
C Then the following machine-dependent constants must be declared 
C   in DATA statements.  IEEE values are provided as a default.
C
C XBIG   - the largest argument for which GAMMA(X) is representable
C          in the machine, i.e., the solution to the equation
C                  GAMMA(XBIG) = beta**maxexp
C XINF   - the largest machine representable floating-point number;
C          approximately beta**maxexp
C EPS    - the smallest positive floating-point number such that
C          1.0+EPS .GT. 1.0
C XMININ - the smallest positive floating-point number such that
C          1/XMININ is machine representable
C
C     Approximate values for some important machines are:
C
C                            beta       maxexp        XBIG
C
C CRAY-1         (S.P.)        2         8191        966.961
C Cyber 180/855
C   under NOS    (S.P.)        2         1070        177.803
C IEEE (IBM/XT,
C   SUN, etc.)   (S.P.)        2          128        35.040
C IEEE (IBM/XT,
C   SUN, etc.)   (D.P.)        2         1024        171.624
C IBM 3033       (D.P.)       16           63        57.574
C VAX D-Format   (D.P.)        2          127        34.844
C VAX G-Format   (D.P.)        2         1023        171.489
C
C                            XINF         EPS        XMININ
C
C CRAY-1         (S.P.)   5.45E+2465   7.11E-15    1.84E-2466
C Cyber 180/855
C   under NOS    (S.P.)   1.26E+322    3.55E-15    3.14E-294
C IEEE (IBM/XT,
C   SUN, etc.)   (S.P.)   3.40E+38     1.19E-7     1.18E-38
C IEEE (IBM/XT,
C   SUN, etc.)   (D.P.)   1.79D+308    2.22D-16    2.23D-308
C IBM 3033       (D.P.)   7.23D+75     2.22D-16    1.39D-76
C VAX D-Format   (D.P.)   1.70D+38     1.39D-17    5.88D-39
C VAX G-Format   (D.P.)   8.98D+307    1.11D-16    1.12D-308
C
C*******************************************************************
C*******************************************************************
C
C Error returns
C
C  The program returns the value XINF for singularities or
C     when overflow would occur.  The computation is believed
C     to be free of underflow and overflow.
C
C
C  Intrinsic functions required are:
C
C     INT, DBLE, EXP, LOG, REAL, SIN
C
C
C References: "An Overview of Software Development for Special
C              Functions", W. J. Cody, Lecture Notes in Mathematics,
C              506, Numerical Analysis Dundee, 1975, G. A. Watson
C              (ed.), Springer Verlag, Berlin, 1976.
C
C              Computer Approximations, Hart, Et. Al., Wiley and
C              sons, New York, 1968.
C
C  Latest modification: March 12, 1992
C
C  Authors: W. J. Cody and L. Stoltz
C           Applied Mathematics Division
C           Argonne National Laboratory
C           Argonne, IL 60439
C
C----------------------------------------------------------------------
      INTEGER I,N
      LOGICAL PARITY
CS    REAL 
CD    DOUBLE PRECISION 
     1    C,CONV,EPS,FACT,HALF,ONE,P,PI,Q,RES,SQRTPI,SUM,TWELVE,
     2    TWO,X,XBIG,XDEN,XINF,XMININ,XNUM,Y,Y1,YSQ,Z,ZERO
      DIMENSION C(7),P(8),Q(8)
C----------------------------------------------------------------------
C  Mathematical constants
C----------------------------------------------------------------------
CS    DATA ONE,HALF,TWELVE,TWO,ZERO/1.0E0,0.5E0,12.0E0,2.0E0,0.0E0/,
CS   1     SQRTPI/0.9189385332046727417803297E0/,
CS   2     PI/3.1415926535897932384626434E0/
CD    DATA ONE,HALF,TWELVE,TWO,ZERO/1.0D0,0.5D0,12.0D0,2.0D0,0.0D0/,
CD   1     SQRTPI/0.9189385332046727417803297D0/,
CD   2     PI/3.1415926535897932384626434D0/
C----------------------------------------------------------------------
C  Machine dependent parameters
C----------------------------------------------------------------------
CS    DATA XBIG,XMININ,EPS/35.040E0,1.18E-38,1.19E-7/,
CS   1     XINF/3.4E38/
CD    DATA XBIG,XMININ,EPS/171.624D0,2.23D-308,2.22D-16/,
CD   1     XINF/1.79D308/
C----------------------------------------------------------------------
C  Numerator and denominator coefficients for rational minimax
C     approximation over (1,2).
C----------------------------------------------------------------------
CS    DATA P/-1.71618513886549492533811E+0,2.47656508055759199108314E+1,
CS   1       -3.79804256470945635097577E+2,6.29331155312818442661052E+2,
CS   2       8.66966202790413211295064E+2,-3.14512729688483675254357E+4,
CS   3       -3.61444134186911729807069E+4,6.64561438202405440627855E+4/
CS    DATA Q/-3.08402300119738975254353E+1,3.15350626979604161529144E+2,
CS   1      -1.01515636749021914166146E+3,-3.10777167157231109440444E+3,
CS   2        2.25381184209801510330112E+4,4.75584627752788110767815E+3,
CS   3      -1.34659959864969306392456E+5,-1.15132259675553483497211E+5/
CD    DATA P/-1.71618513886549492533811D+0,2.47656508055759199108314D+1,
CD   1       -3.79804256470945635097577D+2,6.29331155312818442661052D+2,
CD   2       8.66966202790413211295064D+2,-3.14512729688483675254357D+4,
CD   3       -3.61444134186911729807069D+4,6.64561438202405440627855D+4/
CD    DATA Q/-3.08402300119738975254353D+1,3.15350626979604161529144D+2,
CD   1      -1.01515636749021914166146D+3,-3.10777167157231109440444D+3,
CD   2        2.25381184209801510330112D+4,4.75584627752788110767815D+3,
CD   3      -1.34659959864969306392456D+5,-1.15132259675553483497211D+5/
C----------------------------------------------------------------------
C  Coefficients for minimax approximation over (12, INF).
C----------------------------------------------------------------------
CS    DATA C/-1.910444077728E-03,8.4171387781295E-04,
CS   1     -5.952379913043012E-04,7.93650793500350248E-04,
CS   2     -2.777777777777681622553E-03,8.333333333333333331554247E-02,
CS   3      5.7083835261E-03/
CD    DATA C/-1.910444077728D-03,8.4171387781295D-04,
CD   1     -5.952379913043012D-04,7.93650793500350248D-04,
CD   2     -2.777777777777681622553D-03,8.333333333333333331554247D-02,
CD   3      5.7083835261D-03/
C----------------------------------------------------------------------
C  Statement functions for conversion between integer and float
C----------------------------------------------------------------------
CS    CONV(I) = REAL(I)
CD    CONV(I) = DBLE(I)
      PARITY = .FALSE.
      FACT = ONE
      N = 0
      Y = X
      IF (Y .LE. ZERO) THEN
C----------------------------------------------------------------------
C  Argument is negative
C----------------------------------------------------------------------
            Y = -X
            Y1 = AINT(Y)
            RES = Y - Y1
            IF (RES .NE. ZERO) THEN
                  IF (Y1 .NE. AINT(Y1*HALF)*TWO) PARITY = .TRUE.
                  FACT = -PI / SIN(PI*RES)
                  Y = Y + ONE
               ELSE
                  RES = XINF
                  GO TO 900
            END IF
      END IF
C----------------------------------------------------------------------
C  Argument is positive
C----------------------------------------------------------------------
      IF (Y .LT. EPS) THEN
C----------------------------------------------------------------------
C  Argument .LT. EPS
C----------------------------------------------------------------------
            IF (Y .GE. XMININ) THEN
                  RES = ONE / Y
               ELSE
                  RES = XINF
                  GO TO 900
            END IF
         ELSE IF (Y .LT. TWELVE) THEN
            Y1 = Y
            IF (Y .LT. ONE) THEN
C----------------------------------------------------------------------
C  0.0 .LT. argument .LT. 1.0
C----------------------------------------------------------------------
                  Z = Y
                  Y = Y + ONE
               ELSE
C----------------------------------------------------------------------
C  1.0 .LT. argument .LT. 12.0, reduce argument if necessary
C----------------------------------------------------------------------
                  N = INT(Y) - 1
                  Y = Y - CONV(N)
                  Z = Y - ONE
            END IF
C----------------------------------------------------------------------
C  Evaluate approximation for 1.0 .LT. argument .LT. 2.0
C----------------------------------------------------------------------
            XNUM = ZERO
            XDEN = ONE
            DO 260 I = 1, 8
               XNUM = (XNUM + P(I)) * Z
               XDEN = XDEN * Z + Q(I)
  260       CONTINUE
            RES = XNUM / XDEN + ONE
            IF (Y1 .LT. Y) THEN
C----------------------------------------------------------------------
C  Adjust result for case  0.0 .LT. argument .LT. 1.0
C----------------------------------------------------------------------
                  RES = RES / Y1
               ELSE IF (Y1 .GT. Y) THEN
C----------------------------------------------------------------------
C  Adjust result for case  2.0 .LT. argument .LT. 12.0
C----------------------------------------------------------------------
                  DO 290 I = 1, N
                     RES = RES * Y
                     Y = Y + ONE
  290             CONTINUE
            END IF
         ELSE
C----------------------------------------------------------------------
C  Evaluate for argument .GE. 12.0,
C----------------------------------------------------------------------
            IF (Y .LE. XBIG) THEN
                  YSQ = Y * Y
                  SUM = C(7)
                  DO 350 I = 1, 6
                     SUM = SUM / YSQ + C(I)
  350             CONTINUE
                  SUM = SUM/Y - Y + SQRTPI
                  SUM = SUM + (Y-HALF)*LOG(Y)
                  RES = EXP(SUM)
               ELSE
                  RES = XINF
                  GO TO 900
            END IF
      END IF
C----------------------------------------------------------------------
C  Final adjustments and return
C----------------------------------------------------------------------
      IF (PARITY) RES = -RES
      IF (FACT .NE. ONE) RES = FACT / RES
CS900 GAMMA = RES
CD900 DGAMMA = RES
      RETURN
C ---------- Last line of GAMMA ----------
      END
      PROGRAM GAMTST
C------------------------------------------------------------------
C FORTRAN 77 program to test GAMMA or DGAMMA
C
C   Method:
C
C      Accuracy tests compare function values against values
C      generated with the duplication formula.
C
C   Data required
C
C      None
C
C   Subprograms required from this package
C
C     MACHAR - An environmental inquiry program providing
C              information on the floating-point arithmetic
C              system.  Note that the call to MACHAR can
C              be deleted provided the following five
C              parameters are assigned the values indicated
C
C              IBETA  - The radix of the floating-point system
C              IT     - The number of base-ibeta digits in the 
C                       significant of a floating-point number
C              EPS    - The smallest positive floating-point
C                       number such that 1.0+EPS .NE. 1.0
C              XMIN   - The smallest non-vanishing floating-point
C                       integral power of the radix
C              XMAX   - The largest finite floating-point number
C
C     REN(K) - A function subprogram returning random real
C              numbers uniformly distributed over (0,1)
C
C
C  Intrinsic functions required are:
C
C      ABS, DBLE, INT, LOG, MAX, REAL, SQRT
C
C  Reference: "Performance evaluation of programs related
C              to the real gamma function", W. J. Cody, 
C              submitted for publication.
C
C  Latest modification: March 12, 1992
C
C  Authors: W. J. Cody and L. Stoltz
C           Mathematics and Computer Science Division 
C           Argonne National Laboratory
C           Argonne, IL 60439
C
C--------------------------------------------------------------------
      INTEGER I,IBETA,IEXP,IOUT,IRND,IT,J,JT,K1,K2,K3,
     1        MACHEP,MAXEXP,MINEXP,N,NEGEP,NGRD,NX
CS    REAL  GAMMA,
CD    DOUBLE PRECISION  DGAMMA,
     1    A,AIT,ALBETA,ALNX,B,BETA,C,CL,CONV,C1,C2,DEL,EPS,
     2    EPSNEG,FUNC,HALF,ONE,REN,R6,R7,TEN,TWO,W,X,XC,XL, 
     3    XMAX,XMIN,XMINV,XN,XNUM,XXN,XP,XPH,X99,XP99,Y,Z,ZERO,ZZ 
CS    DATA C1,C2/2.8209479177387814347E-1,9.1893853320467274178E-1/,
CS   1     ZERO,HALF,ONE,TWO,TEN/0.0E0,0.5E0,1.0E0,2.0E0,10.0E0/,
CS   2     X99,XP99/-999.0E0,0.99E0/
CD    DATA C1,C2/2.8209479177387814347D-1,9.1893853320467274178D-1/,
CD   1     ZERO,HALF,ONE,TWO,TEN/0.0D0,0.5D0,1.0D0,2.0D0,10.0D0/,
CD   2     X99,XP99/-999.0D0,0.99D0/
      DATA IOUT/6/
C------------------------------------------------------------------
C  Statement functions for conversion
C------------------------------------------------------------------
CS    CONV(I) = REAL(I)
CD    CONV(I) = DBLE(I)
CS    FUNC(X) = GAMMA(X)
CD    FUNC(X) = DGAMMA(X)
C------------------------------------------------------------------
C  Determine machine parameters and set constants
C------------------------------------------------------------------
      CALL MACHAR(IBETA,IT,IRND,NGRD,MACHEP,NEGEP,IEXP,MINEXP,
     1            MAXEXP,EPS,EPSNEG,XMIN,XMAX)
      BETA = CONV(IBETA)
      ALBETA = LOG(BETA)
      AIT = CONV(IT)
      A = ZERO
      B = TWO
      N = 2000
      XN = CONV(N)
      JT = 0
C-----------------------------------------------------------------
C  Determine smallest argument for GAMMA
C-----------------------------------------------------------------
      IF (XMIN*XMAX .LT. ONE) THEN
            XMINV = ONE/XMAX
         ELSE
            XMINV = XMIN
      END IF
C-----------------------------------------------------------------
C  Determine largest argument for GAMMA by Newton iteration
C-----------------------------------------------------------------
      CL = LOG(XMAX)
      XP = HALF * CL
      CL = C2 - CL
   50 X = XP
         ALNX = LOG(X)
         XNUM = (X-HALF)*ALNX - X + CL
         XP = X - XNUM/(ALNX-HALF/X)
         IF (ABS(XP-X)/X .GE. TEN*EPS) GO TO 50
      CL = XP
C-----------------------------------------------------------------
C  Random argument accuracy tests
C-----------------------------------------------------------------
      DO 300 J = 1, 4
         K1 = 0
         K3 = 0
         XC = ZERO
         R6 = ZERO
         R7 = ZERO
         DEL = (B - A) / XN
         XL = A
         DO 200 I = 1, N
            X = DEL * REN(JT) + XL
C-----------------------------------------------------------------
C  Use duplication formula for X not close to the zero
C-----------------------------------------------------------------
            XPH = X * HALF + HALF
            XP = XPH - HALF
            X = XP + XP
            NX = INT(X)
            XXN = CONV(NX)
            C = (TWO ** NX) * (TWO ** (X-XXN))
            Z = FUNC(X)
            ZZ = ((C*C1)*FUNC(XP)) * FUNC(XPH)
C--------------------------------------------------------------------
C  Accumulate results
C--------------------------------------------------------------------
            W = (Z - ZZ) / Z
            IF (W .GT. ZERO) THEN
                  K1 = K1 + 1
               ELSE IF (W .LT. ZERO) THEN
                  K3 = K3 + 1
            END IF
            W = ABS(W)
            IF (W .GT. R6) THEN
                  R6 = W
                  XC = X
            END IF
            R7 = R7 + W * W
            XL = XL + DEL
  200    CONTINUE
C------------------------------------------------------------------
C  Gather and print statistics for test
C------------------------------------------------------------------
         K2 = N - K3 - K1
         R7 = SQRT(R7/XN)
         WRITE (IOUT,1000)
         WRITE (IOUT,1010) N,A,B
         WRITE (IOUT,1011) K1,K2,K3
         WRITE (IOUT,1020) IT,IBETA
         IF (R6 .NE. ZERO) THEN
               W = LOG(ABS(R6))/ALBETA
            ELSE
               W = X99
         END IF
         WRITE (IOUT,1021) R6,IBETA,W,XC
         W = MAX(AIT+W,ZERO)
         WRITE (IOUT,1022) IBETA,W
         IF (R7 .NE. ZERO) THEN
               W = LOG(ABS(R7))/ALBETA
            ELSE
               W = X99
         END IF
         WRITE (IOUT,1023) R7,IBETA,W
         W = MAX(AIT+W,ZERO)
         WRITE (IOUT,1022) IBETA,W
C------------------------------------------------------------------
C  Initialize for next test
C------------------------------------------------------------------
         A = B
         IF (J .EQ. 1) THEN
               B = TEN
            ELSE IF (J .EQ. 2) THEN
               B = CL - HALF
            ELSE
               A = -(TEN-HALF) * HALF
               B = A + HALF
         END IF
  300 CONTINUE
C-----------------------------------------------------------------
C  Special tests
C  First test with special arguments
C-----------------------------------------------------------------
      WRITE (IOUT,1025)
      WRITE (IOUT,1040)
      X = -HALF
      Y = FUNC(X)
      WRITE (IOUT,1041) X, Y
      X = XMINV / XP99
      Y = FUNC(X)
      WRITE (IOUT,1041) X, Y
      X = ONE
      Y = FUNC(X)
      WRITE (IOUT,1041) X, Y
      X = TWO
      Y = FUNC(X)
      WRITE (IOUT,1041) X, Y
      X = CL * XP99
      Y = FUNC(X)
      WRITE (IOUT,1041) X, Y
C-----------------------------------------------------------------
C  Test of error returns
C-----------------------------------------------------------------
      WRITE (IOUT,1050)
      X = -ONE
      WRITE (IOUT,1052) X
      Y = FUNC(X)
      WRITE (IOUT,1061) Y
      X = ZERO
      WRITE (IOUT,1052) X
      Y = FUNC(X)
      WRITE (IOUT,1061) Y
      X = XMINV * (ONE - EPS)
      WRITE (IOUT,1052) X
      Y = FUNC(X)
      WRITE (IOUT,1061) Y
      X = CL * (ONE + EPS)
      WRITE (IOUT,1052) X
      Y = FUNC(X)
      WRITE (IOUT,1061) Y
      WRITE (IOUT,1100)
      STOP
C-----------------------------------------------------------------
 1000 FORMAT('1Test of GAMMA(X) vs Duplication Formula'//)
 1010 FORMAT(I7,' Random arguments were tested from the interval (',
     1    F7.3,',',F7.3,')'//)
 1011 FORMAT(' GAMMA(X) was larger',I6,' times,'/
     1    13X,' agreed',I6,' times, and'/
     2    9X,'was smaller',I6,' times.'//)
 1020 FORMAT(' There are',I4,' base',I4,
     1    ' significant digits in a floating-point number'//)
 1021 FORMAT(' The maximum relative error of',E15.4,' = ',I4,' **',
     1    F7.2/4X,'occurred for X =',E13.6)
 1022 FORMAT(' The estimated loss of base',I4,
     1    ' significant digits is',F7.2//)
 1023 FORMAT(' The root mean square relative error was',E15.4,
     1    ' = ',I4,' **',F7.2)
 1025 FORMAT('1Special Tests'//)
 1040 FORMAT(//' Test of special arguments'//)
 1041 FORMAT(' GAMMA (',E13.6,') = ',E13.6//)
 1050 FORMAT('1Test of Error Returns'///)
 1052 FORMAT(' GAMMA will be called with the argument',E13.6,/
     1    ' This should trigger an error message'//)
 1061 FORMAT(' GAMMA returned the value',E13.6///)
 1100 FORMAT(' This concludes the tests')
C---------- Last line of GAMMA test program ----------
      END
      SUBROUTINE CALCI0(ARG,RESULT,JINT)
C--------------------------------------------------------------------
C
C This packet computes modified Bessel functions of the first kind
C   and order zero, I0(X) and EXP(-ABS(X))*I0(X), for real
C   arguments X.  It contains two function type subprograms, BESI0
C   and BESEI0, and one subroutine type subprogram, CALCI0.
C   The calling statements for the primary entries are
C
C                   Y=BESI0(X)
C   and
C                   Y=BESEI0(X)
C
C   where the entry points correspond to the functions I0(X) and
C   EXP(-ABS(X))*I0(X), respectively.  The routine CALCI0 is
C   intended for internal packet use only, all computations within
C   the packet being concentrated in this routine.  The function
C   subprograms invoke CALCI0 with the statement
C          CALL CALCI0(ARG,RESULT,JINT)
C   where the parameter usage is as follows
C
C      Function                     Parameters for CALCI0
C       Call              ARG                  RESULT          JINT
C
C     BESI0(ARG)    ABS(ARG) .LE. XMAX        I0(ARG)           1
C     BESEI0(ARG)    any real ARG        EXP(-ABS(ARG))*I0(ARG) 2
C
C   The main computation evaluates slightly modified forms of
C   minimax approximations generated by Blair and Edwards, Chalk
C   River (Atomic Energy of Canada Limited) Report AECL-4928,
C   October, 1974.  This transportable program is patterned after
C   the machine-dependent FUNPACK packet NATSI0, but cannot match
C   that version for efficiency or accuracy.  This version uses
C   rational functions that theoretically approximate I-SUB-0(X)
C   to at least 18 significant decimal digits.  The accuracy
C   achieved depends on the arithmetic system, the compiler, the
C   intrinsic functions, and proper selection of the machine-
C   dependent constants.
C
C*******************************************************************
C*******************************************************************
C
C Explanation of machine-dependent constants.  Let
C
C   beta   = Radix for the floating-point system
C   maxexp = Smallest power of beta that overflows
C
C Then the following machine-dependent constants must be declared
C   in DATA statements.  IEEE values are provided as a default.
C
C   XSMALL = Positive argument such that 1.0 - X = 1.0 to
C            machine precision for all ABS(X) .LE. XSMALL.
C   XINF =   Largest positive machine number; approximately
C            beta**maxexp
C   XMAX =   Largest argument acceptable to BESI0;  Solution to
C            equation:
C               W(X) * (1+1/(8*X)+9/(128*X**2) = beta**maxexp
C            where  W(X) = EXP(X)/SQRT(2*PI*X)
C
C
C     Approximate values for some important machines are:
C
C                          beta       maxexp       XSMALL
C
C CRAY-1        (S.P.)       2         8191       3.55E-15
C Cyber 180/855
C   under NOS   (S.P.)       2         1070       3.55E-15
C IEEE (IBM/XT,
C   SUN, etc.)  (S.P.)       2          128       2.98E-8
C IEEE (IBM/XT,
C   SUN, etc.)  (D.P.)       2         1024       5.55D-17
C IBM 3033      (D.P.)      16           63       6.95D-18
C VAX           (S.P.)       2          127       2.98E-8
C VAX D-Format  (D.P.)       2          127       6.95D-18
C VAX G-Format  (D.P.)       2         1023       5.55D-17
C
C
C                               XINF          XMAX
C
C CRAY-1        (S.P.)       5.45E+2465     5682.810
C Cyber 180/855
C   under NOS   (S.P.)       1.26E+322       745.893
C IEEE (IBM/XT,
C   SUN, etc.)  (S.P.)       3.40E+38         91.900
C IEEE (IBM/XT,
C   SUN, etc.)  (D.P.)       1.79D+308       713.986
C IBM 3033      (D.P.)       7.23D+75        178.182
C VAX           (S.P.)       1.70D+38         91.203
C VAX D-Format  (D.P.)       1.70D+38         91.203
C VAX G-Format  (D.P.)       8.98D+307       713.293
C
C*******************************************************************
C*******************************************************************
C
C Error returns
C
C  The program returns XINF for BESI0 for ABS(ARG) .GT. XMAX.
C
C
C  Intrinsic functions required are:
C
C     ABS, SQRT, EXP
C
C
C  Authors: W. J. Cody and L. Stoltz
C           Mathematics and Computer Science Division
C           Argonne National Laboratory
C           Argonne, IL 60439
C
C  Latest modification: March 12, 1992
C
C--------------------------------------------------------------------
      INTEGER I,JINT
CS    REAL
CD    DOUBLE PRECISION
     1       A,ARG,B,EXP40,FORTY,ONE,ONE5,P,PP,Q,QQ,RESULT,
     2       REC15,SUMP,SUMQ,TWO25,X,XINF,XMAX,XSMALL,XX
      DIMENSION P(15),PP(8),Q(5),QQ(7)
C--------------------------------------------------------------------
C  Mathematical constants
C--------------------------------------------------------------------
CS    DATA ONE/1.0E0/,ONE5/15.0E0/,EXP40/2.353852668370199854E17/,
CS   1     FORTY/40.0E0/,REC15/6.6666666666666666666E-2/,
CS   2     TWO25/225.0E0/
CD    DATA ONE/1.0D0/,ONE5/15.0D0/,EXP40/2.353852668370199854D17/,
CD   1     FORTY/40.0D0/,REC15/6.6666666666666666666D-2/,
CD   2     TWO25/225.0D0/
C--------------------------------------------------------------------
C  Machine-dependent constants
C--------------------------------------------------------------------
CS    DATA XSMALL/2.98E-8/,XINF/3.40E38/,XMAX/91.9E0/
CD    DATA XSMALL/5.55D-17/,XINF/1.79D308/,XMAX/713.986D0/
C--------------------------------------------------------------------
C  Coefficients for XSMALL .LE. ABS(ARG) .LT. 15.0
C--------------------------------------------------------------------
CS    DATA  P/-5.2487866627945699800E-18,-1.5982226675653184646E-14,
CS   1        -2.6843448573468483278E-11,-3.0517226450451067446E-08,
CS   2        -2.5172644670688975051E-05,-1.5453977791786851041E-02,
CS   3        -7.0935347449210549190E+00,-2.4125195876041896775E+03,
CS   4        -5.9545626019847898221E+05,-1.0313066708737980747E+08,
CS   5        -1.1912746104985237192E+10,-8.4925101247114157499E+11,
CS   6        -3.2940087627407749166E+13,-5.5050369673018427753E+14,
CS   7        -2.2335582639474375249E+15/
CS    DATA  Q/-3.7277560179962773046E+03, 6.5158506418655165707E+06,
CS   1        -6.5626560740833869295E+09, 3.7604188704092954661E+12,
CS   2        -9.7087946179594019126E+14/
CD    DATA  P/-5.2487866627945699800D-18,-1.5982226675653184646D-14,
CD   1        -2.6843448573468483278D-11,-3.0517226450451067446D-08,
CD   2        -2.5172644670688975051D-05,-1.5453977791786851041D-02,
CD   3        -7.0935347449210549190D+00,-2.4125195876041896775D+03,
CD   4        -5.9545626019847898221D+05,-1.0313066708737980747D+08,
CD   5        -1.1912746104985237192D+10,-8.4925101247114157499D+11,
CD   6        -3.2940087627407749166D+13,-5.5050369673018427753D+14,
CD   7        -2.2335582639474375249D+15/
CD    DATA  Q/-3.7277560179962773046D+03, 6.5158506418655165707D+06,
CD   1        -6.5626560740833869295D+09, 3.7604188704092954661D+12,
CD   2        -9.7087946179594019126D+14/
C--------------------------------------------------------------------
C  Coefficients for 15.0 .LE. ABS(ARG)
C--------------------------------------------------------------------
CS    DATA PP/-3.9843750000000000000E-01, 2.9205384596336793945E+00,
CS   1        -2.4708469169133954315E+00, 4.7914889422856814203E-01,
CS   2        -3.7384991926068969150E-03,-2.6801520353328635310E-03,
CS   3         9.9168777670983678974E-05,-2.1877128189032726730E-06/
CS    DATA QQ/-3.1446690275135491500E+01, 8.5539563258012929600E+01,
CS   1        -6.0228002066743340583E+01, 1.3982595353892851542E+01,
CS   2        -1.1151759188741312645E+00, 3.2547697594819615062E-02,
CS   3        -5.5194330231005480228E-04/
CD    DATA PP/-3.9843750000000000000D-01, 2.9205384596336793945D+00,
CD   1        -2.4708469169133954315D+00, 4.7914889422856814203D-01,
CD   2        -3.7384991926068969150D-03,-2.6801520353328635310D-03,
CD   3         9.9168777670983678974D-05,-2.1877128189032726730D-06/
CD    DATA QQ/-3.1446690275135491500D+01, 8.5539563258012929600D+01,
CD   1        -6.0228002066743340583D+01, 1.3982595353892851542D+01,
CD   2        -1.1151759188741312645D+00, 3.2547697594819615062D-02,
CD   3        -5.5194330231005480228D-04/
C--------------------------------------------------------------------
      X = ABS(ARG)
      IF (X .LT. XSMALL) THEN
            RESULT = ONE
         ELSE IF (X .LT. ONE5) THEN
C--------------------------------------------------------------------
C  XSMALL .LE.  ABS(ARG)  .LT. 15.0
C--------------------------------------------------------------------
            XX = X * X
            SUMP = P(1)
            DO 50 I = 2, 15
              SUMP = SUMP * XX + P(I)
   50       CONTINUE
            XX = XX - TWO25
            SUMQ = ((((XX+Q(1))*XX+Q(2))*XX+Q(3))*XX+Q(4))*XX+Q(5)
            RESULT = SUMP / SUMQ
            IF (JINT .EQ. 2) RESULT = RESULT * EXP(-X)
         ELSE IF (X .GE. ONE5) THEN
            IF ((JINT .EQ. 1) .AND. (X .GT. XMAX)) THEN
                  RESULT = XINF
               ELSE
C--------------------------------------------------------------------
C  15.0  .LE.  ABS(ARG)
C--------------------------------------------------------------------
                  XX = ONE / X - REC15
                  SUMP = ((((((PP(1)*XX+PP(2))*XX+PP(3))*XX+PP(4))*XX+
     1                   PP(5))*XX+PP(6))*XX+PP(7))*XX+PP(8)
                  SUMQ = ((((((XX+QQ(1))*XX+QQ(2))*XX+QQ(3))*XX+
     1                   QQ(4))*XX+QQ(5))*XX+QQ(6))*XX+QQ(7)
                  RESULT = SUMP / SUMQ
                  IF (JINT .EQ. 2) THEN
                        RESULT = (RESULT - PP(1)) / SQRT(X)
                     ELSE
C--------------------------------------------------------------------
C  Calculation reformulated to avoid premature overflow
C--------------------------------------------------------------------
                        IF (X .LE.(XMAX-ONE5)) THEN
                              A = EXP(X)
                              B = ONE
                           ELSE
                              A = EXP(X-FORTY)
                              B = EXP40
                        END IF
                        RESULT = ((RESULT*A-PP(1)*A)/SQRT(X))*B
                  END IF
            END IF
      END IF
C--------------------------------------------------------------------
C  Return for ABS(ARG) .LT. XSMALL
C--------------------------------------------------------------------
      RETURN
C----------- Last line of CALCI0 -----------
      END
CS    REAL FUNCTION BESI0(X)
CD    DOUBLE PRECISION FUNCTION BESI0(X)
C--------------------------------------------------------------------
C
C This long precision subprogram computes approximate values for
C   modified Bessel functions of the first kind of order zero for
C   arguments ABS(ARG) .LE. XMAX  (see comments heading CALCI0).
C
C--------------------------------------------------------------------
      INTEGER JINT
CS    REAL  
CD    DOUBLE PRECISION  
     1    X, RESULT
C--------------------------------------------------------------------
      JINT=1
      CALL CALCI0(X,RESULT,JINT)
      BESI0=RESULT
      RETURN
C---------- Last line of BESI0 ----------
      END
CS    REAL FUNCTION BESEI0(X)
CD    DOUBLE PRECISION FUNCTION BESEI0(X)
C--------------------------------------------------------------------
C
C This function program computes approximate values for the
C   modified Bessel function of the first kind of order zero
C   multiplied by EXP(-ABS(X)), where EXP is the
C   exponential function, ABS is the absolute value, and X
C   is any argument.
C
C--------------------------------------------------------------------
      INTEGER JINT
CS    REAL  
CD    DOUBLE PRECISION  
     1    X, RESULT
C--------------------------------------------------------------------
      JINT=2
      CALL CALCI0(X,RESULT,JINT)
      BESEI0=RESULT
      RETURN
C---------- Last line of BESEI0 ----------
      END
      PROGRAM I0TEST
C------------------------------------------------------------------
C FORTRAN 77 program to test BESI0, BESEI0
C
C  Method:
C
C     Accuracy tests compare function values against values
C     generated with the multiplication formula for small
C     arguments and values generated from a Taylor's Series
C     Expansion using Amos' Ratio Scheme for initial values
C     for large arguments.
C
C  Data required
C
C     None
C
C  Subprograms required from this package
C
C     MACHAR - An environmental inquiry program providing
C         information on the floating-point arithmetic
C         system.  Note that the call to MACHAR can
C         be deleted provided the following five
C         parameters are assigned the values indicated
C
C              IBETA  - the radix of the floating-point system
C              IT     - the number of base-IBETA digits in the
C                       significant of a floating-point number
C              EPS    - the smallest positive floating-point
C                       number such that 1.0+EPS .NE. 1.0
C              XMIN   - the smallest non-vanishing normalized
C                       floating-point power of the radix
C              XMAX   - the largest finite floating-point number
C
C     REN(K) - a function subprogram returning random real
C              numbers uniformly distributed over (0,1)
C
C
C  Intrinsic functions required are:
C
C      ABS, DBLE, INT, LOG, MAX, REAL, SQRT
C
C  Reference: "Computation of Modified Bessel Functions and
C              Their Ratios," D. E. Amos, Math. of Comp., 
C              Volume 28, Number 24, January, 1974.
C
C             "Performance evaluation of programs for certain
C              Bessel functions", W. J. Cody and L. Stoltz,
C              ACM Trans. on Math. Software, Vol. 15, 1989,
C              pp 41-48.
C
C             "Use of Taylor series to test accuracy of function
C              programs," W. J. Cody and L. Stoltz, submitted
C              for publication.
C
C  Latest modification: March 12, 1992
C
C  Authors:  W. J. Cody and L. Stoltz
C            Mathematics and Computer Science Division 
C            Argonne National Laboratory
C            Argonne, IL 60439
C
C------------------------------------------------------------------
      INTEGER I,IBETA,IEXP,II,IND,IOUT,IRND,IT,J,JT,J1,J2,K1,K2,K3,
     1    MACHEP,MAXEXP,MB,MBORG,MINEXP,MB2,N,NEGEP,NGRD
CS    REAL  
CD    DOUBLE PRECISION  
     1    A,AIT,AK,AKK,ALBETA,ARR,ATETEN,B,BESEI0,BESI0,BETA,BOT,C,
     2    CONST,CONV,D,DEL,DELTA,E,EIGHT,EPS,EPSNEG,F,HALF,HUND,ONE,
     3    OVRCHK,ONE28,REN,R6,R7,SIXTEN,SUM,TEMP,TOP,TWO,T1,T2,U,U2,
     4    W,X,XA,XB,XBAD,XJ1,XL,XLAM,XLARGE,XMAX,XMB,XMIN,XN,XNINE,
     5    X1,X99,Y,Z,ZERO,ZZ
      DIMENSION ARR(8,6),U(560),U2(560) 
CS    DATA ZERO,HALF,ONE,TWO,EIGHT/0.0E0,0.5E0,1.0E0,2.0E0,8.0E0/, 
CS   1   XNINE,SIXTEN,ATETEN,HUND/9.0E0,1.6E1,1.8E1,1.0E2/,
CS   2   ONE28,X99,XLAM,XLARGE/1.28E2,-999.0E0,1.03125E0,1.0E4/,
CS   3   C/0.9189385332E0/
CD    DATA ZERO,HALF,ONE,TWO,EIGHT/0.0D0,0.5D0,1.0D0,2.0D0,8.0D0/, 
CD   1   XNINE,SIXTEN,ATETEN,HUND/9.0D0,1.6D1,1.8D1,1.0D2/,
CD   2   ONE28,X99,XLAM,XLARGE/1.28D2,-999.0D0,1.03125D0,1.0D4/,
CD   3   C/0.9189385332D0/
CS    DATA  ARR/0.0E0,1.0E0,-1.0E0,1.0E0,-2.0E0,1.0E0,-3.0E0,1.0E0,
CS   1          -999.0E0,-999.0E0,-999.0E0,3.0E0,-12.0E0,9.0E0,-51.0E0,
CS   2          18.0E0,-5040.0E0,720.0E0,0.0E0,-999.0E0,-999.0E0,
CS   3          60.0E0,-360.0E0,345.0E0,-1320.0E0,192.0E0,-120.0E0,
CS   4          24.0E0,0.0E0,-999.0E0,-999.0E0,2520.0E0,-96.0E0,15.0E0,
CS   5          -33.0E0,7.0E0,-6.0E0,2.0E0,0.0E0,-999.0E0,-4.0E0,1.0E0,
CS   6          -3.0E0,1.0E0,-2.0E0,1.0E0,-1.0E0,1.0E0/
CD    DATA  ARR/0.0D0,1.0D0,-1.0D0,1.0D0,-2.0D0,1.0D0,-3.0D0,1.0D0,
CD   1          -999.0D0,-999.0D0,-999.0D0,3.0D0,-12.0D0,9.0D0,-51.0D0,
CD   2          18.0D0,-5040.0D0,720.0D0,0.0D0,-999.0D0,-999.0D0,
CD   3          60.0D0,-360.0D0,345.0D0,-1320.0D0,192.0D0,-120.0D0,
CD   4          24.0D0,0.0D0,-999.0D0,-999.0D0,2520.0D0,-96.0D0,15.0D0,
CD   5          -33.0D0,7.0D0,-6.0D0,2.0D0,0.0D0,-999.0D0,-4.0D0,1.0D0,
CD   6          -3.0D0,1.0D0,-2.0D0,1.0D0,-1.0D0,1.0D0/
      DATA IOUT/6/
C------------------------------------------------------------------
C  Define statement functions for conversions
C------------------------------------------------------------------
CS    CONV(N) = REAL(N)
CD    CONV(N) = DBLE(N)
      TOP(X) = X - HALF*LOG(X) + LOG(ONE+(ONE/EIGHT-XNINE/
     1   ONE28/X)/X)
      BOT(X) = -(SIXTEN*X+ATETEN) / (((ONE28*X+SIXTEN)*X+
     1   XNINE)*X) + ONE - HALF/X
C------------------------------------------------------------------
C  Determine machine parameters and set constants
C------------------------------------------------------------------
      CALL MACHAR(IBETA,IT,IRND,NGRD,MACHEP,NEGEP,IEXP,MINEXP,
     1            MAXEXP,EPS,EPSNEG,XMIN,XMAX)
      BETA = CONV(IBETA)
      AIT = CONV(IT)
      ALBETA = LOG(BETA)
      A = ZERO
      B = TWO
      JT = 0
      CONST = C + LOG(XMAX)
      DELTA = XLAM - ONE
      F = (XLAM-ONE) * (XLAM+ONE) * HALF
C-----------------------------------------------------------------
C  Random argument accuracy tests
C-----------------------------------------------------------------
      DO 300 J = 1, 4
C-------------------------------------------------------------------
C  Calculate the number of terms needed for convergence of the 
C  series by using Newton's iteration on the asymptotic form of 
C  the multiplication theorem
C-------------------------------------------------------------------
         XBAD = B
         D = AIT * ALBETA - C + ONE
         E = LOG(XBAD * F) + ONE
         AKK = ONE
  100    AK = AKK
            Z = D + E*AK - (AK+HALF) * LOG(AK+ONE)
            ZZ = E - (AK+HALF)/(AK+ONE) - LOG(AK+ONE)
            AKK = AK - Z/ZZ
         IF (ABS(AK-AKK) .GT. HUND*EPS*AK) GO TO 100
         MBORG = INT(AKK) + 1
         N = 2000 
         XN = CONV(N)
         K1 = 0
         K2 = 0
         K3 = 0
         X1 = ZERO
         R6 = ZERO
         R7 = ZERO
         DEL = (B - A) / XN
         XL = A
         DO 200 I = 1, N
            X = DEL * REN(JT) + XL
C------------------------------------------------------------------
C   Carefully purify arguments
C------------------------------------------------------------------
            IF (J .EQ. 1) THEN
                  Y = X/XLAM
               ELSE
                  Y = X - DELTA
            END IF
            TEMP = SIXTEN * Y
            T1 = TEMP + Y
            T1 = TEMP + T1
            Y = T1 - TEMP
            Y = Y - TEMP
            IF (J .EQ. 1) THEN
                  X = Y * XLAM
               ELSE
                  X = Y + DELTA
            END IF
C------------------------------------------------------------------
C   Use Amos' Ratio Scheme
C------------------------------------------------------------------
            D = F*Y
            MB = MBORG + MBORG
            MB2 = MB - 1
            XMB = CONV(MB2)
            TEMP = (XMB + ONE + HALF) * (XMB + ONE + HALF)
            U2(MB) = Y / (XMB + HALF + SQRT(TEMP + Y*Y))
C------------------------------------------------------------------
C   Generate ratios using recurrence
C------------------------------------------------------------------
            DO 110 II = 2, MB
               OVRCHK = XMB/(Y*HALF)
               U2(MB2) = ONE / (OVRCHK + U2(MB2+1))
               XMB = XMB - ONE
               MB2 = MB2 - 1
  110       CONTINUE
            U(1) = BESI0(Y)
            IF (J .EQ. 1) THEN
C------------------------------------------------------------------
C   Accuracy test is based on the multiplication theorem
C------------------------------------------------------------------
                  MB = MB - MBORG
                  DO 120 II = 2, MB
                     U(II) = U(II-1) * U2(II-1)
  120             CONTINUE
C------------------------------------------------------------------
C   Accurate Summation
C------------------------------------------------------------------
                  MB = MB - 1
                  XMB = CONV(MB)
                  SUM = U(MB+1)
                  IND = MB
                  DO 155 II = 2, MB
                     SUM = SUM * D / XMB + U(IND)
                     IND = IND - 1
                     XMB = XMB - ONE
  155             CONTINUE
                  ZZ = SUM * D + U(IND)
               ELSE
C------------------------------------------------------------------
C   Accuracy test is based on Taylor's Series Expansion
C------------------------------------------------------------------
                  U(2) = U(1) * U2(1)
                  MB = 8 
                  J1 = MB
                  XJ1 = CONV(J1+1)
                  IEXP = 0
C------------------------------------------------------------------
C   Accurate Summation
C------------------------------------------------------------------
                  DO 180 II = 1, MB
                     J2 = 1
  160                J2 = J2 + 1
                     IF (ARR(J1,J2) .NE. X99) GO TO 160
                     J2 = J2 - 1
                     T1 = ARR(J1,J2)
                     J2 = J2 - 1
C------------------------------------------------------------------
C   Group I0 terms in the derivative
C------------------------------------------------------------------
                     IF (J2 .EQ. 0) GO TO 168 
  165                T1 = T1 / (Y*Y) + ARR(J1,J2)
                           J2 = J2 - 1
                     IF (J2 .GE. 1) GO TO 165
  168                IF (IEXP .EQ. 1) T1 = T1 / Y
                     J2 = 6 
  170                J2 = J2 - 1
                     IF (ARR(II,J2) .NE. X99) GO TO 170
                     J2 = J2 + 1
                     T2 = ARR(II,J2)
                     J2 = J2 + 1
                     IF (IEXP .EQ. 0) THEN 
                           IEXP = 1
                        ELSE
                           IEXP = 0
                     END IF
C------------------------------------------------------------------
C   Group I1 terms in the derivative
C------------------------------------------------------------------
                     IF (J2 .EQ. 7) GO TO 177 
  175                T2 = T2 / (Y*Y) + ARR(II,J2)
                           J2 = J2 + 1
                     IF (J2 .LE. 6) GO TO 175
  177                IF (IEXP .EQ. 1) T2 = T2 / Y
                     IF (J1 .EQ. 8) THEN
                           SUM = U(1)*T1 + U(2)*T2
                        ELSE
                           SUM = SUM * (DELTA/XJ1) + (U(1)*T1 + U(2)*T2)
                     END IF
                     J1 = J1 - 1
                     XJ1 = CONV(J1+1)
  180             CONTINUE
                  ZZ = SUM * DELTA + U(1)
            END IF
            Z = BESI0(X)
C------------------------------------------------------------------
C   Accumulate Results
C------------------------------------------------------------------
            W = (Z - ZZ) / Z
            IF (W .GT. ZERO) THEN 
                  K1 = K1 + 1
               ELSE IF (W .LT. ZERO) THEN 
                  K3 = K3 + 1
               ELSE
                  K2 = K2 + 1
            END IF
            W = ABS(W)
            IF (W .GT. R6) THEN
                  R6 = W
                  X1 = X
            END IF
            R7 = R7 + W * W
            XL = XL + DEL
  200    CONTINUE
C------------------------------------------------------------------
C   Gather and print statistics for test
C------------------------------------------------------------------
         N = K1 + K2 + K3
         R7 = SQRT(R7/XN)
         IF (J .EQ. 1) THEN
               WRITE (IOUT,1000)
            ELSE
               WRITE (IOUT,1001)
         END IF
         WRITE (IOUT,1010) N,A,B
         WRITE (IOUT,1011) K1,K2,K3
         WRITE (IOUT,1020) IT,IBETA
         IF (R6 .NE. ZERO) THEN
               W = LOG(R6)/ALBETA
            ELSE
               W = X99
         END IF
         WRITE (IOUT,1021) R6,IBETA,W,X1
         W = MAX(AIT+W,ZERO)
         WRITE (IOUT,1022) IBETA,W
         IF (R7 .NE. ZERO) THEN
               W = LOG(R7)/ALBETA
            ELSE
               W = X99
         END IF
         WRITE (IOUT,1023) R7,IBETA,W
         W = MAX(AIT+W,ZERO)
         WRITE (IOUT,1022) IBETA,W
C------------------------------------------------------------------
C   Initialize for next test
C------------------------------------------------------------------
         A = B
         B = B + B
         IF (J .EQ. 1) B = B + B - HALF
  300 CONTINUE
C-----------------------------------------------------------------
C   Test of error returns
C
C   Special tests
C-----------------------------------------------------------------
      WRITE (IOUT,1030)
      WRITE (IOUT,1031)
      Y = BESI0(XMIN)
      WRITE (IOUT,1032) Y
      Y = BESI0(ZERO)
      WRITE (IOUT,1033) 0,Y
      X = -ONE * REN(JT)
      Y = BESI0(X)
      WRITE (IOUT,1034) X,Y
      X = -X 
      Y = BESI0(X)
      WRITE (IOUT,1034) X,Y
      Y = BESEI0(XMAX)
      WRITE (IOUT,1035) Y
C-----------------------------------------------------------------
C   Determine largest safe argument for unscaled functions
C-----------------------------------------------------------------
      WRITE (IOUT, 1036)
      XA = LOG(XMAX)
  330 XB = XA - (TOP(XA)-CONST) / BOT(XA)
      IF (ABS(XB-XA)/XB .LE. EPS) THEN 
            GO TO 350
         ELSE
            XA = XB
            GO TO 330
      END IF
  350 XLARGE = XB / XLAM 
      Y = BESI0(XLARGE)
      WRITE (IOUT,1034) XLARGE,Y
      XLARGE = XB * XLAM
      Y = BESI0(XLARGE)
      WRITE (IOUT,1034) XLARGE,Y
      WRITE (IOUT, 1037)
      STOP
C-----------------------------------------------------------------
 1000 FORMAT('1Test of I0(X) vs Multiplication Theorem'//)
 1001 FORMAT('1Test of I0(X) vs Taylor series'//)
 1010 FORMAT(I7,' Random arguments were tested from the interval ',
     1    '(',F5.2,',',F5.2,')'//)
 1011 FORMAT(' I0(X) was larger',I6,' times,'/
     1    10X,' agreed',I6,' times, and'/
     1    6X,'was smaller',I6,' times.'//)
 1020 FORMAT(' There are',I4,' base',I4,
     1    ' significant digits in a floating-point number'//)
 1021 FORMAT(' The maximum relative error of',E15.4,' = ',I4,' **',
     1    F7.2/4X,'occurred for X =',E13.6)
 1022 FORMAT(' The estimated loss of base',I4,
     1    ' significant digits is',F7.2//)
 1023 FORMAT(' The root mean square relative error was',E15.4,
     1    ' = ',I4,' **',F7.2)
 1030 FORMAT('1Special Tests'//)
 1031 FORMAT(' Test with extreme arguments'/)
 1032 FORMAT(' I0(XMIN) = ',E24.17/)
 1033 FORMAT(' I0(',I1,') = ',E24.17/)
 1034 FORMAT(' I0(',E24.17,' ) = ',E24.17/)
 1035 FORMAT(' E**-X * I0(XMAX) = ',E24.17/)
 1036 FORMAT(' Tests near the largest argument for unscaled functions'/)
 1037 FORMAT(' This concludes the tests.') 
C---------- Last line of BESI0 test program ---------- 
      END
      SUBROUTINE CALCI1(ARG,RESULT,JINT)
C--------------------------------------------------------------------
C
C This packet computes modified Bessel functioons of the first kind
C   and order one, I1(X) and EXP(-ABS(X))*I1(X), for real
C   arguments X.  It contains two function type subprograms, BESI1
C   and BESEI1, and one subroutine type subprogram, CALCI1.
C   The calling statements for the primary entries are
C
C                   Y=BESI1(X)
C   and
C                   Y=BESEI1(X)
C
C   where the entry points correspond to the functions I1(X) and
C   EXP(-ABS(X))*I1(X), respectively.  The routine CALCI1 is
C   intended for internal packet use only, all computations within
C   the packet being concentrated in this routine.  The function
C   subprograms invoke CALCI1 with the statement
C          CALL CALCI1(ARG,RESULT,JINT)
C   where the parameter usage is as follows
C
C      Function                     Parameters for CALCI1
C       Call              ARG                  RESULT          JINT
C
C     BESI1(ARG)    ABS(ARG) .LE. XMAX        I1(ARG)           1
C     BESEI1(ARG)    any real ARG        EXP(-ABS(ARG))*I1(ARG) 2
C
C   The main computation evaluates slightly modified forms of
C   minimax approximations generated by Blair and Edwards, Chalk
C   River (Atomic Energy of Canada Limited) Report AECL-4928,
C   October, 1974.  This transportable program is patterned after
C   the machine-dependent FUNPACK packet NATSI1, but cannot match
C   that version for efficiency or accuracy.  This version uses
C   rational functions that theoretically approximate I-SUB-1(X)
C   to at least 18 significant decimal digits.  The accuracy
C   achieved depends on the arithmetic system, the compiler, the
C   intrinsic functions, and proper selection of the machine-
C   dependent constants.
C
C*******************************************************************
C*******************************************************************
C
C Explanation of machine-dependent constants.  Let
C
C   beta   = Radix for the floating-point system
C   maxexp = Smallest power of beta that overflows
C
C Then the following machine-dependent constants must be declared
C   in DATA statements.  IEEE values are provided as a default.
C
C   XSMALL = Positive argument such that 1.0 - X = 1.0 to
C            machine precision for all ABS(X) .LE. XSMALL.
C   XINF =   Largest positive machine number; approximately
C            beta**maxexp
C   XMAX =   Largest argument acceptable to BESI1;  Solution to
C            equation:
C               EXP(X) * (1-3/(8*X)) / SQRT(2*PI*X) = beta**maxexp
C
C
C     Approximate values for some important machines are:
C
C                          beta       maxexp       XSMALL
C
C CRAY-1        (S.P.)       2         8191       3.55E-15
C Cyber 180/855
C   under NOS   (S.P.)       2         1070       3.55E-15
C IEEE (IBM/XT,
C   SUN, etc.)  (S.P.)       2          128       2.98E-8
C IEEE (IBM/XT,
C   SUN, etc.)  (D.P.)       2         1024       5.55D-17
C IBM 3033      (D.P.)      16           63       6.95D-18
C VAX           (S.P.)       2          127       2.98E-8
C VAX D-Format  (D.P.)       2          127       6.95D-18
C VAX G-Format  (D.P.)       2         1023       5.55D-17
C
C
C                               XINF          XMAX
C
C CRAY-1        (S.P.)       5.45E+2465     5682.810
C Cyber 180/855
C   under NOS   (S.P.)       1.26E+322       745.894
C IEEE (IBM/XT,
C   SUN, etc.)  (S.P.)       3.40E+38         91.906
C IEEE (IBM/XT,
C   SUN, etc.)  (D.P.)       1.79D+308       713.987
C IBM 3033      (D.P.)       7.23D+75        178.185
C VAX           (S.P.)       1.70D+38         91.209
C VAX D-Format  (D.P.)       1.70D+38         91.209
C VAX G-Format  (D.P.)       8.98D+307       713.293
C
C*******************************************************************
C*******************************************************************
C
C Error returns
C
C  The program returns the value XINF for ABS(ARG) .GT. XMAX.
C
C
C Intrinsic functions required are:
C
C     ABS, SQRT, EXP
C
C
C  Authors: W. J. Cody and L. Stoltz
C           Mathematics and Computer Science Division
C           Argonne National Laboratory
C           Argonne, IL  60439
C
C  Latest modification: March 13, 1992
C
C--------------------------------------------------------------------
      INTEGER J,JINT
CS    REAL
CD    DOUBLE PRECISION
     1    A,ARG,B,EXP40,FORTY,HALF,ONE,ONE5,P,PBAR,PP,Q,QQ,REC15,
     2    RESULT,SUMP,SUMQ,TWO25,X,XINF,XMAX,XSMALL,XX,ZERO
      DIMENSION P(15),PP(8),Q(5),QQ(6)
C--------------------------------------------------------------------
C  Mathematical constants
C--------------------------------------------------------------------
CS    DATA ONE/1.0E0/,ONE5/15.0E0/,EXP40/2.353852668370199854E17/,
CS   1     FORTY/40.0E0/,REC15/6.6666666666666666666E-2/,
CS   2     TWO25/225.0E0/,HALF/0.5E0/,ZERO/0.0E0/
CD    DATA ONE/1.0D0/,ONE5/15.0D0/,EXP40/2.353852668370199854D17/,
CD   1     FORTY/40.0D0/,REC15/6.6666666666666666666D-2/,
CD   2     TWO25/225.0D0/,HALF/0.5D0/,ZERO/0.0D0/
C--------------------------------------------------------------------
C  Machine-dependent constants
C--------------------------------------------------------------------
CS    DATA XSMALL/2.98E-8/,XINF/3.4E38/,XMAX/91.906E0/
CD    DATA XSMALL/5.55D-17/,XINF/1.79D308/,XMAX/713.987D0/
C--------------------------------------------------------------------
C  Coefficients for XSMALL .LE. ABS(ARG) .LT. 15.0
C--------------------------------------------------------------------
CS    DATA P/-1.9705291802535139930E-19,-6.5245515583151902910E-16,
CS   1       -1.1928788903603238754E-12,-1.4831904935994647675E-09,
CS   2       -1.3466829827635152875E-06,-9.1746443287817501309E-04,
CS   3       -4.7207090827310162436E-01,-1.8225946631657315931E+02,
CS   4       -5.1894091982308017540E+04,-1.0588550724769347106E+07,
CS   5       -1.4828267606612366099E+09,-1.3357437682275493024E+11,
CS   6       -6.9876779648010090070E+12,-1.7732037840791591320E+14,
CS   7       -1.4577180278143463643E+15/
CD    DATA P/-1.9705291802535139930D-19,-6.5245515583151902910D-16,
CD   1       -1.1928788903603238754D-12,-1.4831904935994647675D-09,
CD   2       -1.3466829827635152875D-06,-9.1746443287817501309D-04,
CD   3       -4.7207090827310162436D-01,-1.8225946631657315931D+02,
CD   4       -5.1894091982308017540D+04,-1.0588550724769347106D+07,
CD   5       -1.4828267606612366099D+09,-1.3357437682275493024D+11,
CD   6       -6.9876779648010090070D+12,-1.7732037840791591320D+14,
CD   7       -1.4577180278143463643D+15/
CS    DATA Q/-4.0076864679904189921E+03, 7.4810580356655069138E+06,
CS   1       -8.0059518998619764991E+09, 4.8544714258273622913E+12,
CS   2       -1.3218168307321442305E+15/
CD    DATA Q/-4.0076864679904189921D+03, 7.4810580356655069138D+06,
CD   1       -8.0059518998619764991D+09, 4.8544714258273622913D+12,
CD   2       -1.3218168307321442305D+15/
C--------------------------------------------------------------------
C  Coefficients for 15.0 .LE. ABS(ARG)
C--------------------------------------------------------------------
CS    DATA PP/-6.0437159056137600000E-02, 4.5748122901933459000E-01,
CS   1        -4.2843766903304806403E-01, 9.7356000150886612134E-02,
CS   2        -3.2457723974465568321E-03,-3.6395264712121795296E-04,
CS   3         1.6258661867440836395E-05,-3.6347578404608223492E-07/
CD    DATA PP/-6.0437159056137600000D-02, 4.5748122901933459000D-01,
CD   1        -4.2843766903304806403D-01, 9.7356000150886612134D-02,
CD   2        -3.2457723974465568321D-03,-3.6395264712121795296D-04,
CD   3         1.6258661867440836395D-05,-3.6347578404608223492D-07/
CS    DATA QQ/-3.8806586721556593450E+00, 3.2593714889036996297E+00,
CS   1        -8.5017476463217924408E-01, 7.4212010813186530069E-02,
CS   2        -2.2835624489492512649E-03, 3.7510433111922824643E-05/
CD    DATA QQ/-3.8806586721556593450D+00, 3.2593714889036996297D+00,
CD   1        -8.5017476463217924408D-01, 7.4212010813186530069D-02,
CD   2        -2.2835624489492512649D-03, 3.7510433111922824643D-05/
CS    DATA PBAR/3.98437500E-01/
CD    DATA PBAR/3.98437500D-01/
C--------------------------------------------------------------------
      X = ABS(ARG)
      IF (X .LT. XSMALL) THEN
C--------------------------------------------------------------------
C  Return for ABS(ARG) .LT. XSMALL
C--------------------------------------------------------------------
            RESULT = HALF * X
         ELSE IF (X .LT. ONE5) THEN
C--------------------------------------------------------------------
C  XSMALL .LE. ABS(ARG) .LT. 15.0
C--------------------------------------------------------------------
            XX = X * X
            SUMP = P(1)
            DO 50 J = 2, 15
               SUMP = SUMP * XX + P(J)
   50          CONTINUE
            XX = XX - TWO25
            SUMQ = ((((XX+Q(1))*XX+Q(2))*XX+Q(3))*XX+Q(4))
     1           *XX+Q(5)
            RESULT = (SUMP / SUMQ) * X
            IF (JINT .EQ. 2) RESULT = RESULT * EXP(-X)
         ELSE IF ((JINT .EQ. 1) .AND. (X .GT. XMAX)) THEN
                  RESULT = XINF
         ELSE
C--------------------------------------------------------------------
C  15.0 .LE. ABS(ARG)
C--------------------------------------------------------------------
            XX = ONE / X - REC15
            SUMP = ((((((PP(1)*XX+PP(2))*XX+PP(3))*XX+
     1           PP(4))*XX+PP(5))*XX+PP(6))*XX+PP(7))*XX+PP(8)
            SUMQ = (((((XX+QQ(1))*XX+QQ(2))*XX+QQ(3))*XX+
     1           QQ(4))*XX+QQ(5))*XX+QQ(6)
            RESULT = SUMP / SUMQ
            IF (JINT .NE. 1) THEN
                  RESULT = (RESULT + PBAR) / SQRT(X)
               ELSE
C--------------------------------------------------------------------
C  Calculation reformulated to avoid premature overflow
C--------------------------------------------------------------------
                  IF (X .GT. XMAX-ONE5) THEN
                        A = EXP(X-FORTY)
                        B = EXP40
                     ELSE
                        A = EXP(X)
                        B = ONE
                  END IF
                  RESULT = ((RESULT * A + PBAR * A) /
     1                  SQRT(X)) * B
C--------------------------------------------------------------------
C  Error return for ABS(ARG) .GT. XMAX
C--------------------------------------------------------------------
            END IF
      END IF
      IF (ARG .LT. ZERO) RESULT = -RESULT
      RETURN
C----------- Last line of CALCI1 -----------
      END
CS    REAL FUNCTION BESI1(X)
CD    DOUBLE PRECISION FUNCTION BESI1(X)
C--------------------------------------------------------------------
C
C This long precision subprogram computes approximate values for
C   modified Bessel functions of the first kind of order one for
C   arguments ABS(ARG) .LE. XMAX  (see comments heading CALCI1).
C
C--------------------------------------------------------------------
      INTEGER JINT
CS    REAL
CD    DOUBLE PRECISION
     1    X, RESULT
C--------------------------------------------------------------------
      JINT=1
      CALL CALCI1(X,RESULT,JINT)
      BESI1=RESULT
      RETURN
C---------- Last line of BESI1 ----------
      END
CS    REAL FUNCTION BESEI1(X)
CD    DOUBLE PRECISION FUNCTION BESEI1(X)
C--------------------------------------------------------------------
C
C This function program computes approximate values for the
C   modified Bessel function of the first kind of order one
C   multiplied by EXP(-ABS(X)), where EXP is the
C   exponential function, ABS is the absolute value, and X
C   is any argument.
C
C--------------------------------------------------------------------
      INTEGER JINT
CS    REAL
CD    DOUBLE PRECISION
     1    X, RESULT
C--------------------------------------------------------------------
      JINT=2
      CALL CALCI1(X,RESULT,JINT)
      BESEI1=RESULT
      RETURN
C---------- Last line of BESEI1 ----------
      END
      PROGRAM I1TEST
C------------------------------------------------------------------
C FORTRAN 77 program to test BESI1, BESEI1
C
C  Method:
C
C     Accuracy tests compare function values against values
C     generated with the multiplication formula for small
C     arguments and values generated from a Taylor's Series
C     Expansion using Amos' Ratio Scheme for initial values
C     for large arguments.
C
C  Data required
C
C     None
C
C  Subprograms required from this package
C
C     MACHAR - An environmental inquiry program providing
C         information on the floating-point arithmetic
C         system.  Note that the call to MACHAR can
C         be deleted provided the following five
C         parameters are assigned the values indicated
C
C              IBETA  - the radix of the floating-point system
C              IT     - the number of base-IBETA digits in the
C                       significant of a floating-point number
C              EPS    - the smallest positive floating-point
C                       number such that 1.0+EPS .NE. 1.0
C              XMIN   - the smallest non-vanishing normalized
C                       floating-point power of the radix
C              XMAX   - the largest finite floating-point number
C
C     REN(K) - a function subprogram returning random real
C              numbers uniformly distributed over (0,1)
C
C
C  Intrinsic functions required are:
C
C      ABS, DBLE, INT, LOG, MAX, REAL, SQRT
C
C  References: "Computation of Modified Bessel Functions and
C               Their Ratios," D. E. Amos, Math. of Comp., 
C               Volume 28, Number 24, January, 1974.
C
C              "Performance evaluation of programs for certain
C               Bessel functions", W. J. Cody and L. Stoltz,
C               ACM Trans. on Math. Software, Vol. 15, 1989,
C               pp 41-48.
C
C              "Use of Taylor series to test accuracy of function
C               programs," W. J. Cody and L. Stoltz, submitted
C               for publication.
C
C  Latest modification: March 13, 1992
C
C  Authors:  W. J. Cody and L. Stoltz
C            Mathematics and Computer Science Division 
C            Argonne National Laboratory
C            Argonne, IL 60439
C
C------------------------------------------------------------------
      INTEGER I,IBETA,IEXP,II,IND,IOUT,IRND,IT,J,JT,J1,J2,K1,K2,K3,
     1    MACHEP,MAXEXP,MB,MBORG,MINEXP,MB2,N,NEGEP,NGRD
CS    REAL  
CD    DOUBLE PRECISION  
     1    A,AIT,AK,AKK,ALBETA,ARR,B,BESEI1,BESI1,BETA,BOT,C,CONST,CONV,
     2    D,DEL,DELTA,E,EIGHT,EPS,EPSNEG,F,HALF,HUND,ONE,OVRCHK,REN,R6,
     3    R7,SIXTEN,SUM,TEMP,THREE,TOP,T1,T2,U,U2,W,X,XA,XB,XBAD,XJ1,
     4    XL,XLAM,XLARGE,XMAX,XMB,XMIN,XN,X1,X99,Y,Z,ZERO,ZZ
      DIMENSION ARR(8,7),U(560),U2(560) 
CS    DATA ZERO,HALF,ONE,THREE,EIGHT/0.0E0,0.5E0,1.0E0,3.0E0,8.0E0/, 
CS   1   SIXTEN,HUND,X99,XLAM/1.6E1,1.0E2,-999.0E0,1.03125E0/,
CS   2   XLARGE,C/1.0E4,0.9189385332E0/
CD    DATA ZERO,HALF,ONE,THREE,EIGHT/0.0D0,0.5D0,1.0D0,3.0D0,8.0D0/, 
CD   1   SIXTEN,HUND,X99,XLAM/1.6D1,1.0D2,-999.0D0,1.03125D0/,
CD   2   XLARGE,C/1.0D4,0.9189385332D0/
CS    DATA  ARR/1.0E0,-1.0E0,1.0E0,-2.0E0,1.0E0,-3.0E0,1.0E0,-4.0E0,
CS   1          -999.0E0,-999.0E0,3.0E0,-12.0E0,9.0E0,-51.0E0,18.0E0,
CS   2          -132.0E0,40320.0E0,0.0E0,-999.0E0,-999.0E0,60.0E0,
CS   3          -360.0E0,345.0E0,-2700.0E0,10440.0E0,-5040.0E0,720.0E0,
CS   4          0.0E0,-999.0E0,-999.0E0,2520.0E0,-20160.0E0,729.0E0,
CS   5          -1320.0E0,192.0E0,-120.0E0,24.0E0,0.0E0,-999.0E0,
CS   6          -999.0E0,26.0E0,-96.0E0,15.0E0,-33.0E0,7.0E0,-6.0E0,
CS   7          2.0E0,0.0E0,1.0E0,-4.0E0,1.0E0,-3.0E0,1.0E0,-2.0E0,
CS   8          1.0E0,-1.0E0/
CD    DATA  ARR/1.0D0,-1.0D0,1.0D0,-2.0D0,1.0D0,-3.0D0,1.0D0,-4.0D0,
CD   1          -999.0D0,-999.0D0,3.0D0,-12.0D0,9.0D0,-51.0D0,18.0D0,
CD   2          -132.0D0,40320.0D0,0.0D0,-999.0D0,-999.0D0,60.0D0,
CD   3          -360.0D0,345.0D0,-2700.0D0,10440.0D0,-5040.0D0,720.0D0,
CD   4          0.0D0,-999.0D0,-999.0D0,2520.0D0,-20160.0D0,729.0D0,
CD   5          -1320.0D0,192.0D0,-120.0D0,24.0D0,0.0D0,-999.0D0,
CD   6          -999.0D0,26.0D0,-96.0D0,15.0D0,-33.0D0,7.0D0,-6.0D0,
CD   7          2.0D0,0.0D0,1.0D0,-4.0D0,1.0D0,-3.0D0,1.0D0,-2.0D0,
CD   8          1.0D0,-1.0D0/
      DATA IOUT/6/
C------------------------------------------------------------------
C  Define statement functions for conversions
C------------------------------------------------------------------
CS    CONV(N) = REAL(N)
CD    CONV(N) = DBLE(N)
      TOP(X) = X - HALF*LOG(X) + LOG(ONE-THREE/(EIGHT*X))
      BOT(X) = THREE / ((EIGHT*X-THREE)*X) + ONE - HALF/X
C------------------------------------------------------------------
C  Determine machine parameters and set constants
C------------------------------------------------------------------
      CALL MACHAR(IBETA,IT,IRND,NGRD,MACHEP,NEGEP,IEXP,MINEXP,
     1            MAXEXP,EPS,EPSNEG,XMIN,XMAX)
      BETA = CONV(IBETA)
      AIT = CONV(IT)
      ALBETA = LOG(BETA)
      A = ZERO
      B = ONE
      JT = 0
      CONST = C + LOG(XMAX)
      DELTA = XLAM - ONE
      F = (XLAM-ONE) * (XLAM+ONE) * HALF
C-----------------------------------------------------------------
C  Random argument accuracy tests
C-----------------------------------------------------------------
      DO 300 J = 1, 4
C-------------------------------------------------------------------
C  Calculate the number of terms needed for convergence of the 
C  series by using Newton's iteration on the asymptotic form of 
C  the multiplication theorem
C-------------------------------------------------------------------
         XBAD = B
         D = AIT * ALBETA - C + ONE
         E = LOG(XBAD * F) + ONE
         AKK = ONE
  100    AK = AKK
            Z = D + E*AK - (AK+HALF) * LOG(AK+ONE)
            ZZ = E - (AK+HALF)/(AK+ONE) - LOG(AK+ONE)
            AKK = AK - Z/ZZ
         IF (ABS(AK-AKK) .GT. HUND*EPS*AK) GO TO 100
         MBORG = INT(AKK) + 1
         N = 2000 
         XN = CONV(N)
         K1 = 0
         K2 = 0
         K3 = 0
         X1 = ZERO
         R6 = ZERO
         R7 = ZERO
         DEL = (B - A) / XN
         XL = A
         DO 200 I = 1, N
            X = DEL * REN(JT) + XL
C------------------------------------------------------------------
C   Carefully purify arguments
C------------------------------------------------------------------
            IF (J .EQ. 1) THEN
                  Y = X/XLAM
               ELSE
                  Y = X - DELTA
            END IF
            W = SIXTEN * Y
            T1 = W + Y
            T1 = W + T1
            Y = T1 - W
            Y = Y - W
            IF (J .EQ. 1) THEN
                  X = Y * XLAM
               ELSE
                  X = Y + DELTA
            END IF
C------------------------------------------------------------------
C   Use Amos' Ratio Scheme
C------------------------------------------------------------------
            D = F*Y
            MB = MBORG + MBORG
            MB2 = MB - 1
            XMB = CONV(MB2)
            TEMP = (XMB + ONE + HALF) * (XMB + ONE + HALF)
            U2(MB) = Y / (XMB + HALF + SQRT(TEMP + Y*Y))
C------------------------------------------------------------------
C   Generate ratios using recurrence
C------------------------------------------------------------------
            DO 110 II = 2, MB
               OVRCHK = XMB/(Y*HALF)
               U2(MB2) = ONE / (OVRCHK + U2(MB2+1))
               XMB = XMB - ONE
               MB2 = MB2 - 1
  110       CONTINUE
            U(2) = BESI1(Y)
            U(1) = U(2) / U2(1)
            IF (J .EQ. 1) THEN
C------------------------------------------------------------------
C   Accuracy test is based on the multiplication theorem
C------------------------------------------------------------------
                  MB = MB - MBORG
                  DO 120 II = 3, MB
                     U(II) = U(II-1) * U2(II-1)
  120             CONTINUE
C------------------------------------------------------------------
C   Accurate Summation
C------------------------------------------------------------------
                  MB = MB - 1
                  XMB = CONV(MB-1)
                  SUM = U(MB+1)
                  IND = MB
                  DO 155 II = 2, MB
                     SUM = SUM * D / XMB + U(IND)
                     IND = IND - 1
                     XMB = XMB - ONE
  155             CONTINUE
                  ZZ = XLAM * SUM 
               ELSE
C------------------------------------------------------------------
C   Accuracy test is based on Taylor's Series Expansion
C------------------------------------------------------------------
                  MB = 8 
                  J1 = MB
                  XJ1 = CONV(J1+1)
                  IEXP = 1
C------------------------------------------------------------------
C   Accurate Summation
C------------------------------------------------------------------
                  DO 180 II = 1, MB
                     J2 = 1
  160                J2 = J2 + 1
                     IF (ARR(J1,J2) .NE. X99) GO TO 160
                     J2 = J2 - 1
                     T1 = ARR(J1,J2)
                     J2 = J2 - 1
C------------------------------------------------------------------
C   Group I0 terms in the derivative
C------------------------------------------------------------------
                     IF (J2 .EQ. 0) GO TO 168 
  165                T1 = T1 / (Y*Y) + ARR(J1,J2)
                           J2 = J2 - 1
                     IF (J2 .GE. 1) GO TO 165
  168                IF (IEXP .EQ. 1) T1 = T1 / Y
                     J2 = 7 
  170                J2 = J2 - 1
                     IF (ARR(II,J2) .NE. X99) GO TO 170
                     J2 = J2 + 1
                     T2 = ARR(II,J2)
                     J2 = J2 + 1
                     IF (IEXP .EQ. 0) THEN
                           IEXP = 1
                        ELSE
                           IEXP = 0
                     END IF
C------------------------------------------------------------------
C   Group I1 terms in the derivative
C------------------------------------------------------------------
                     IF (J2 .EQ. 8) GO TO 177 
  175                T2 = T2 / (Y*Y) + ARR(II,J2)
                           J2 = J2 + 1
                     IF (J2 .LE. 7) GO TO 175
  177                IF (IEXP .EQ. 1) T2 = T2 / Y
                     IF (J1 .EQ. 8) THEN
                           SUM = U(1)*T1 + U(2)*T2
                        ELSE
                           SUM = SUM * (DELTA/XJ1) + (U(1)*T1 + U(2)*T2)
                     END IF
                     J1 = J1 - 1
                     XJ1 = CONV(J1+1)
  180             CONTINUE
                  ZZ = SUM * DELTA + U(2)
            END IF
            Z = BESI1(X)
C------------------------------------------------------------------
C   Accumulate Results
C------------------------------------------------------------------
            W = (Z - ZZ) / Z
            IF (W .GT. ZERO) THEN 
                  K1 = K1 + 1
               ELSE IF (W .LT. ZERO) THEN 
                  K3 = K3 + 1
               ELSE
                  K2 = K2 + 1
            END IF
            W = ABS(W)
            IF (W .GT. R6) THEN
                  R6 = W
                  X1 = X
            END IF
            R7 = R7 + W * W
            XL = XL + DEL
  200    CONTINUE
C------------------------------------------------------------------
C   Gather and print statistics for test
C------------------------------------------------------------------
         N = K1 + K2 + K3
         R7 = SQRT(R7/XN)
         IF (J .EQ. 1) THEN
               WRITE (IOUT,1000)
            ELSE
               WRITE (IOUT,1001)
         END IF
         WRITE (IOUT,1010) N,A,B
         WRITE (IOUT,1011) K1,K2,K3
         WRITE (IOUT,1020) IT,IBETA
         IF (R6 .NE. ZERO) THEN
               W = LOG(R6)/ALBETA
            ELSE
               W = X99
         END IF
         WRITE (IOUT,1021) R6,IBETA,W,X1
         W = MAX(AIT+W,ZERO)
         WRITE (IOUT,1022) IBETA,W
         IF (R7 .NE. ZERO) THEN
               W = LOG(R7)/ALBETA
            ELSE
               W = X99
         END IF
         WRITE (IOUT,1023) R7,IBETA,W
         W = MAX(AIT+W,ZERO)
         WRITE (IOUT,1022) IBETA,W
C------------------------------------------------------------------
C   Initialize for next test
C------------------------------------------------------------------
         A = B
         B = B + B
         IF (J .EQ. 1) B = B + B + THREE + HALF
  300 CONTINUE
C-----------------------------------------------------------------
C   Test of error returns
C
C   Special tests
C-----------------------------------------------------------------
      WRITE (IOUT,1030)
      WRITE (IOUT,1031)
      Y = BESI1(XMIN)
      WRITE (IOUT,1032) Y
      Y = BESI1(ZERO)
      WRITE (IOUT,1033) 0,Y
      X = -ONE * REN(JT)
      Y = BESI1(X)
      WRITE (IOUT,1034) X,Y
      X = -X 
      Y = BESI1(X)
      WRITE (IOUT,1034) X,Y
      Y = BESEI1(XMAX)
      WRITE (IOUT,1035) Y
C-----------------------------------------------------------------
C   Determine largest safe argument for unscaled functions
C-----------------------------------------------------------------
      WRITE (IOUT, 1036)
      XA = LOG(XMAX)
  330 XB = XA - (TOP(XA)-CONST) / BOT(XA)
      IF (ABS(XB-XA)/XB .LE. EPS) THEN 
            GO TO 350
         ELSE
            XA = XB
            GO TO 330
      END IF
  350 XLARGE = XB / XLAM 
      Y = BESI1(XLARGE)
      WRITE (IOUT,1034) XLARGE,Y
      XLARGE = XB * XLAM
      Y = BESI1(XLARGE)
      WRITE (IOUT,1034) XLARGE,Y
      WRITE (IOUT, 1037)
      STOP
C-----------------------------------------------------------------
 1000 FORMAT('1Test of I1(X) vs Multiplication Theorem'//)
 1001 FORMAT('1Test of I1(X) vs Taylor series'//)
 1010 FORMAT(I7,' Random arguments were tested from the interval ',
     1    '(',F5.2,',',F5.2,')'//)
 1011 FORMAT(' I1(X) was larger',I6,' times,'/
     1    10X,' agreed',I6,' times, and'/
     1    6X,'was smaller',I6,' times.'//)
 1020 FORMAT(' There are',I4,' base',I4,
     1    ' significant digits in a floating-point number'//)
 1021 FORMAT(' The maximum relative error of',E15.4,' = ',I4,' **',
     1    F7.2/4X,'occurred for X =',E13.6)
 1022 FORMAT(' The estimated loss of base',I4,
     1    ' significant digits is',F7.2//)
 1023 FORMAT(' The root mean square relative error was',E15.4,
     1    ' = ',I4,' **',F7.2)
 1030 FORMAT('1Special Tests'//)
 1031 FORMAT(' Test with extreme arguments'/)
 1032 FORMAT(' I1(XMIN) = ',E24.17/)
 1033 FORMAT(' I1(',I1,') = ',E24.17/)
 1034 FORMAT(' I1(',E24.17,' ) = ',E24.17/)
 1035 FORMAT(' E**-X * I1(XMAX) = ',E24.17/)
 1036 FORMAT(' Tests near the largest argument for unscaled functions'/)
 1037 FORMAT(' This concludes the tests.') 
C     ---------- Last line of BESI1 test program ---------- 
      END
      PROGRAM J0TEST
C--------------------------------------------------------------------
C  Fortran 77 program to test BESJ0
C
C  Data required
C
C     None
C
C  Subprograms required from this package
C
C     MACHAR - an environmental inquiry program providing
C              information on the floating-point arithmetic
C              system.  Note that the call to MACHAR can
C              be deleted provided the following six
C              parameters are assigned the values indicated
C
C                 IBETA  - the radix of the floating-point system
C                 IT     - the number of base-IBETA digits in the
C                          significand of a floating-point number
C                 MAXEXP - the smallest integer such that 
C                          FLOAT(IBETA)**MAXEXP causes overflow
C                 EPS    - the smallest positive floating-point
C                          number such that 1.0+EPS .NE. 1.0
C                 XMIN   - the smallest positive normalized
C                          floating-point power of the radix
C                 XMAX   - the largest finite floating-point
C                          number
C
C     REN(K) - a function subprogram returning random real
C              numbers uniformly distributed over (0,1)
C
C
C  Intrinsic functions required are:
C
C         ABS, DBLE, FLOAT, LOG, MAX, SIGN, SQRT
C
C  Reference: "The use of Taylor series to test accuracy of
C              function programs", W. J. Cody and L. Stoltz,
C              submitted for publication.
C
C  Latest modification: March 13, 1992
C
C  Authors: W. J. Cody
C           Mathematics and Computer Science Division
C           Argonne National Laboratory
C           Argonne, IL 60439
C
C--------------------------------------------------------------------
      INTEGER I,IBETA,IEXP,II,III,IOUT,IRND,IT,J,JJ,JT,K1,K2,K3,
     1        MACHEP,MAXEXP,MINEXP,N,NDUM,NEGEP,NGRD
CS    REAL
CD    DOUBLE PRECISION
     1   A,AIT,ALBETA,ALL9,B,BESJ0,BESJ1,BETA,BJ0,BJ0P,BJ1,
     2   BJ1P,CJ0,CJ1,CONV,D,DEL,DELTA,EIGHT,ELEV,EPS,EPSNEG,
     3   FOUR,ONE,REN,R6,R7,SIXTEN,SUM,T,TERM,TWENTY,TWO56,W,
     4   X,XI,XL,XMAX,XMIN,XM,XN,X1,Y,YINV,YSQ,YX,Z,ZERO,ZZ
      DIMENSION BJ0P(6,10),BJ1P(6,10),XI(2),YX(2)
C--------------------------------------------------------------------
C  Mathematical constants
C--------------------------------------------------------------------
      DATA IOUT/6/
CS    DATA ZERO,ONE,FOUR,DELTA/0.0E0,1.0E0,4.0E0,0.0625E0/,
CS   1   EIGHT,TWENTY,ALL9,TWO56/8.0E0,20.0E0,-999.0E0,256.0E0/,
CS   2   SIXTEN,ELEV/16.0E0,11.0E0/
CD    DATA ZERO,ONE,FOUR,DELTA/0.0D0,1.0D0,4.0E0,0.0625D0/,
CD   1   EIGHT,TWENTY,ALL9,TWO56/8.0D0,20.0D0,-999.0D0,256.0D0/,
CD   2   SIXTEN,ELEV/16.0D0,11.0D0/
C--------------------------------------------------------------------
C  Coefficients for Taylor expansion
C--------------------------------------------------------------------
CS    DATA BJ0P/ 0.0E0,1.8144E6,-2.3688E5,1.0845E4,-2.7E2,5.0E0,
CS   1          -1.8144E5,2.394E4,-1.125E3,30.0E0,-1.0E0,0.0E0,
CS   2           0.0E0,2.016E4,-2.7E3,1.32E2,-4.0E0,0.0E0,
CS   3          -2.52E3,3.45E2,-18.0E0,1.0E0,0.0E0,0.0E0,
CS   4           0.0E0,3.6E2,-51.0E0,3.0E0,0.0E0,0.0E0,
CS   5          -60.0E0,9.0E0,-1.0E0,0.0E0,0.0E0,0.0E0,
CS   6           0.0E0,12.0E0,-2.0E0,0.0E0,0.0E0,0.0E0,
CS   7          -3.0E0,1.0E0,0.0E0,0.0E0,0.0E0,0.0E0,
CS   8           0.0E0,1.0E0,0.0E0,0.0E0,0.0E0,0.0E0,
CS   9          -1.0E0,0.0E0,0.0E0,0.0E0,0.0E0,0.0E0/
CS    DATA BJ1P/-3.6288E6,9.2736E5,-6.201E4,1.965E3,-40.0E0,1.0E0,
CS   1           3.6288E5,-9.324E4,6.345E3,-2.1E2,5.0E0,0.0E0,
CS   2          -4.032E4,1.044E4,-7.29E2,26.0E0,-1.0E0,0.0E0,
CS   3           5.04E3,-1.32E3,96.0E0,-4.0E0,0.0E0,0.0E0,
CS   4          -7.2E2,1.92E2,-15.0E0,1.0E0,0.0E0,0.0E0,
CS   5           1.2E2,-33.0E0,3.0E0,0.0E0,0.0E0,0.0E0,
CS   6          -24.0E0,7.0E0,-1.0E0,0.0E0,0.0E0,0.0E0,
CS   7           6.0E0,-2.0E0,0.0E0,0.0E0,0.0E0,0.0E0,
CS   8          -2.0E0,1.0E0,0.0E0,0.0E0,0.0E0,0.0E0,
CS   9           1.0E0,0.0E0,0.0E0,0.0E0,0.0E0,0.0E0/
CD    DATA BJ0P/ 0.0D0,1.8144D6,-2.3688D5,1.0845D4,-2.7D2,5.0D0,
CD   1          -1.8144D5,2.394D4,-1.125D3,30.0D0,-1.0D0,0.0D0,
CD   2           0.0D0,2.016D4,-2.7D3,1.32D2,-4.0D0,0.0D0,
CD   3          -2.52D3,3.45D2,-18.0D0,1.0D0,0.0D0,0.0D0,
CD   4           0.0D0,3.6D2,-51.0D0,3.0D0,0.0D0,0.0D0,
CD   5          -60.0D0,9.0D0,-1.0D0,0.0D0,0.0D0,0.0D0,
CD   6           0.0D0,12.0D0,-2.0D0,0.0D0,0.0D0,0.0D0,
CD   7          -3.0D0,1.0D0,0.0D0,0.0D0,0.0D0,0.0D0,
CD   8           0.0D0,1.0D0,0.0D0,0.0D0,0.0D0,0.0D0,
CD   9          -1.0D0,0.0D0,0.0D0,0.0D0,0.0D0,0.0D0/
CD    DATA BJ1P/-3.6288D6,9.2736D5,-6.201D4,1.965D3,-40.0D0,1.0D0,
CD   1           3.6288D5,-9.324D4,6.345D3,-2.1D2,5.0D0,0.0D0,
CD   2          -4.032D4,1.044D4,-7.29D2,26.0D0,-1.0D0,0.0D0,
CD   3           5.04D3,-1.32D3,96.0D0,-4.0D0,0.0D0,0.0D0,
CD   4          -7.2D2,1.92D2,-15.0D0,1.0D0,0.0D0,0.0D0,
CD   5           1.2D2,-33.0D0,3.0D0,0.0D0,0.0D0,0.0D0,
CD   6          -24.0D0,7.0D0,-1.0D0,0.0D0,0.0D0,0.0D0,
CD   7           6.0D0,-2.0D0,0.0D0,0.0D0,0.0D0,0.0D0,
CD   8          -2.0D0,1.0D0,0.0D0,0.0D0,0.0D0,0.0D0,
CD   9           1.0D0,0.0D0,0.0D0,0.0D0,0.0D0,0.0D0/
C--------------------------------------------------------------------
C  Zeroes of J0
C--------------------------------------------------------------------
CS    DATA XI/616.0E0,1413.0E0/
CS    DATA YX(1)/-7.3927 64822 17001 92757 E-4/,
CS   1     YX(2)/-1.8608 65179 75735 03393 E-4/
CD    DATA XI/616.0D0,1413.0D0/
CD    DATA YX(1)/-7.3927 64822 17001 92757 D-4/,
CD   1     YX(2)/-1.8608 65179 75738 79013 D-4/
C--------------------------------------------------------------------
C  Statement functions for conversion between integer and float
C--------------------------------------------------------------------
CS    CONV(NDUM) = REAL(NDUM)
CD    CONV(NDUM) = DBLE(NDUM)
C--------------------------------------------------------------------
C  Determine machine parameters and set constants
C--------------------------------------------------------------------
      CALL MACHAR(IBETA,IT,IRND,NGRD,MACHEP,NEGEP,IEXP,MINEXP,
     1            MAXEXP,EPS,EPSNEG,XMIN,XMAX)
      BETA = CONV(IBETA)
      ALBETA = LOG(BETA)
      AIT = CONV(IT)
      JT = 0
      B = ZERO
C--------------------------------------------------------------------
C  Random argument accuracy tests (based on a Taylor expansion)
C--------------------------------------------------------------------
      DO 300 J = 1, 3
         K1 = 0
         K2 = 0
         K3 = 0
         X1 = ZERO
         R6 = ZERO
         R7 = ZERO
         N = 2000
         A = B
         IF (J .EQ. 1) THEN
               B = FOUR
            ELSE IF (J .EQ. 2) THEN
               B = EIGHT
            ELSE
               B = TWENTY
               N = 2000
         END IF
         XN = CONV(N)
         DEL = (B - A) / XN
         XL = A
         DO 200 I = 1, N
            X = DEL * REN(JT) + XL
C--------------------------------------------------------------------
C  Carefully purify arguments and evaluate identities
C--------------------------------------------------------------------
            Y = X - DELTA
            W = SIXTEN * Y
            Y = (W + Y) - W
            X = Y + DELTA
            SUM = ZERO
            TERM = ZERO
            BJ0 = BESJ0(Y)
            Z = BESJ0(X)
            D = DELTA
            IF (ABS(Z) .LT. ABS(BJ0)) THEN
               CJ0 = X
               X = Y
               Y = CJ0
               CJ0 = BJ0
               BJ0 = Z
               Z = CJ0
               D = -D
            END IF
            BJ1 = BESJ1(Y)
            YINV = ONE/Y
            YSQ = ONE/(Y*Y)
            XM = ELEV
C--------------------------------------------------------------------
C  Evaluate (12-II)th derivative at Y.
C--------------------------------------------------------------------
            DO 170 II = 1, 10
               CJ0 = BJ0P(1,II)
               CJ1 = BJ1P(1,II)
               JJ = (11-II)/2 + 1
               DO 160  III = 2, JJ
                  CJ0 = CJ0 * YSQ + BJ0P(III,II)
                  CJ1 = CJ1 * YSQ + BJ1P(III,II)
  160          CONTINUE
               IF ((II/2)*2 .NE. II) THEN
                     CJ0 = CJ0 * YINV
                  ELSE
                     CJ1 = CJ1 * YINV
               ENDIF
               TERM = CJ0*BJ0 + CJ1*BJ1
               SUM = (SUM + TERM) * D/XM
               XM = XM - ONE
  170       CONTINUE
            SUM = (SUM - BJ1)*D + BJ0
            ZZ = SUM
C--------------------------------------------------------------------
C  Accumulate results
C--------------------------------------------------------------------
            W = (Z - ZZ) / Z
            IF (W .GT. ZERO) THEN
                  K1 = K1 + 1
               ELSE IF (W .LT. ZERO) THEN
                  K3 = K3 + 1
               ELSE
                  K2 = K2 + 1
            END IF
            W = ABS(W)
            IF (W .GT. R6) THEN
               R6 = W
               X1 = X
            END IF
            R7 = R7 + W * W
            XL = XL + DEL
  200    CONTINUE
C--------------------------------------------------------------------
C  Process and output statistics
C--------------------------------------------------------------------
         N = K1 + K2 + K3
         R7 = SQRT(R7/XN)
         WRITE (IOUT,1000)
         WRITE (IOUT,1010) N,A,B
         WRITE (IOUT,1011) K1,K2,K3
         WRITE (IOUT,1020) IT,IBETA
         IF (R6 .NE. ZERO) THEN
               W = LOG(ABS(R6))/ALBETA
            ELSE
               W = ALL9
         END IF
         WRITE (IOUT,1021) R6,IBETA,W,X1
         W = MAX(AIT+W,ZERO)
         WRITE (IOUT,1022) IBETA,W
         IF (R7 .NE. ZERO) THEN
               W = LOG(ABS(R7))/ALBETA
            ELSE
               W = ALL9
         END IF
         WRITE (IOUT,1023) R7,IBETA,W
         W = MAX(AIT+W,ZERO)
         WRITE (IOUT,1022) IBETA,W
  300 CONTINUE
C--------------------------------------------------------------------
C  Special tests
C--------------------------------------------------------------------
      WRITE (IOUT,1030)
      WRITE (IOUT,1031) IBETA
      DO 330 I = 1, 2  
         X = XI(I)/TWO56
         Y = BESJ0(X)
         T = (Y-YX(I))/YX(I)
         IF (T .NE. ZERO) THEN
               W = LOG(ABS(T))/ALBETA
            ELSE
               W = ALL9
         END IF
         W = MAX(AIT+W,ZERO)
         WRITE (IOUT,1032) X,Y,W
  330 CONTINUE
C--------------------------------------------------------------------
C  Test of error returns
C--------------------------------------------------------------------
      WRITE (IOUT,1033)
      X = XMAX
      WRITE (IOUT,1034) X
      Y = BESJ0(X)
      WRITE (IOUT,1036) Y
      WRITE (IOUT,1100)
      STOP
C--------------------------------------------------------------------
 1000 FORMAT('1Test of J0(X) VS Taylor expansion'  //)
 1010 FORMAT(I7,' random arguments were tested from the interval ',
     1 1H(,F5.1,1H,,F5.1,1H)//)
 1011 FORMAT(' ABS(J0(X)) was larger',I6,' times', /
     1     15X,' agreed',I6,' times, and'/
     1   11X,'was smaller',I6,' times.'//)
 1020 FORMAT(' There are',I4,' base',I4,
     1    ' significant digits in a floating-point number.' //)
 1021 FORMAT(' The maximum relative error of',E15.4,3H = ,I4,3H **,
     1  F7.2/4X,'occurred for X =',E13.6)
 1022 FORMAT(' The estimated loss of base',I4,
     1  ' significant digits is',F7.2//)
 1023 FORMAT(' The root mean square relative error was',E15.4,
     1    3H = ,I4,3H **,F7.2)
 1030 FORMAT('1Special Tests'//)
 1031 FORMAT(' Accuracy near zeros'//10X,'X',15X,'BESJ0(X)',
     1    13X,'Loss of base',I3,' digits'/)
 1032 FORMAT(E20.10,E25.15,8X,F7.2/)
 1033 FORMAT(//' Test with extreme arguments'///)
 1034 FORMAT(' J0 will be called with the argument ',E17.10/
     1     ' This may stop execution.'//)
 1036 FORMAT(' J0 returned the value',E25.17/)
 1100 FORMAT(' This concludes the tests.')
C---------- Last card of BESJ0 test program ----------
      END


      SUBROUTINE CALJY0(ARG,RESULT,JINT)
C---------------------------------------------------------------------
C
C This packet computes zero-order Bessel functions of the first and
C   second kind (J0 and Y0), for real arguments X, where 0 < X <= XMAX
C   for Y0, and |X| <= XMAX for J0.  It contains two function-type
C   subprograms,  BESJ0  and  BESY0,  and one subroutine-type
C   subprogram,  CALJY0.  The calling statements for the primary
C   entries are:
C
C           Y = BESJ0(X)
C   and
C           Y = BESY0(X),
C
C   where the entry points correspond to the functions J0(X) and Y0(X),
C   respectively.  The routine  CALJY0  is intended for internal packet
C   use only, all computations within the packet being concentrated in
C   this one routine.  The function subprograms invoke  CALJY0  with
C   the statement
C           CALL CALJY0(ARG,RESULT,JINT),
C   where the parameter usage is as follows:
C
C      Function                  Parameters for CALJY0
C       call              ARG             RESULT          JINT
C
C     BESJ0(ARG)     |ARG| .LE. XMAX       J0(ARG)          0
C     BESY0(ARG)   0 .LT. ARG .LE. XMAX    Y0(ARG)          1
C
C   The main computation uses unpublished minimax rational
C   approximations for X .LE. 8.0, and an approximation from the
C   book  Computer Approximations  by Hart, et. al., Wiley and Sons,
C   New York, 1968, for arguments larger than 8.0   Part of this
C   transportable packet is patterned after the machine-dependent
C   FUNPACK program BESJ0(X), but cannot match that version for
C   efficiency or accuracy.  This version uses rational functions
C   that are theoretically accurate to at least 18 significant decimal
C   digits for X <= 8, and at least 18 decimal places for X > 8.  The
C   accuracy achieved depends on the arithmetic system, the compiler,
C   the intrinsic functions, and proper selection of the machine-
C   dependent constants.
C
C*******************************************************************
C
C The following machine-dependent constants must be declared in
C   DATA statements.  IEEE values are provided as a default.
C
C   XINF   = largest positive machine number
C   XMAX   = largest acceptable argument.  The functions AINT, SIN
C            and COS must perform properly for  ABS(X) .LE. XMAX.
C            We recommend that XMAX be a small integer multiple of
C            sqrt(1/eps), where eps is the smallest positive number
C            such that  1+eps > 1.
C   XSMALL = positive argument such that  1.0-(X/2)**2 = 1.0
C            to machine precision for all  ABS(X) .LE. XSMALL.
C            We recommend that  XSMALL < sqrt(eps)/beta, where beta
C            is the floating-point radix (usually 2 or 16).
C
C     Approximate values for some important machines are
C
C                          eps      XMAX     XSMALL      XINF
C
C  CDC 7600      (S.P.)  7.11E-15  1.34E+08  2.98E-08  1.26E+322
C  CRAY-1        (S.P.)  7.11E-15  1.34E+08  2.98E-08  5.45E+2465
C  IBM PC (8087) (S.P.)  5.96E-08  8.19E+03  1.22E-04  3.40E+38
C  IBM PC (8087) (D.P.)  1.11D-16  2.68D+08  3.72D-09  1.79D+308
C  IBM 195       (D.P.)  2.22D-16  6.87D+09  9.09D-13  7.23D+75
C  UNIVAC 1108   (D.P.)  1.73D-18  4.30D+09  2.33D-10  8.98D+307
C  VAX 11/780    (D.P.)  1.39D-17  1.07D+09  9.31D-10  1.70D+38
C
C*******************************************************************
C*******************************************************************
C
C Error Returns
C
C  The program returns the value zero for  X .GT. XMAX, and returns
C    -XINF when BESLY0 is called with a negative or zero argument.
C
C
C Intrinsic functions required are:
C
C     ABS, AINT, COS, LOG, SIN, SQRT
C
C
C  Latest modification: March 13, 1992
C
C  Author: W. J. Cody
C          Mathematics and Computer Science Division
C          Argonne National Laboratory
C          Argonne, IL 60439
C
C--------------------------------------------------------------------
      INTEGER I,JINT
CS    REAL
CD    DOUBLE PRECISION
     1       ARG,AX,CONS,DOWN,EIGHT,FIVE5,FOUR,ONE,ONEOV8,PI2,PJ0,
     2       PJ1,PLG,PROD,PY0,PY1,PY2,P0,P1,P17,QJ0,QJ1,QLG,QY0,QY1,
     3       QY2,Q0,Q1,RESJ,RESULT,R0,R1,SIXTY4,THREE,TWOPI,TWOPI1,
     4       TWOPI2,TWO56,UP,W,WSQ,XDEN,XINF,XMAX,XNUM,XSMALL,XJ0,
     5       XJ1,XJ01,XJ02,XJ11,XJ12,XY,XY0,XY01,XY02,XY1,XY11,XY12,
     6       XY2,XY21,XY22,Z,ZERO,ZSQ
      DIMENSION PJ0(7),PJ1(8),PLG(4),PY0(6),PY1(7),PY2(8),P0(6),P1(6),
     1          QJ0(5),QJ1(7),QLG(4),QY0(5),QY1(6),QY2(7),Q0(5),Q1(5)
C-------------------------------------------------------------------
C  Mathematical constants
C    CONS = ln(.5) + Euler's gamma
C-------------------------------------------------------------------
CS    DATA ZERO,ONE,THREE,FOUR,EIGHT/0.0E0,1.0E0,3.0E0,4.0E0,8.0E0/,
CS   1     FIVE5,SIXTY4,ONEOV8,P17/5.5E0,64.0E0,0.125E0,1.716E-1/,
CS   2     TWO56,CONS/256.0E0,-1.1593151565841244881E-1/,
CS   3     PI2,TWOPI/6.3661977236758134308E-1,6.2831853071795864769E0/,
CS   4     TWOPI1,TWOPI2/6.28125E0,1.9353071795864769253E-3/
CD    DATA ZERO,ONE,THREE,FOUR,EIGHT/0.0D0,1.0D0,3.0D0,4.0D0,8.0D0/,
CD   1     FIVE5,SIXTY4,ONEOV8,P17/5.5D0,64.0D0,0.125D0,1.716D-1/,
CD   2     TWO56,CONS/256.0D0,-1.1593151565841244881D-1/,
CD   3     PI2,TWOPI/6.3661977236758134308D-1,6.2831853071795864769D0/,
CD   4     TWOPI1,TWOPI2/6.28125D0,1.9353071795864769253D-3/
C-------------------------------------------------------------------
C  Machine-dependent constants
C-------------------------------------------------------------------
CS    DATA XMAX/8.19E+03/,XSMALL/1.22E-04/,XINF/3.40E+38/
CD    DATA XMAX/2.68D+08/,XSMALL/3.72D-09/,XINF/1.79D+308/
C-------------------------------------------------------------------
C  Zeroes of Bessel functions
C-------------------------------------------------------------------
CS    DATA XJ0/2.4048255576957727686E+0/,XJ1/5.5200781102863106496E+0/,
CS   1     XY0/8.9357696627916752158E-1/,XY1/3.9576784193148578684E+0/,
CS   2     XY2/7.0860510603017726976E+0/,
CS   3     XJ01/ 616.0E+0/, XJ02/-1.4244423042272313784E-03/,
CS   4     XJ11/1413.0E+0/, XJ12/ 5.4686028631064959660E-04/,
CS   5     XY01/ 228.0E+0/, XY02/ 2.9519662791675215849E-03/,
CS   6     XY11/1013.0E+0/, XY12/ 6.4716931485786837568E-04/,
CS   7     XY21/1814.0E+0/, XY22/ 1.1356030177269762362E-04/
CD    DATA XJ0/2.4048255576957727686D+0/,XJ1/5.5200781102863106496D+0/,
CD   1     XY0/8.9357696627916752158D-1/,XY1/3.9576784193148578684D+0/,
CD   2     XY2/7.0860510603017726976D+0/,
CD   3     XJ01/ 616.0D+0/, XJ02/-1.4244423042272313784D-03/,
CD   4     XJ11/1413.0D+0/, XJ12/ 5.4686028631064959660D-04/,
CD   5     XY01/ 228.0D+0/, XY02/ 2.9519662791675215849D-03/,
CD   6     XY11/1013.0D+0/, XY12/ 6.4716931485786837568D-04/,
CD   7     XY21/1814.0D+0/, XY22/ 1.1356030177269762362D-04/
C-------------------------------------------------------------------
C  Coefficients for rational approximation to ln(x/a)
C--------------------------------------------------------------------
CS    DATA PLG/-2.4562334077563243311E+01,2.3642701335621505212E+02,
CS   1         -5.4989956895857911039E+02,3.5687548468071500413E+02/
CS    DATA QLG/-3.5553900764052419184E+01,1.9400230218539473193E+02,
CS   1         -3.3442903192607538956E+02,1.7843774234035750207E+02/
CD    DATA PLG/-2.4562334077563243311D+01,2.3642701335621505212D+02,
CD   1         -5.4989956895857911039D+02,3.5687548468071500413D+02/
CD    DATA QLG/-3.5553900764052419184D+01,1.9400230218539473193D+02,
CD   1         -3.3442903192607538956D+02,1.7843774234035750207D+02/
C-------------------------------------------------------------------
C  Coefficients for rational approximation of
C  J0(X) / (X**2 - XJ0**2),  XSMALL  <  |X|  <=  4.0
C--------------------------------------------------------------------
CS    DATA PJ0/6.6302997904833794242E+06,-6.2140700423540120665E+08,
CS   1         2.7282507878605942706E+10,-4.1298668500990866786E+11,
CS   2        -1.2117036164593528341E-01, 1.0344222815443188943E+02,
CS   3        -3.6629814655107086448E+04/
CS    DATA QJ0/4.5612696224219938200E+05, 1.3985097372263433271E+08,
CS   1         2.6328198300859648632E+10, 2.3883787996332290397E+12,
CS   2         9.3614022392337710626E+02/
CD    DATA PJ0/6.6302997904833794242D+06,-6.2140700423540120665D+08,
CD   1         2.7282507878605942706D+10,-4.1298668500990866786D+11,
CD   2        -1.2117036164593528341D-01, 1.0344222815443188943D+02,
CD   3        -3.6629814655107086448D+04/
CD    DATA QJ0/4.5612696224219938200D+05, 1.3985097372263433271D+08,
CD   1         2.6328198300859648632D+10, 2.3883787996332290397D+12,
CD   2         9.3614022392337710626D+02/
C-------------------------------------------------------------------
C  Coefficients for rational approximation of
C  J0(X) / (X**2 - XJ1**2),  4.0  <  |X|  <=  8.0
C-------------------------------------------------------------------
CS    DATA PJ1/4.4176707025325087628E+03, 1.1725046279757103576E+04,
CS   1         1.0341910641583726701E+04,-7.2879702464464618998E+03,
CS   2        -1.2254078161378989535E+04,-1.8319397969392084011E+03,
CS   3         4.8591703355916499363E+01, 7.4321196680624245801E+02/
CS    DATA QJ1/3.3307310774649071172E+02,-2.9458766545509337327E+03,
CS   1         1.8680990008359188352E+04,-8.4055062591169562211E+04,
CS   2         2.4599102262586308984E+05,-3.5783478026152301072E+05,
CS   3        -2.5258076240801555057E+01/
CD    DATA PJ1/4.4176707025325087628D+03, 1.1725046279757103576D+04,
CD   1         1.0341910641583726701D+04,-7.2879702464464618998D+03,
CD   2        -1.2254078161378989535D+04,-1.8319397969392084011D+03,
CD   3         4.8591703355916499363D+01, 7.4321196680624245801D+02/
CD    DATA QJ1/3.3307310774649071172D+02,-2.9458766545509337327D+03,
CD   1         1.8680990008359188352D+04,-8.4055062591169562211D+04,
CD   2         2.4599102262586308984D+05,-3.5783478026152301072D+05,
CD   3        -2.5258076240801555057D+01/
C-------------------------------------------------------------------
C  Coefficients for rational approximation of
C    (Y0(X) - 2 LN(X/XY0) J0(X)) / (X**2 - XY0**2),
C        XSMALL  <  |X|  <=  3.0
C--------------------------------------------------------------------
CS    DATA PY0/1.0102532948020907590E+04,-2.1287548474401797963E+06,
CS   1         2.0422274357376619816E+08,-8.3716255451260504098E+09,
CS   2         1.0723538782003176831E+11,-1.8402381979244993524E+01/
CS    DATA QY0/6.6475986689240190091E+02, 2.3889393209447253406E+05,
CS   1         5.5662956624278251596E+07, 8.1617187777290363573E+09,
CS   2         5.8873865738997033405E+11/
CD    DATA PY0/1.0102532948020907590D+04,-2.1287548474401797963D+06,
CD   1         2.0422274357376619816D+08,-8.3716255451260504098D+09,
CD   2         1.0723538782003176831D+11,-1.8402381979244993524D+01/
CD    DATA QY0/6.6475986689240190091D+02, 2.3889393209447253406D+05,
CD   1         5.5662956624278251596D+07, 8.1617187777290363573D+09,
CD   2         5.8873865738997033405D+11/
C-------------------------------------------------------------------
C  Coefficients for rational approximation of
C    (Y0(X) - 2 LN(X/XY1) J0(X)) / (X**2 - XY1**2),
C        3.0  <  |X|  <=  5.5
C--------------------------------------------------------------------
CS    DATA PY1/-1.4566865832663635920E+04, 4.6905288611678631510E+06,
CS   1         -6.9590439394619619534E+08, 4.3600098638603061642E+10,
CS   2         -5.5107435206722644429E+11,-2.2213976967566192242E+13,
CS   3          1.7427031242901594547E+01/
CS    DATA QY1/ 8.3030857612070288823E+02, 4.0669982352539552018E+05,
CS   1          1.3960202770986831075E+08, 3.4015103849971240096E+10,
CS   2          5.4266824419412347550E+12, 4.3386146580707264428E+14/
CD    DATA PY1/-1.4566865832663635920D+04, 4.6905288611678631510D+06,
CD   1         -6.9590439394619619534D+08, 4.3600098638603061642D+10,
CD   2         -5.5107435206722644429D+11,-2.2213976967566192242D+13,
CD   3          1.7427031242901594547D+01/
CD    DATA QY1/ 8.3030857612070288823D+02, 4.0669982352539552018D+05,
CD   1          1.3960202770986831075D+08, 3.4015103849971240096D+10,
CD   2          5.4266824419412347550D+12, 4.3386146580707264428D+14/
C-------------------------------------------------------------------
C  Coefficients for rational approximation of
C    (Y0(X) - 2 LN(X/XY2) J0(X)) / (X**2 - XY2**2),
C        5.5  <  |X|  <=  8.0
C--------------------------------------------------------------------
CS    DATA PY2/ 2.1363534169313901632E+04,-1.0085539923498211426E+07,
CS   1          2.1958827170518100757E+09,-1.9363051266772083678E+11,
CS   2         -1.2829912364088687306E+11, 6.7016641869173237784E+14,
CS   3         -8.0728726905150210443E+15,-1.7439661319197499338E+01/
CS    DATA QY2/ 8.7903362168128450017E+02, 5.3924739209768057030E+05,
CS   1          2.4727219475672302327E+08, 8.6926121104209825246E+10,
CS   2          2.2598377924042897629E+13, 3.9272425569640309819E+15,
CS   3          3.4563724628846457519E+17/
CD    DATA PY2/ 2.1363534169313901632D+04,-1.0085539923498211426D+07,
CD   1          2.1958827170518100757D+09,-1.9363051266772083678D+11,
CD   2         -1.2829912364088687306D+11, 6.7016641869173237784D+14,
CD   3         -8.0728726905150210443D+15,-1.7439661319197499338D+01/
CD    DATA QY2/ 8.7903362168128450017D+02, 5.3924739209768057030D+05,
CD   1          2.4727219475672302327D+08, 8.6926121104209825246D+10,
CD   2          2.2598377924042897629D+13, 3.9272425569640309819D+15,
CD   3          3.4563724628846457519D+17/
C-------------------------------------------------------------------
C  Coefficients for Hart,s approximation,  |X| > 8.0
C-------------------------------------------------------------------
CS    DATA P0/3.4806486443249270347E+03, 2.1170523380864944322E+04,
CS   1        4.1345386639580765797E+04, 2.2779090197304684302E+04,
CS   2        8.8961548424210455236E-01, 1.5376201909008354296E+02/
CS    DATA Q0/3.5028735138235608207E+03, 2.1215350561880115730E+04,
CS   1        4.1370412495510416640E+04, 2.2779090197304684318E+04,
CS   2        1.5711159858080893649E+02/
CS    DATA P1/-2.2300261666214198472E+01,-1.1183429920482737611E+02,
CS   1        -1.8591953644342993800E+02,-8.9226600200800094098E+01,
CS   2        -8.8033303048680751817E-03,-1.2441026745835638459E+00/
CS    DATA Q1/1.4887231232283756582E+03, 7.2642780169211018836E+03,
CS   1        1.1951131543434613647E+04, 5.7105024128512061905E+03,
CS   2        9.0593769594993125859E+01/
CD    DATA P0/3.4806486443249270347D+03, 2.1170523380864944322D+04,
CD   1        4.1345386639580765797D+04, 2.2779090197304684302D+04,
CD   2        8.8961548424210455236D-01, 1.5376201909008354296D+02/
CD    DATA Q0/3.5028735138235608207D+03, 2.1215350561880115730D+04,
CD   1        4.1370412495510416640D+04, 2.2779090197304684318D+04,
CD   2        1.5711159858080893649D+02/
CD    DATA P1/-2.2300261666214198472D+01,-1.1183429920482737611D+02,
CD   1        -1.8591953644342993800D+02,-8.9226600200800094098D+01,
CD   2        -8.8033303048680751817D-03,-1.2441026745835638459D+00/
CD    DATA Q1/1.4887231232283756582D+03, 7.2642780169211018836D+03,
CD   1        1.1951131543434613647D+04, 5.7105024128512061905D+03,
CD   2        9.0593769594993125859D+01/
C-------------------------------------------------------------------
C  Check for error conditions
C-------------------------------------------------------------------
      AX = ABS(ARG)
      IF ((JINT .EQ. 1) .AND. (ARG .LE. ZERO)) THEN
            RESULT = -XINF
            GO TO 2000
         ELSE IF (AX .GT. XMAX) THEN
            RESULT = ZERO
            GO TO 2000
      END IF
      IF (AX .GT. EIGHT) GO TO 800
      IF (AX .LE. XSMALL) THEN
         IF (JINT .EQ. 0) THEN
               RESULT = ONE
            ELSE
               RESULT = PI2 * (LOG(AX) + CONS)
         END IF
         GO TO 2000
      END IF
C-------------------------------------------------------------------
C  Calculate J0 for appropriate interval, preserving
C     accuracy near the zero of J0
C-------------------------------------------------------------------
      ZSQ = AX * AX
      IF (AX .LE. FOUR) THEN
            XNUM = (PJ0(5) * ZSQ + PJ0(6)) * ZSQ + PJ0(7)
            XDEN = ZSQ + QJ0(5)
            DO 50 I = 1, 4
               XNUM = XNUM * ZSQ + PJ0(I)
               XDEN = XDEN * ZSQ + QJ0(I)
   50       CONTINUE
            PROD = ((AX - XJ01/TWO56) - XJ02) * (AX + XJ0)
         ELSE
            WSQ = ONE - ZSQ / SIXTY4
            XNUM = PJ1(7) * WSQ + PJ1(8)
            XDEN = WSQ + QJ1(7)
            DO 220 I = 1, 6
               XNUM = XNUM * WSQ + PJ1(I)
               XDEN = XDEN * WSQ + QJ1(I)
  220       CONTINUE
            PROD = (AX + XJ1) * ((AX - XJ11/TWO56) - XJ12)
      END IF
      RESULT = PROD * XNUM / XDEN
      IF (JINT .EQ. 0) GO TO 2000
C-------------------------------------------------------------------
C  Calculate Y0.  First find  RESJ = pi/2 ln(x/xn) J0(x),
C    where xn is a zero of Y0
C-------------------------------------------------------------------
      IF (AX .LE. THREE) THEN
            UP = (AX-XY01/TWO56)-XY02
            XY = XY0
         ELSE IF (AX .LE. FIVE5) THEN
            UP = (AX-XY11/TWO56)-XY12
            XY = XY1
         ELSE
            UP = (AX-XY21/TWO56)-XY22
            XY = XY2
      END IF
      DOWN = AX + XY
      IF (ABS(UP) .LT. P17*DOWN) THEN
            W = UP/DOWN
            WSQ = W*W
            XNUM = PLG(1)
            XDEN = WSQ + QLG(1)
            DO 320 I = 2, 4
               XNUM = XNUM*WSQ + PLG(I)
               XDEN = XDEN*WSQ + QLG(I)
  320       CONTINUE
            RESJ = PI2 * RESULT * W * XNUM/XDEN
         ELSE
            RESJ = PI2 * RESULT * LOG(AX/XY)
      END IF
C-------------------------------------------------------------------
C  Now calculate Y0 for appropriate interval, preserving
C     accuracy near the zero of Y0
C-------------------------------------------------------------------
      IF (AX .LE. THREE) THEN
            XNUM = PY0(6) * ZSQ + PY0(1)
            XDEN = ZSQ + QY0(1)
            DO 340 I = 2, 5
               XNUM = XNUM * ZSQ + PY0(I)
               XDEN = XDEN * ZSQ + QY0(I)
  340       CONTINUE
         ELSE IF (AX .LE. FIVE5) THEN
            XNUM = PY1(7) * ZSQ + PY1(1)
            XDEN = ZSQ + QY1(1)
            DO 360 I = 2, 6
               XNUM = XNUM * ZSQ + PY1(I)
               XDEN = XDEN * ZSQ + QY1(I)
  360       CONTINUE
         ELSE
            XNUM = PY2(8) * ZSQ + PY2(1)
            XDEN = ZSQ + QY2(1)
            DO 380 I = 2, 7
               XNUM = XNUM * ZSQ + PY2(I)
               XDEN = XDEN * ZSQ + QY2(I)
  380       CONTINUE
      END IF
      RESULT = RESJ + UP * DOWN * XNUM / XDEN
      GO TO 2000
C-------------------------------------------------------------------
C  Calculate J0 or Y0 for |ARG|  >  8.0
C-------------------------------------------------------------------
  800 Z = EIGHT / AX
      W = AX / TWOPI
      W = AINT(W) + ONEOV8
      W = (AX - W * TWOPI1) - W * TWOPI2
      ZSQ = Z * Z
      XNUM = P0(5) * ZSQ + P0(6)
      XDEN = ZSQ + Q0(5)
      UP = P1(5) * ZSQ + P1(6)
      DOWN = ZSQ + Q1(5)
      DO 850 I = 1, 4
         XNUM = XNUM * ZSQ + P0(I)
         XDEN = XDEN * ZSQ + Q0(I)
         UP = UP * ZSQ + P1(I)
         DOWN = DOWN * ZSQ + Q1(I)
  850 CONTINUE
      R0 = XNUM / XDEN
      R1 = UP / DOWN
      IF (JINT .EQ. 0) THEN
            RESULT = SQRT(PI2/AX) * (R0*COS(W) - Z*R1*SIN(W))
         ELSE
            RESULT = SQRT(PI2/AX) * (R0*SIN(W) + Z*R1*COS(W))
      END IF
 2000 RETURN
C---------- Last line of CALJY0 ----------
      END
CS    REAL FUNCTION BESJ0(X)
CD    DOUBLE PRECISION FUNCTION BESJ0(X)
C--------------------------------------------------------------------
C
C This subprogram computes approximate values for Bessel functions
C   of the first kind of order zero for arguments  |X| <= XMAX
C   (see comments heading CALJY0).
C
C--------------------------------------------------------------------
      INTEGER JINT
CS    REAL  X, RESULT
CD    DOUBLE PRECISION  X, RESULT
C--------------------------------------------------------------------
      JINT=0
      CALL CALJY0(X,RESULT,JINT)
      BESJ0 = RESULT
      RETURN
C---------- Last line of BESJ0 ----------
      END
CS    REAL FUNCTION BESY0(X)
CD    DOUBLE PRECISION FUNCTION BESY0(X)
C--------------------------------------------------------------------
C
C This subprogram computes approximate values for Bessel functions
C   of the second kind of order zero for arguments 0 < X <= XMAX
C   (see comments heading CALJY0).
C
C--------------------------------------------------------------------
      INTEGER JINT
CS    REAL  X, RESULT
CD    DOUBLE PRECISION  X, RESULT
C--------------------------------------------------------------------
      JINT=1
      CALL CALJY0(X,RESULT,JINT)
      BESY0 = RESULT
      RETURN
C---------- Last line of BESY0 ----------
      END
      PROGRAM J1TEST
C--------------------------------------------------------------------
C  Fortran 77 program to test BESJ1
C
C  Data required
C
C     None
C
C  Subprograms required from this package
C
C     MACHAR - an environmental inquiry program providing
C              information on the floating-point arithmetic
C              system.  Note that the call to MACHAR can
C              be deleted provided the following six
C              parameters are assigned the values indicated
C
C                 IBETA  - the radix of the floating-point system
C                 IT     - the number of base-IBETA digits in the
C                          significand of a floating-point number
C                 MAXEXP - the smallest integer such that 
C                          FLOAT(IBETA)**MAXEXP causes overflow
C                 EPS    - the smallest positive floating-point
C                          number such that 1.0+EPS .NE. 1.0
C                 XMIN   - the smallest positive normalized
C                          floating-point power of the radix
C                 XMAX   - the largest finite floating-point
C                          number
C
C     REN(K) - a function subprogram returning random real
C              numbers uniformly distributed over (0,1)
C
C
C  Intrinsic functions required are:
C
C         ABS, DBLE, FLOAT, LOG, MAX, SIGN, SQRT
C
C  Reference: "The use of Taylor series to test accuracy of
C              function programs", W. J. Cody and L. Stoltz,
C              submitted for publication.
C
C  Latest modification: March 13, 1992
C
C  Authors: W. J. Cody
C           Mathematics and Computer Science Division
C           Argonne National Laboratory
C           Argonne, IL 60439
C
C--------------------------------------------------------------------
      INTEGER I,IBETA,IEXP,II,III,IOUT,IRND,IT,J,JJ,JT,K1,K2,K3,
     1        MACHEP,MAXEXP,MINEXP,N,NDUM,NEGEP,NGRD
CS    REAL
CD    DOUBLE PRECISION
     1   A,AIT,ALBETA,ALL9,B,BESJ0,BESJ1,BETA,BJ0,BJ0P,BJ1,BJ1P,
     2   CJ0,CJ1,CONV,D,DEL,DELTA,EIGHT,ELEV,EPS,EPSNEG,FOUR,ONE,
     3   REN,R6,R7,SIXTEN,SUM,T,TERM,THRTEN,TWENTY,TWO,TWO56,W,X,
     4   XI,XL,XMAX,XMIN,XM,XN,X1,Y,YINV,YSQ,YX,Z,ZERO,ZZ
      DIMENSION BJ0P(6,10),BJ1P(6,10),XI(2),YX(2)
C--------------------------------------------------------------------
C  Mathematical constants
C--------------------------------------------------------------------
      DATA IOUT/6/
CS    DATA ZERO,ONE,FOUR,DELTA/0.0E0,1.0E0,4.0E0,0.0625E0/,
CS   1   EIGHT,TWENTY,ALL9,TWO56/8.0E0,20.0E0,-999.0E0,256.0E0/,
CS   2   TWO,THRTEN,SIXTEN,ELEV/2.0E0,13.0E0,16.0E0,11.0E0/
CD    DATA ZERO,ONE,FOUR,DELTA/0.0D0,1.0D0,4.0E0,0.0625D0/,
CD   1   EIGHT,TWENTY,ALL9,TWO56/8.0D0,20.0D0,-999.0D0,256.0D0/,
CD   2   TWO,THRTEN,SIXTEN,ELEV/2.0D0,13.0D0,16.0D0,11.0D0/
C--------------------------------------------------------------------
C  Coefficients for Taylor expansion
C--------------------------------------------------------------------
CS    DATA BJ0P/1.99584E7,-2.58552E6,1.16235E5,-2.775E3,4.5E1,-1.0E0,
CS   1           0.0E0,-1.8144E6,2.3688E5,-1.0845E4,2.7E2,-5.0E0,
CS   2           1.8144E5,-2.394E4,1.125E3,-30.0E0,1.0E0,0.0E0,
CS   3           0.0E0,-2.016E4,2.7E3,-1.32E2,4.0E0,0.0E0,
CS   4           2.52E3,-3.45E2,18.0E0,-1.0E0,0.0E0,0.0E0,
CS   5           0.0E0,-3.6E2,51.0E0,-3.0E0,0.0E0,0.0E0,
CS   6           60.0E0,-9.0E0,1.0E0,0.0E0,0.0E0,0.0E0,
CS   7           0.0E0,-12.0E0,2.0E0,0.0E0,0.0E0,0.0E0,
CS   8           3.0E0,-1.0E0,0.0E0,0.0E0,0.0E0,0.0E0,
CS   9           0.0E0,-1.0E0,0.0E0,0.0E0,0.0E0,0.0E0/
CS    DATA BJ1P/-3.99168E7,1.016064E7,-6.7095E5,2.067E4,-3.9E2,6.0E0,
CS   1           3.6288E6,-9.2736E5,6.201E4,-1.965E3,40.0E0,-1.0E0,
CS   2          -3.6288E5,9.324E4,-6.345E3,2.1E2,-5.0E0,0.0E0,
CS   3           4.032E4,-1.044E4,7.29E2,-26.0E0,1.0E0,0.0E0,
CS   4          -5.04E3,1.32E3,-96.0E0,4.0E0,0.0E0,0.0E0,
CS   5           7.2E2,-1.92E2,15.0E0,-1.0E0,0.0E0,0.0E0,
CS   6          -1.2E2,33.0E0,-3.0E0,0.0E0,0.0E0,0.0E0,
CS   7           24.0E0,-7.0E0,1.0E0,0.0E0,0.0E0,0.0E0,
CS   8          -6.0E0,2.0E0,0.0E0,0.0E0,0.0E0,0.0E0,
CS   9           2.0E0,-1.0E0,0.0E0,0.0E0,0.0E0,0.0E0/
CD    DATA BJ0P/1.99584D7,-2.58552D6,1.16235D5,-2.775D3,4.5D1,-1.0D0,
CD   1           0.0D0,-1.8144D6,2.3688D5,-1.0845D4,2.7D2,-5.0D0,
CD   2           1.8144D5,-2.394D4,1.125D3,-30.0D0,1.0D0,0.0D0,
CD   3           0.0D0,-2.016D4,2.7D3,-1.32D2,4.0D0,0.0D0,
CD   4           2.52D3,-3.45D2,18.0D0,-1.0D0,0.0D0,0.0D0,
CD   5           0.0D0,-3.6D2,51.0D0,-3.0D0,0.0D0,0.0D0,
CD   6           60.0D0,-9.0D0,1.0D0,0.0D0,0.0D0,0.0D0,
CD   7           0.0D0,-12.0D0,2.0D0,0.0D0,0.0D0,0.0D0,
CD   8           3.0D0,-1.0D0,0.0D0,0.0D0,0.0D0,0.0D0,
CD   9           0.0D0,-1.0D0,0.0D0,0.0D0,0.0D0,0.0D0/
CD    DATA BJ1P/-3.99168D7,1.016064D7,-6.7095D5,2.067D4,-3.9D2,6.0D0,
CD   1           3.6288D6,-9.2736D5,6.201D4,-1.965D3,40.0D0,-1.0D0,
CD   2          -3.6288D5,9.324D4,-6.345D3,2.1D2,-5.0D0,0.0D0,
CD   3           4.032D4,-1.044D4,7.29D2,-26.0D0,1.0D0,0.0D0,
CD   4          -5.04D3,1.32D3,-96.0D0,4.0D0,0.0D0,0.0D0,
CD   5           7.2D2,-1.92D2,15.0D0,-1.0D0,0.0D0,0.0D0,
CD   6          -1.2D2,33.0D0,-3.0D0,0.0D0,0.0D0,0.0D0,
CD   7           24.0D0,-7.0D0,1.0D0,0.0D0,0.0D0,0.0D0,
CD   8          -6.0D0,2.0D0,0.0D0,0.0D0,0.0D0,0.0D0,
CD   9           2.0D0,-1.0D0,0.0D0,0.0D0,0.0D0,0.0D0/
C--------------------------------------------------------------------
C  Zeroes of J1
C--------------------------------------------------------------------
CS    DATA XI/981.0E0,1796.0E0/
CS    DATA YX(1)/-1.3100 39300 13279 72376 E-4/,
CS   1     YX(2)/ 1.1503 46070 23016 98285 E-5/
CD    DATA XI/981.0D0,1796.0D0/
CD    DATA YX(1)/-1.3100 39300 13279 72376 D-4/,
CD   1     YX(2)/ 1.1503 46070 23016 98285 D-5/
C--------------------------------------------------------------------
C  Statement functions for conversion between integer and float
C--------------------------------------------------------------------
CS    CONV(NDUM) = REAL(NDUM)
CD    CONV(NDUM) = DBLE(NDUM)
C--------------------------------------------------------------------
C  Determine machine parameters and set constants
C--------------------------------------------------------------------
      CALL MACHAR(IBETA,IT,IRND,NGRD,MACHEP,NEGEP,IEXP,MINEXP,
     1            MAXEXP,EPS,EPSNEG,XMIN,XMAX)
      BETA = CONV(IBETA)
      ALBETA = LOG(BETA)
      AIT = CONV(IT)
      JT = 0
      B = ZERO
C--------------------------------------------------------------------
C  Random argument accuracy tests (based on a Taylor expansion)
C--------------------------------------------------------------------
      DO 300 J = 1, 4
         K1 = 0
         K2 = 0
         K3 = 0
         X1 = ZERO
         R6 = ZERO
         R7 = ZERO
         N = 2000
         A = B
         IF (J .EQ. 1) THEN
               B = ONE
            ELSE IF (J .EQ. 2) THEN
               B = FOUR
            ELSE IF (J .EQ. 3) THEN
               B = EIGHT
            ELSE
               B = TWENTY
         END IF
         XN = CONV(N)
         DEL = (B - A) / XN
         XL = A
         DO 200 I = 1, N
            X = DEL * REN(JT) + XL
            IF (J .EQ. 1) THEN
C--------------------------------------------------------------------
C  Use traditional Maclaurin series for small arguments.
C--------------------------------------------------------------------
                  Y = X/TWO
                  SUM = Y
                  XM = THRTEN
                  DO 100 II = 1,12
                     SUM = SUM*Y/XM
                     XM = XM-ONE
                     SUM = (ONE - SUM/XM)*Y
  100             CONTINUE
                  ZZ = SUM
                  Z = BESJ1(X)
               ELSE
C--------------------------------------------------------------------
C  Use local Taylor series elsewhere.  First, purify arguments.
C--------------------------------------------------------------------
                  Y = X - DELTA
                  W = SIXTEN * Y
                  Y = (W + Y) - W
                  X = Y + DELTA
                  SUM = ZERO
                  TERM = ZERO
                  BJ1 = BESJ1(Y)
                  Z = BESJ1(X)
                  D = DELTA
                  IF (ABS(Z) .LT. ABS(BJ1)) THEN
                     CJ1 = X
                     X = Y
                     Y = CJ1
                     CJ1 = BJ1
                     BJ1 = Z
                     Z = CJ1
                     D = -D
                  END IF
                  BJ0 = BESJ0(Y)
                  YINV = ONE/Y
                  YSQ = ONE/(Y*Y)
                  XM = ELEV
C--------------------------------------------------------------------
C  Evaluate (12-II)th derivative at Y.
C--------------------------------------------------------------------
                  DO 170 II = 1, 10
                     CJ0 = BJ0P(1,II)
                     CJ1 = BJ1P(1,II)
                     JJ = (12-II)/2 + 1
                     DO 160  III = 2, JJ
                        CJ0 = CJ0 * YSQ + BJ0P(III,II)
                        CJ1 = CJ1 * YSQ + BJ1P(III,II)
  160                CONTINUE
                     IF ((II/2)*2 .EQ. II) THEN
                           CJ0 = CJ0 * YINV
                        ELSE
                           CJ1 = CJ1 * YINV
                     ENDIF
                     TERM = CJ0*BJ0 + CJ1*BJ1
                     SUM = (SUM + TERM) * D/XM
                     XM = XM - ONE
  170             CONTINUE
                  SUM = (SUM + BJ0 - BJ1*YINV)*D + BJ1
                  ZZ = SUM
            END IF
C--------------------------------------------------------------------
C  Accumulate results
C--------------------------------------------------------------------
            W = (Z - ZZ) / Z
            IF (W .GT. ZERO) THEN
                  K1 = K1 + 1
               ELSE IF (W .LT. ZERO) THEN
                  K3 = K3 + 1
               ELSE
                  K2 = K2 + 1
            END IF
            W = ABS(W)
            IF (W .GT. R6) THEN
               R6 = W
               X1 = X
            END IF
            R7 = R7 + W * W
            XL = XL + DEL
  200    CONTINUE
C--------------------------------------------------------------------
C  Process and output statistics
C--------------------------------------------------------------------
         N = K1 + K2 + K3
         R7 = SQRT(R7/XN)
         IF (J .EQ. 1) THEN
               WRITE (IOUT,1000)
            ELSE
               WRITE (IOUT,1001)
         END IF
         WRITE (IOUT,1010) N,A,B
         WRITE (IOUT,1011) K1,K2,K3
         WRITE (IOUT,1020) IT,IBETA
         IF (R6 .NE. ZERO) THEN
               W = LOG(ABS(R6))/ALBETA
            ELSE
               W = ALL9
         END IF
         WRITE (IOUT,1021) R6,IBETA,W,X1
         W = MAX(AIT+W,ZERO)
         WRITE (IOUT,1022) IBETA,W
         IF (R7 .NE. ZERO) THEN
               W = LOG(ABS(R7))/ALBETA
            ELSE
               W = ALL9
         END IF
         WRITE (IOUT,1023) R7,IBETA,W
         W = MAX(AIT+W,ZERO)
         WRITE (IOUT,1022) IBETA,W
  300 CONTINUE
C--------------------------------------------------------------------
C  Special tests
C--------------------------------------------------------------------
      WRITE (IOUT,1030)
      WRITE (IOUT,1031) IBETA
      DO 330 I = 1, 2  
         X = XI(I)/TWO56
         Y = BESJ1(X)
         T = (Y-YX(I))/YX(I)
         IF (T .NE. ZERO) THEN
               W = LOG(ABS(T))/ALBETA
            ELSE
               W = ALL9
         END IF
         W = MAX(AIT+W,ZERO)
         WRITE (IOUT,1032) X,Y,W
  330 CONTINUE
C--------------------------------------------------------------------
C  Test of error returns
C--------------------------------------------------------------------
      WRITE (IOUT,1033)
      X = XMAX
      WRITE (IOUT,1034) X
      Y = BESJ1(X)
      WRITE (IOUT,1036) Y
      WRITE (IOUT,1100)
      STOP
C--------------------------------------------------------------------
 1000 FORMAT('1Test of J1(X) VS Maclaurin expansion'  //)
 1001 FORMAT('1Test of J1(X) VS local Taylor expansion'  //)
 1010 FORMAT(I7,' random arguments were tested from the interval ',
     1 1H(,F5.1,1H,,F5.1,1H)//)
 1011 FORMAT(' ABS(J1(X)) was larger',I6,' times', /
     1     15X,' agreed',I6,' times, and'/
     1   11X,'was smaller',I6,' times.'//)
 1020 FORMAT(' There are',I4,' base',I4,
     1    ' significant digits in a floating-point number.' //)
 1021 FORMAT(' The maximum relative error of',E15.4,3H = ,I4,3H **,
     1  F7.2/4X,'occurred for X =',E13.6)
 1022 FORMAT(' The estimated loss of base',I4,
     1  ' significant digits is',F7.2//)
 1023 FORMAT(' The root mean square relative error was',E15.4,
     1    3H = ,I4,3H **,F7.2)
 1030 FORMAT('1Special Tests'//)
 1031 FORMAT(' Accuracy near zeros'//10X,'X',15X,'BESJ1(X)',
     1    13X,'Loss of base',I3,' digits'/)
 1032 FORMAT(E20.10,E25.15,8X,F7.2/)
 1033 FORMAT(//' Test with extreme arguments'///)
 1034 FORMAT(' J1 will be called with the argument ',E17.10/
     1     ' This may stop execution.'//)
 1036 FORMAT(' J1 returned the value',E25.17/)
 1100 FORMAT(' This concludes the tests.')
C---------- Last card of BESJ1 test program ----------
      END


      SUBROUTINE CALJY1(ARG,RESULT,JINT)
C---------------------------------------------------------------------
C
C This packet computes first-order Bessel functions of the first and
C   second kind (J1 and Y1), for real arguments X, where 0 < X <= XMAX
C   for Y1, and |X| <= XMAX for J1.  It contains two function-type
C   subprograms,  BESJ1  and  BESY1,  and one subroutine-type
C   subprogram,  CALJY1.  The calling statements for the primary
C   entries are:
C
C           Y = BESJ1(X)
C   and
C           Y = BESY1(X),
C
C   where the entry points correspond to the functions J1(X) and Y1(X),
C   respectively.  The routine  CALJY1  is intended for internal packet
C   use only, all computations within the packet being concentrated in
C   this one routine.  The function subprograms invoke  CALJY1  with
C   the statement
C           CALL CALJY1(ARG,RESULT,JINT),
C   where the parameter usage is as follows:
C
C      Function                  Parameters for CALJY1
C       call              ARG             RESULT          JINT
C
C     BESJ1(ARG)     |ARG| .LE. XMAX       J1(ARG)          0
C     BESY1(ARG)   0 .LT. ARG .LE. XMAX    Y1(ARG)          1
C
C   The main computation uses unpublished minimax rational
C   approximations for X .LE. 8.0, and an approximation from the
C   book  Computer Approximations  by Hart, et. al., Wiley and Sons,
C   New York, 1968, for arguments larger than 8.0   Part of this
C   transportable packet is patterned after the machine-dependent
C   FUNPACK program BESJ1(X), but cannot match that version for
C   efficiency or accuracy.  This version uses rational functions
C   that are theoretically accurate to at least 18 significant decimal
C   digits for X <= 8, and at least 18 decimal places for X > 8.  The
C   accuracy achieved depends on the arithmetic system, the compiler,
C   the intrinsic functions, and proper selection of the machine-
C   dependent constants.
C
C*******************************************************************
C
C The following machine-dependent constants must be declared in
C   DATA statements.  IEEE values are provided as a default.
C
C   XINF   = largest positive machine number
C   XMAX   = largest acceptable argument.  The functions AINT, SIN
C            and COS must perform properly for  ABS(X) .LE. XMAX.
C            We recommend that XMAX be a small integer multiple of
C            sqrt(1/eps), where eps is the smallest positive number
C            such that  1+eps > 1.
C   XSMALL = positive argument such that  1.0-(1/2)(X/2)**2 = 1.0
C            to machine precision for all  ABS(X) .LE. XSMALL.
C            We recommend that  XSMALL < sqrt(eps)/beta, where beta
C            is the floating-point radix (usually 2 or 16).
C
C     Approximate values for some important machines are
C
C                          eps      XMAX     XSMALL      XINF
C
C  CDC 7600      (S.P.)  7.11E-15  1.34E+08  2.98E-08  1.26E+322
C  CRAY-1        (S.P.)  7.11E-15  1.34E+08  2.98E-08  5.45E+2465
C  IBM PC (8087) (S.P.)  5.96E-08  8.19E+03  1.22E-04  3.40E+38
C  IBM PC (8087) (D.P.)  1.11D-16  2.68D+08  3.72D-09  1.79D+308
C  IBM 195       (D.P.)  2.22D-16  6.87D+09  9.09D-13  7.23D+75
C  UNIVAC 1108   (D.P.)  1.73D-18  4.30D+09  2.33D-10  8.98D+307
C  VAX 11/780    (D.P.)  1.39D-17  1.07D+09  9.31D-10  1.70D+38
C
C*******************************************************************
C*******************************************************************
C
C Error Returns
C
C  The program returns the value zero for  X .GT. XMAX, and returns
C    -XINF when BESLY1 is called with a negative or zero argument.
C
C
C Intrinsic functions required are:
C
C     ABS, AINT, COS, LOG, SIN, SQRT
C
C
C  Author: W. J. Cody
C          Mathematics and Computer Science Division
C          Argonne National Laboratory
C          Argonne, IL 60439
C
C  Latest modification: March 13, 1992
C
C--------------------------------------------------------------------
      INTEGER I,JINT
      DIMENSION PJ0(7),PJ1(8),PLG(4),PY0(7),PY1(9),P0(6),P1(6),
     1          QJ0(5),QJ1(7),QLG(4),QY0(6),QY1(8),Q0(6),Q1(6)
CS    REAL
CD    DOUBLE PRECISION
     1   ARG,AX,DOWN,EIGHT,FOUR,HALF,PI2,PJ0,PJ1,PLG,PROD,PY0,
     2   PY1,P0,P1,P17,QJ0,QJ1,QLG,QY0,QY1,Q0,Q1,RESJ,RESULT,
     3   RTPI2,R0,R1,THROV8,TWOPI,TWOPI1,TWOPI2,TWO56,UP,W,WSQ,
     4   XDEN,XINF,XMAX,XNUM,XSMALL,XJ0,XJ1,XJ01,XJ02,XJ11,XJ12,
     5   XY,XY0,XY01,XY02,XY1,XY11,XY12,Z,ZERO,ZSQ
C-------------------------------------------------------------------
C  Mathematical constants
C-------------------------------------------------------------------
CS    DATA EIGHT/8.0E0/,
CS   1     FOUR/4.0E0/,HALF/0.5E0/,THROV8/0.375E0/,
CS   2     PI2/6.3661977236758134308E-1/,P17/1.716E-1/
CS   3     TWOPI/6.2831853071795864769E+0/,ZERO/0.0E0/,
CS   4     TWOPI1/6.28125E0/,TWOPI2/1.9353071795864769253E-03/
CS   5     TWO56/256.0E+0/,RTPI2/7.9788456080286535588E-1/
CD    DATA EIGHT/8.0D0/,
CD   1     FOUR/4.0D0/,HALF/0.5D0/,THROV8/0.375D0/,
CD   2     PI2/6.3661977236758134308D-1/,P17/1.716D-1/
CD   3     TWOPI/6.2831853071795864769D+0/,ZERO/0.0D0/,
CD   4     TWOPI1/6.28125D0/,TWOPI2/1.9353071795864769253D-03/
CD   5     TWO56/256.0D+0/,RTPI2/7.9788456080286535588D-1/
C-------------------------------------------------------------------
C  Machine-dependent constants
C-------------------------------------------------------------------
CS    DATA XMAX/8.19E+03/,XSMALL/1.22E-04/,XINF/3.40E+38/
CD    DATA XMAX/2.68D+08/,XSMALL/3.72D-09/,XINF/1.79D+308/
C-------------------------------------------------------------------
C  Zeroes of Bessel functions
C-------------------------------------------------------------------
CS    DATA XJ0/3.8317059702075123156E+0/,XJ1/7.0155866698156187535E+0/,
CS   1     XY0/2.1971413260310170351E+0/,XY1/5.4296810407941351328E+0/,
CS   2     XJ01/ 981.0E+0/, XJ02/-3.2527979248768438556E-04/,
CS   3     XJ11/1796.0E+0/, XJ12/-3.8330184381246462950E-05/,
CS   4     XY01/ 562.0E+0/, XY02/ 1.8288260310170351490E-03/,
CS   5     XY11/1390.0E+0/, XY12/-6.4592058648672279948E-06/
CD    DATA XJ0/3.8317059702075123156D+0/,XJ1/7.0155866698156187535D+0/,
CD   1     XY0/2.1971413260310170351D+0/,XY1/5.4296810407941351328D+0/,
CD   2     XJ01/ 981.0D+0/, XJ02/-3.2527979248768438556D-04/,
CD   3     XJ11/1796.0D+0/, XJ12/-3.8330184381246462950D-05/,
CD   4     XY01/ 562.0D+0/, XY02/ 1.8288260310170351490D-03/,
CD   5     XY11/1390.0D+0/, XY12/-6.4592058648672279948D-06/
C-------------------------------------------------------------------
C  Coefficients for rational approximation to ln(x/a)
C--------------------------------------------------------------------
CS    DATA PLG/-2.4562334077563243311E+01,2.3642701335621505212E+02,
CS   1         -5.4989956895857911039E+02,3.5687548468071500413E+02/
CS    DATA QLG/-3.5553900764052419184E+01,1.9400230218539473193E+02,
CS   1         -3.3442903192607538956E+02,1.7843774234035750207E+02/
CD    DATA PLG/-2.4562334077563243311D+01,2.3642701335621505212D+02,
CD   1         -5.4989956895857911039D+02,3.5687548468071500413D+02/
CD    DATA QLG/-3.5553900764052419184D+01,1.9400230218539473193D+02,
CD   1         -3.3442903192607538956D+02,1.7843774234035750207D+02/
C-------------------------------------------------------------------
C  Coefficients for rational approximation of
C  J1(X) / (X * (X**2 - XJ0**2)),  XSMALL  <  |X|  <=  4.0
C--------------------------------------------------------------------
CS    DATA PJ0/9.8062904098958257677E+05,-1.1548696764841276794E+08,
CS   1       6.6781041261492395835E+09,-1.4258509801366645672E+11,
CS   2      -4.4615792982775076130E+03, 1.0650724020080236441E+01,
CS   3      -1.0767857011487300348E-02/
CS    DATA QJ0/5.9117614494174794095E+05, 2.0228375140097033958E+08,
CS   1       4.2091902282580133541E+10, 4.1868604460820175290E+12,
CS   2       1.0742272239517380498E+03/
CD    DATA PJ0/9.8062904098958257677D+05,-1.1548696764841276794D+08,
CD   1       6.6781041261492395835D+09,-1.4258509801366645672D+11,
CD   2      -4.4615792982775076130D+03, 1.0650724020080236441D+01,
CD   3      -1.0767857011487300348D-02/
CD    DATA QJ0/5.9117614494174794095D+05, 2.0228375140097033958D+08,
CD   1       4.2091902282580133541D+10, 4.1868604460820175290D+12,
CD   2       1.0742272239517380498D+03/
C-------------------------------------------------------------------
C  Coefficients for rational approximation of
C  J1(X) / (X * (X**2 - XJ1**2)),  4.0  <  |X|  <=  8.0
C-------------------------------------------------------------------
CS    DATA PJ1/4.6179191852758252280E+00,-7.1329006872560947377E+03,
CS   1       4.5039658105749078904E+06,-1.4437717718363239107E+09,
CS   2       2.3569285397217157313E+11,-1.6324168293282543629E+13,
CS   3       1.1357022719979468624E+14, 1.0051899717115285432E+15/
CS    DATA QJ1/1.1267125065029138050E+06, 6.4872502899596389593E+08,
CS   1       2.7622777286244082666E+11, 8.4899346165481429307E+13,
CS   2       1.7128800897135812012E+16, 1.7253905888447681194E+18,
CS   3       1.3886978985861357615E+03/
CD    DATA PJ1/4.6179191852758252280D+00,-7.1329006872560947377D+03,
CD   1       4.5039658105749078904D+06,-1.4437717718363239107D+09,
CD   2       2.3569285397217157313D+11,-1.6324168293282543629D+13,
CD   3       1.1357022719979468624D+14, 1.0051899717115285432D+15/
CD    DATA QJ1/1.1267125065029138050D+06, 6.4872502899596389593D+08,
CD   1       2.7622777286244082666D+11, 8.4899346165481429307D+13,
CD   2       1.7128800897135812012D+16, 1.7253905888447681194D+18,
CD   3       1.3886978985861357615D+03/
C-------------------------------------------------------------------
C  Coefficients for rational approximation of
C    (Y1(X) - 2 LN(X/XY0) J1(X)) / (X**2 - XY0**2),
C        XSMALL  <  |X|  <=  4.0
C--------------------------------------------------------------------
CS    DATA PY0/2.2157953222280260820E+05,-5.9157479997408395984E+07,
CS   1         7.2144548214502560419E+09,-3.7595974497819597599E+11,
CS   2         5.4708611716525426053E+12, 4.0535726612579544093E+13,
CS   3        -3.1714424660046133456E+02/
CS    DATA QY0/8.2079908168393867438E+02, 3.8136470753052572164E+05,
CS   1         1.2250435122182963220E+08, 2.7800352738690585613E+10,
CS   2         4.1272286200406461981E+12, 3.0737873921079286084E+14/
CD    DATA PY0/2.2157953222280260820D+05,-5.9157479997408395984D+07,
CD   1         7.2144548214502560419D+09,-3.7595974497819597599D+11,
CD   2         5.4708611716525426053D+12, 4.0535726612579544093D+13,
CD   3        -3.1714424660046133456D+02/
CD    DATA QY0/8.2079908168393867438D+02, 3.8136470753052572164D+05,
CD   1         1.2250435122182963220D+08, 2.7800352738690585613D+10,
CD   2         4.1272286200406461981D+12, 3.0737873921079286084D+14/
C--------------------------------------------------------------------
C  Coefficients for rational approximation of
C    (Y1(X) - 2 LN(X/XY1) J1(X)) / (X**2 - XY1**2),
C        4.0  <  |X|  <=  8.0
C--------------------------------------------------------------------
CS    DATA PY1/ 1.9153806858264202986E+06,-1.1957961912070617006E+09,
CS   1          3.7453673962438488783E+11,-5.9530713129741981618E+13,
CS   2          4.0686275289804744814E+15,-2.3638408497043134724E+16,
CS   3         -5.6808094574724204577E+18, 1.1514276357909013326E+19,
CS   4         -1.2337180442012953128E+03/
CS    DATA QY1/ 1.2855164849321609336E+03, 1.0453748201934079734E+06,
CS   1          6.3550318087088919566E+08, 3.0221766852960403645E+11,
CS   2          1.1187010065856971027E+14, 3.0837179548112881950E+16,
CS   3          5.6968198822857178911E+18, 5.3321844313316185697E+20/
CD    DATA PY1/ 1.9153806858264202986D+06,-1.1957961912070617006D+09,
CD   1          3.7453673962438488783D+11,-5.9530713129741981618D+13,
CD   2          4.0686275289804744814D+15,-2.3638408497043134724D+16,
CD   3         -5.6808094574724204577D+18, 1.1514276357909013326D+19,
CD   4         -1.2337180442012953128D+03/
CD    DATA QY1/ 1.2855164849321609336D+03, 1.0453748201934079734D+06,
CD   1          6.3550318087088919566D+08, 3.0221766852960403645D+11,
CD   2          1.1187010065856971027D+14, 3.0837179548112881950D+16,
CD   3          5.6968198822857178911D+18, 5.3321844313316185697D+20/
C-------------------------------------------------------------------
C  Coefficients for Hart,s approximation,  |X| > 8.0
C-------------------------------------------------------------------
CS    DATA P0/-1.0982405543459346727E+05,-1.5235293511811373833E+06,
CS   1         -6.6033732483649391093E+06,-9.9422465050776411957E+06,
CS   2         -4.4357578167941278571E+06,-1.6116166443246101165E+03/
CS    DATA Q0/-1.0726385991103820119E+05,-1.5118095066341608816E+06,
CS   1         -6.5853394797230870728E+06,-9.9341243899345856590E+06,
CS   2         -4.4357578167941278568E+06,-1.4550094401904961825E+03/
CS    DATA P1/ 1.7063754290207680021E+03, 1.8494262873223866797E+04,
CS   1          6.6178836581270835179E+04, 8.5145160675335701966E+04,
CS   2          3.3220913409857223519E+04, 3.5265133846636032186E+01/
CS    DATA Q1/ 3.7890229745772202641E+04, 4.0029443582266975117E+05,
CS   1          1.4194606696037208929E+06, 1.8194580422439972989E+06,
CS   2          7.0871281941028743574E+05, 8.6383677696049909675E+02/
CD    DATA P0/-1.0982405543459346727D+05,-1.5235293511811373833D+06,
CD   1         -6.6033732483649391093D+06,-9.9422465050776411957D+06,
CD   2         -4.4357578167941278571D+06,-1.6116166443246101165D+03/
CD    DATA Q0/-1.0726385991103820119D+05,-1.5118095066341608816D+06,
CD   1         -6.5853394797230870728D+06,-9.9341243899345856590D+06,
CD   2         -4.4357578167941278568D+06,-1.4550094401904961825D+03/
CD    DATA P1/ 1.7063754290207680021D+03, 1.8494262873223866797D+04,
CD   1          6.6178836581270835179D+04, 8.5145160675335701966D+04,
CD   2          3.3220913409857223519D+04, 3.5265133846636032186D+01/
CD    DATA Q1/ 3.7890229745772202641D+04, 4.0029443582266975117D+05,
CD   1          1.4194606696037208929D+06, 1.8194580422439972989D+06,
CD   2          7.0871281941028743574D+05, 8.6383677696049909675D+02/
C-------------------------------------------------------------------
C  Check for error conditions
C-------------------------------------------------------------------
      AX = ABS(ARG)
      IF ((JINT .EQ. 1) .AND. ((ARG .LE. ZERO) .OR.
     1   ((ARG .LT. HALF) .AND. (AX*XINF .LT. PI2)))) THEN
            RESULT = -XINF
            GO TO 2000
         ELSE IF (AX .GT. XMAX) THEN
            RESULT = ZERO
            GO TO 2000
      END IF
      IF (AX .GT. EIGHT) THEN
            GO TO 800
         ELSE IF (AX .LE. XSMALL) THEN
            IF (JINT .EQ. 0) THEN
                  RESULT = ARG * HALF
               ELSE
                  RESULT = -PI2 / AX
            END IF
            GO TO 2000
      END IF
C-------------------------------------------------------------------
C  Calculate J1 for appropriate interval, preserving
C     accuracy near the zero of J1
C-------------------------------------------------------------------
      ZSQ = AX * AX
      IF (AX .LE. FOUR) THEN
            XNUM = (PJ0(7) * ZSQ + PJ0(6)) * ZSQ + PJ0(5)
            XDEN = ZSQ + QJ0(5)
            DO 50 I = 1, 4
               XNUM = XNUM * ZSQ + PJ0(I)
               XDEN = XDEN * ZSQ + QJ0(I)
   50       CONTINUE
            PROD = ARG * ((AX - XJ01/TWO56) - XJ02) * (AX + XJ0)
         ELSE
            XNUM = PJ1(1)
            XDEN = (ZSQ + QJ1(7)) * ZSQ + QJ1(1)
            DO 220 I = 2, 6
               XNUM = XNUM * ZSQ + PJ1(I)
               XDEN = XDEN * ZSQ + QJ1(I)
  220       CONTINUE
            XNUM = XNUM * (AX - EIGHT) * (AX + EIGHT) + PJ1(7)
            XNUM = XNUM * (AX - FOUR) * (AX + FOUR) + PJ1(8)
            PROD = ARG * ((AX - XJ11/TWO56) - XJ12) * (AX + XJ1)
      END IF
      RESULT = PROD * (XNUM / XDEN)
      IF (JINT .EQ. 0) GO TO 2000
C-------------------------------------------------------------------
C  Calculate Y1.  First find  RESJ = pi/2 ln(x/xn) J1(x),
C    where xn is a zero of Y1
C-------------------------------------------------------------------
      IF (AX .LE. FOUR) THEN
            UP = (AX-XY01/TWO56)-XY02
            XY = XY0
         ELSE
            UP = (AX-XY11/TWO56)-XY12
            XY = XY1
      END IF
      DOWN = AX + XY
      IF (ABS(UP) .LT. P17*DOWN) THEN
            W = UP/DOWN
            WSQ = W*W
            XNUM = PLG(1)
            XDEN = WSQ + QLG(1)
            DO 320 I = 2, 4
               XNUM = XNUM*WSQ + PLG(I)
               XDEN = XDEN*WSQ + QLG(I)
  320       CONTINUE
            RESJ = PI2 * RESULT * W * XNUM/XDEN
         ELSE
            RESJ = PI2 * RESULT * LOG(AX/XY)
      END IF
C-------------------------------------------------------------------
C  Now calculate Y1 for appropriate interval, preserving
C     accuracy near the zero of Y1
C-------------------------------------------------------------------
      IF (AX .LE. FOUR) THEN
            XNUM = PY0(7) * ZSQ + PY0(1)
            XDEN = ZSQ + QY0(1)
            DO 340 I = 2, 6
               XNUM = XNUM * ZSQ + PY0(I)
               XDEN = XDEN * ZSQ + QY0(I)
  340       CONTINUE
         ELSE
            XNUM = PY1(9) * ZSQ + PY1(1)
            XDEN = ZSQ + QY1(1)
            DO 360 I = 2, 8
               XNUM = XNUM * ZSQ + PY1(I)
               XDEN = XDEN * ZSQ + QY1(I)
  360       CONTINUE
      END IF
      RESULT = RESJ + (UP*DOWN/AX) * XNUM / XDEN
      GO TO 2000
C-------------------------------------------------------------------
C  Calculate J1 or Y1 for |ARG|  >  8.0
C-------------------------------------------------------------------
  800 Z = EIGHT / AX
      W = AINT(AX/TWOPI) + THROV8
      W = (AX - W * TWOPI1) - W * TWOPI2
      ZSQ = Z * Z
      XNUM = P0(6)
      XDEN = ZSQ + Q0(6)
      UP = P1(6)
      DOWN = ZSQ + Q1(6)
      DO 850 I = 1, 5
         XNUM = XNUM * ZSQ + P0(I)
         XDEN = XDEN * ZSQ + Q0(I)
         UP = UP * ZSQ + P1(I)
         DOWN = DOWN * ZSQ + Q1(I)
  850 CONTINUE
      R0 = XNUM / XDEN
      R1 = UP / DOWN
      IF (JINT .EQ. 0) THEN
            RESULT = (RTPI2/SQRT(AX)) * (R0*COS(W) - Z*R1*SIN(W))
         ELSE
            RESULT = (RTPI2/SQRT(AX)) * (R0*SIN(W) + Z*R1*COS(W))
      END IF
      IF ((JINT .EQ. 0) .AND. (ARG .LT. ZERO)) RESULT = -RESULT
 2000 RETURN
C---------- Last card of CALJY1 ----------
      END
CS    REAL FUNCTION BESJ1(X)
CD    DOUBLE PRECISION FUNCTION BESJ1(X)
C--------------------------------------------------------------------
C
C This subprogram computes approximate values for Bessel functions
C   of the first kind of order zero for arguments  |X| <= XMAX
C   (see comments heading CALJY1).
C
C--------------------------------------------------------------------
      INTEGER JINT
CS    REAL
CD    DOUBLE PRECISION
     1   RESULT,X
C--------------------------------------------------------------------
      JINT=0
      CALL CALJY1(X,RESULT,JINT)
      BESJ1 = RESULT
      RETURN
C---------- Last card of BESJ1 ----------
      END
CS    REAL FUNCTION BESY1(X)
CD    DOUBLE PRECISION FUNCTION BESY1(X)
C--------------------------------------------------------------------
C
C This subprogram computes approximate values for Bessel functions
C   of the second kind of order zero for arguments 0 < X <= XMAX
C   (see comments heading CALJY1).
C
C--------------------------------------------------------------------
      INTEGER JINT
CS    REAL
CD    DOUBLE PRECISION
     1   RESULT,X
C--------------------------------------------------------------------
      JINT=1
      CALL CALJY1(X,RESULT,JINT)
      BESY1 = RESULT
      RETURN
C---------- Last card of BESY1 ----------
      END
      SUBROUTINE CALCK0(ARG,RESULT,JINT)
C--------------------------------------------------------------------
C
C This packet computes modified Bessel functions of the second kind
C   and order zero, K0(X) and EXP(X)*K0(X), for real
C   arguments X.  It contains two function type subprograms, BESK0
C   and BESEK0, and one subroutine type subprogram, CALCK0.
C   the calling statements for the primary entries are
C
C                   Y=BESK0(X)
C   and
C                   Y=BESEK0(X)
C
C   where the entry points correspond to the functions K0(X) and
C   EXP(X)*K0(X), respectively.  The routine CALCK0 is
C   intended for internal packet use only, all computations within
C   the packet being concentrated in this routine.  The function
C   subprograms invoke CALCK0 with the statement
C          CALL CALCK0(ARG,RESULT,JINT)
C   where the parameter usage is as follows
C
C      Function                     Parameters for CALCK0
C       Call              ARG                  RESULT          JINT
C
C     BESK0(ARG)   0 .LT. ARG .LE. XMAX       K0(ARG)           1
C     BESEK0(ARG)     0 .LT. ARG           EXP(ARG)*K0(ARG)     2
C
C   The main computation evaluates slightly modified forms of near
C   minimax rational approximations generated by Russon and Blair,
C   Chalk River (Atomic Energy of Canada Limited) Report AECL-3461,
C   1969.  This transportable program is patterned after the
C   machine-dependent FUNPACK packet NATSK0, but cannot match that
C   version for efficiency or accuracy.  This version uses rational
C   functions that theoretically approximate K-SUB-0(X) to at
C   least 18 significant decimal digits.  The accuracy achieved
C   depends on the arithmetic system, the compiler, the intrinsic
C   functions, and proper selection of the machine-dependent
C   constants.
C
C*******************************************************************
C*******************************************************************
C
C Explanation of machine-dependent constants.  Let
C
C   beta   = Radix for the floating-point system
C   minexp = Smallest representable power of beta
C   maxexp = Smallest power of beta that overflows
C
C Then the following machine-dependent constants must be declared
C   in DATA statements.  IEEE values are provided as a default.
C
C   XSMALL = Argument below which BESK0 and BESEK0 may
C            each be represented by a constant and a log.
C            largest X such that  1.0 + X = 1.0  to machine
C            precision.
C   XINF   = Largest positive machine number; approximately
C            beta**maxexp
C   XMAX   = Largest argument acceptable to BESK0;  Solution to
C            equation:
C               W(X) * (1-1/8X+9/128X**2) = beta**minexp
C            where  W(X) = EXP(-X)*SQRT(PI/2X)
C
C
C     Approximate values for some important machines are:
C
C
C                           beta       minexp       maxexp
C
C  CRAY-1        (S.P.)       2        -8193         8191
C  Cyber 180/185
C    under NOS   (S.P.)       2         -975         1070
C  IEEE (IBM/XT,
C    SUN, etc.)  (S.P.)       2         -126          128
C  IEEE (IBM/XT,
C    SUN, etc.)  (D.P.)       2        -1022         1024
C  IBM 3033      (D.P.)      16          -65           63
C  VAX D-Format  (D.P.)       2         -128          127
C  VAX G-Format  (D.P.)       2        -1024         1023
C
C
C                          XSMALL       XINF         XMAX
C
C CRAY-1        (S.P.)    3.55E-15   5.45E+2465    5674.858
C Cyber 180/855
C   under NOS   (S.P.)    1.77E-15   1.26E+322      672.788
C IEEE (IBM/XT,
C   SUN, etc.)  (S.P.)    5.95E-8    3.40E+38        85.337
C IEEE (IBM/XT,
C   SUN, etc.)  (D.P.)    1.11D-16   1.79D+308      705.342
C IBM 3033      (D.P.)    1.11D-16   7.23D+75       177.852
C VAX D-Format  (D.P.)    6.95D-18   1.70D+38        86.715
C VAX G-Format  (D.P.)    5.55D-17   8.98D+307      706.728
C
C*******************************************************************
C*******************************************************************
C
C Error returns
C
C  The program returns the value XINF for ARG .LE. 0.0, and the
C  BESK0 entry returns the value 0.0 for ARG .GT. XMAX.
C
C
C  Intrinsic functions required are:
C
C     EXP, LOG, SQRT
C
C  Latest modification: March 14, 1992
C
C  Authors: W. J. Cody and Laura Stoltz
C           Mathematics and Computer Science Division
C           Argonne National Laboratory
C           Argonne, IL 60439
C
C--------------------------------------------------------------------
      INTEGER I,JINT
CS    REAL
CD    DOUBLE PRECISION
     1    ARG,F,G,ONE,P,PP,Q,QQ,RESULT,SUMF,SUMG,SUMP,SUMQ,TEMP,
     2    X,XINF,XMAX,XSMALL,XX,ZERO
      DIMENSION P(6),Q(2),PP(10),QQ(10),F(4),G(3)
C--------------------------------------------------------------------
C  Mathematical constants
C--------------------------------------------------------------------
CS    DATA ONE/1.0E0/,ZERO/0.0E0/
CD    DATA ONE/1.0D0/,ZERO/0.0D0/
C--------------------------------------------------------------------
C  Machine-dependent constants
C--------------------------------------------------------------------
CS    DATA XSMALL/5.95E-8/,XINF/3.40E+38/,XMAX/ 85.337E0/
CD    DATA XSMALL/1.11D-16/,XINF/1.79D+308/,XMAX/705.342D0/
C--------------------------------------------------------------------
C
C     Coefficients for XSMALL .LE.  ARG  .LE. 1.0
C
C--------------------------------------------------------------------
CS    DATA   P/ 5.8599221412826100000E-04, 1.3166052564989571850E-01,
CS   1          1.1999463724910714109E+01, 4.6850901201934832188E+02,
CS   2          5.9169059852270512312E+03, 2.4708152720399552679E+03/
CS    DATA   Q/-2.4994418972832303646E+02, 2.1312714303849120380E+04/
CS    DATA   F/-1.6414452837299064100E+00,-2.9601657892958843866E+02,
CS   1         -1.7733784684952985886E+04,-4.0320340761145482298E+05/
CS    DATA   G/-2.5064972445877992730E+02, 2.9865713163054025489E+04,
CS   1         -1.6128136304458193998E+06/
CD    DATA   P/ 5.8599221412826100000D-04, 1.3166052564989571850D-01,
CD   1          1.1999463724910714109D+01, 4.6850901201934832188D+02,
CD   2          5.9169059852270512312D+03, 2.4708152720399552679D+03/
CD    DATA   Q/-2.4994418972832303646D+02, 2.1312714303849120380D+04/
CD    DATA   F/-1.6414452837299064100D+00,-2.9601657892958843866D+02,
CD   1         -1.7733784684952985886D+04,-4.0320340761145482298D+05/
CD    DATA   G/-2.5064972445877992730D+02, 2.9865713163054025489D+04,
CD   1         -1.6128136304458193998D+06/
C--------------------------------------------------------------------
C
C     Coefficients for  1.0 .LT. ARG
C
C--------------------------------------------------------------------
CS    DATA  PP/ 1.1394980557384778174E+02, 3.6832589957340267940E+03,
CS   1          3.1075408980684392399E+04, 1.0577068948034021957E+05,
CS   2          1.7398867902565686251E+05, 1.5097646353289914539E+05,
CS   3          7.1557062783764037541E+04, 1.8321525870183537725E+04,
CS   4          2.3444738764199315021E+03, 1.1600249425076035558E+02/
CS    DATA  QQ/ 2.0013443064949242491E+02, 4.4329628889746408858E+03,
CS   1          3.1474655750295278825E+04, 9.7418829762268075784E+04,
CS   2          1.5144644673520157801E+05, 1.2689839587977598727E+05,
CS   3          5.8824616785857027752E+04, 1.4847228371802360957E+04,
CS   4          1.8821890840982713696E+03, 9.2556599177304839811E+01/
CD    DATA  PP/ 1.1394980557384778174D+02, 3.6832589957340267940D+03,
CD   1          3.1075408980684392399D+04, 1.0577068948034021957D+05,
CD   2          1.7398867902565686251D+05, 1.5097646353289914539D+05,
CD   3          7.1557062783764037541D+04, 1.8321525870183537725D+04,
CD   4          2.3444738764199315021D+03, 1.1600249425076035558D+02/
CD    DATA  QQ/ 2.0013443064949242491D+02, 4.4329628889746408858D+03,
CD   1          3.1474655750295278825D+04, 9.7418829762268075784D+04,
CD   2          1.5144644673520157801D+05, 1.2689839587977598727D+05,
CD   3          5.8824616785857027752D+04, 1.4847228371802360957D+04,
CD   4          1.8821890840982713696D+03, 9.2556599177304839811D+01/
C--------------------------------------------------------------------
      X = ARG
      IF (X .GT. ZERO) THEN
            IF (X .LE. ONE) THEN
C--------------------------------------------------------------------
C     0.0 .LT.  ARG  .LE. 1.0
C--------------------------------------------------------------------
                  TEMP = LOG(X)
                  IF (X .LT. XSMALL) THEN
C--------------------------------------------------------------------
C     Return for small ARG
C--------------------------------------------------------------------
                        RESULT = P(6)/Q(2) - TEMP
                     ELSE
                        XX = X * X
                        SUMP = ((((P(1)*XX + P(2))*XX + P(3))*XX +
     1                         P(4))*XX + P(5))*XX + P(6)
                        SUMQ = (XX + Q(1))*XX + Q(2)
                        SUMF = ((F(1)*XX + F(2))*XX + F(3))*XX + F(4)
                        SUMG = ((XX + G(1))*XX + G(2))*XX + G(3)
                        RESULT = SUMP/SUMQ - XX*SUMF*TEMP/SUMG - TEMP
                        IF (JINT .EQ. 2) RESULT = RESULT * EXP(X)
                  END IF
               ELSE IF ((JINT .EQ. 1) .AND. (X .GT. XMAX)) THEN
C--------------------------------------------------------------------
C     Error return for ARG .GT. XMAX
C--------------------------------------------------------------------
                  RESULT = ZERO
               ELSE
C--------------------------------------------------------------------
C     1.0 .LT. ARG
C--------------------------------------------------------------------
                  XX = ONE / X
                  SUMP = PP(1)
                  DO 120 I = 2, 10
                     SUMP = SUMP*XX + PP(I)
  120             CONTINUE
                  SUMQ = XX
                  DO 140 I = 1, 9
                     SUMQ = (SUMQ + QQ(I))*XX
  140             CONTINUE
                  SUMQ = SUMQ + QQ(10)
                  RESULT = SUMP / SUMQ / SQRT(X)
                  IF (JINT .EQ. 1) RESULT = RESULT * EXP(-X)
            END IF
         ELSE
C--------------------------------------------------------------------
C     Error return for ARG .LE. 0.0
C--------------------------------------------------------------------
            RESULT = XINF
      END IF
C--------------------------------------------------------------------
C     Update error counts, etc.
C--------------------------------------------------------------------
      RETURN
C---------- Last line of CALCK0 ----------
      END
CS    REAL FUNCTION BESK0(X)
CD    DOUBLE PRECISION FUNCTION BESK0(X)
C--------------------------------------------------------------------
C
C This function program computes approximate values for the
C   modified Bessel function of the second kind of order zero
C   for arguments 0.0 .LT. ARG .LE. XMAX (see comments heading
C   CALCK0).
C
C  Authors: W. J. Cody and Laura Stoltz
C
C  Latest Modification: March 14, 1992
C
C--------------------------------------------------------------------
      INTEGER JINT
CS    REAL 
CD    DOUBLE PRECISION
     1    X, RESULT
C--------------------------------------------------------------------
      JINT = 1
      CALL CALCK0(X,RESULT,JINT)
      BESK0 = RESULT
      RETURN
C---------- Last line of BESK0 ----------
      END
CS    REAL FUNCTION BESEK0(X)
CD    DOUBLE PRECISION FUNCTION BESEK0(X)
C--------------------------------------------------------------------
C
C This function program computes approximate values for the
C   modified Bessel function of the second kind of order zero
C   multiplied by the Exponential function, for arguments
C   0.0 .LT. ARG.
C
C  Authors: W. J. Cody and Laura Stoltz
C
C  Latest Modification: March 14, 1992
C
C--------------------------------------------------------------------
      INTEGER JINT
CS    REAL 
CD    DOUBLE PRECISION 
     1    X, RESULT
C--------------------------------------------------------------------
      JINT = 2
      CALL CALCK0(X,RESULT,JINT)
      BESEK0 = RESULT
      RETURN
C---------- Last line of BESEK0 ----------
      END
      PROGRAM K0TEST
C--------------------------------------------------------------------
C  FORTRAN 77 program to test BESK0
C
C  Data required
C
C     None
C
C  Subprograms required from this package
C
C     MACHAR - an environmental inquiry program providing
C              information on the floating-point arithmetic
C              system.  Note that the call to MACHAR can
C              be deleted provided the following three
C              parameters are assigned the values indicated
C
C                 IBETA  - the radix of the floating-point system
C                 IT     - the number of base-IBETA digits in the
C                          significand of a floating-point number
C                 MAXEXP - the smallest positive power of BETA
C                          that overflows
C                 EPS    - the smallest positive floating-point
C                          number such that 1.0+EPS .NE. 1.0
C                 XMIN   - the smallest non-vanishing normalized
C                          floating-point power of the radix, i.e.,
C                          XMIN = FLOAT(IBETA) ** MINEXP
C                 XMAX   - the largest finite floating-point number.
C                          In particular XMAX = (1.0-EPSNEG) * 
C                          FLOAT(IBETA) ** MAXEXP
C
C     REN(K) - a function subprogram returning random real
C              numbers uniformly distributed over (0,1)
C
C
C  Intrinsic functions required are:
C
C         ABS, DBLE, LOG, MAX, REAL, SQRT
C
C  User defined functions
C
C         BOT, TOP
C
C  Reference: "Performance evaluation of programs for certain
C              Bessel functions", W. J. Cody and L. Stoltz,
C              ACM Trans. on Math. Software, Vol. 15, 1989,
C              pp 41-48.
C
C  Latest modification: March 14, 1992
C
C  Author: Laura Stoltz 
C          Mathematics and Computer Science Division
C          Argonne National Laboratory
C          Argonne, IL 60439
C
C-----------------------------------------------------------------
      LOGICAL SFLAG,TFLAG
      INTEGER I,IBETA,IEXP,II,IND,IOUT,IRND,IT,J,JT,K1,K2,K3,
     1        MACHEP,MAXEXP,MB,MINEXP,N,NDUM,NEGEP,NGRD
CS    REAL
CD    DOUBLE PRECISION
     1   A,AIT,ALBETA,ALL9,AMAXEXP,ATETEN,B,BESEK0,BESK0,BESK1,BETA,
     2   BOT,C,CONST,CONV,DEL,EIGHT,EPS,EPSNEG,FIVE,HALF,ONE,ONENEG,
     3   ONE28,PI,REN,R6,R7,SUM,T,TOP,TWENTY,TWO,U,W,X,XA,XB,XDEN,
     4   XL,XLAM,XLARGE,XMAX,XMB,XMIN,XN,XNINE,X1,Y,Z,ZERO,ZZ
      DIMENSION U(0:559)
CS    DATA ZERO,HALF,ONE,TWO,EIGHT/0.0E0,0.5E0,1.0E0,2.0E0,8.0E0/,
CS   1   XNINE,ATETEN,TWENTY,ONE28/9.0E0,18.0E0,20.0E0,128.0E0/,
CS   2   FIVE,ONENEG,XDEN,ALL9/5.0E0,-1.0E0,16.0E0,-999.0E0/,
CS   3   PI/3.141592653589793E0/
CD    DATA ZERO,HALF,ONE,TWO,EIGHT/0.0D0,0.5D0,1.0D0,2.0D0,8.0D0/,
CD   1   XNINE,ATETEN,TWENTY,ONE28/9.0D0,18.0D0,20.0D0,128.0D0/,
CD   2   FIVE,ONENEG,XDEN,ALL9/5.0D0,-1.0D0,16.0D0,-999.0D0/,
CD   3   PI/3.141592653589793D0/
      DATA IOUT/6/
      TOP(X) = -X - HALF*LOG(TWO*X) + LOG(ONE-(ONE/EIGHT-XNINE/
     1   ONE28/X)/X)
      BOT(X) = (XDEN*X-ATETEN) / (((ONE28*X-XDEN)*X+XNINE)*X)
     1   - ONE - HALF/X
C------------------------------------------------------------------
C  Statement functions for conversion between integer and float
C------------------------------------------------------------------
CS    CONV(NDUM) = REAL(NDUM)
CD    CONV(NDUM) = DBLE(NDUM)
C-----------------------------------------------------------------
C  Determine machine parameters and set constants
C-----------------------------------------------------------------
      CALL MACHAR(IBETA,IT,IRND,NGRD,MACHEP,NEGEP,IEXP,MINEXP,
     1            MAXEXP,EPS,EPSNEG,XMIN,XMAX)
      BETA = CONV(IBETA)
      ALBETA = LOG(BETA)
      AIT = CONV(IT)
      AMAXEXP = CONV(MAXEXP)
      JT = 0
      B = EPS
      XLAM = (XDEN - ONE) / XDEN
      CONST = HALF * LOG(PI) - LOG(XMIN)
C-----------------------------------------------------------------
C     Random argument accuracy tests
C-----------------------------------------------------------------
      DO 300 J = 1, 3
         SFLAG = ((J .EQ. 1) .AND. (AMAXEXP/AIT .LE. FIVE))
         K1 = 0
         K2 = 0
         K3 = 0
         X1 = ZERO
         R6 = ZERO
         R7 = ZERO
         N = 2000
         IF (SFLAG) B = SQRT(EPS)
         A = B
         IF (J .EQ. 1) THEN
               B = ONE
            ELSE IF (J .EQ. 2) THEN
               B = EIGHT
            ELSE
               B = TWENTY
         END IF
         XN = CONV(N)
         DEL = (B - A) / XN
         XL = A
C------------------------------------------------------------------
C   Accuracy test is based on the multiplication theorem
C------------------------------------------------------------------
         DO 200 I = 1, N
            X = DEL * REN(JT) + XL
            Y = X / XLAM
            W = XDEN * Y
            Y = (W + Y) - W 
            X = Y * XLAM
            U(0) = BESK0(Y)
            U(1) = BESK1(Y)
            TFLAG = SFLAG .AND. (Y .LT. HALF)
            IF (TFLAG) THEN
                  U(0) = U(0) * EPS
                  U(1) = U(1) * EPS
            END IF
            MB = 1
            XMB = ONE
            Y = Y * HALF
            T = U(0) * EPS
            W = (ONE-XLAM) * (ONE+XLAM)
            C = W *Y 
            DO 110 II = 2, 60
               T = XMB * T / C
               Z = U(II-1)
               IF (Z .LT. T) THEN
                     GO TO 120
                  ELSE IF (U(II-1) .GT. ONE) THEN
                     IF ((XMB/Y) .GT. (XMAX/U(II-1))) THEN
                           XL = XL + DEL
                           A = XL
                           GO TO  200
                     END IF
               END IF
               U(II) = XMB/Y * U(II-1) + U(II-2)
               XMB = XMB + ONE
               MB = MB + 1
  110       CONTINUE
  120       SUM = U(MB)
            IND = MB
            DO 155 II = 1, MB
               IND = IND - 1
               SUM = SUM * W * Y / XMB + U(IND)
               XMB = XMB - ONE
  155       CONTINUE
            ZZ = SUM
            IF (TFLAG) ZZ = ZZ / EPS
            Z = BESK0(X)
            Y = Z
            IF (U(0) .GT. Y) Y= U(0)
            W = (Z - ZZ) / Y
            IF (W .GT. ZERO) THEN 
                  K1 = K1 + 1
               ELSE IF (W .LT. ZERO) THEN 
                  K3 = K3 + 1
               ELSE
                  K2 = K2 + 1
            END IF
            W = ABS(W)
            IF (W .GT. R6) THEN
                  R6 = W
                  X1 = X
            END IF
            R7 = R7 + W * W
            XL = XL + DEL
  200    CONTINUE
         N = K1 + K2 + K3
         XN = CONV(N)
         R7 = SQRT(R7/XN)
         WRITE (IOUT,1000)
         WRITE (IOUT,1010) N,A,B
         WRITE (IOUT,1011) K1,K2,K3
         WRITE (IOUT,1020) IT,IBETA
         W = ALL9
         IF (R6 .NE. ZERO) W = LOG(R6)/ALBETA
         IF (J .EQ. 3) THEN
               WRITE (IOUT,1024) R6,IBETA,W,X1
            ELSE
               WRITE (IOUT,1021) R6,IBETA,W,X1
         END IF
         W = MAX(AIT+W,ZERO)
         WRITE (IOUT,1022) IBETA,W
         W = ALL9
         IF (R7 .NE. ZERO) W = LOG(R7)/ALBETA
         IF (J .EQ. 3) THEN
               WRITE (IOUT,1025) R7,IBETA,W
            ELSE
               WRITE (IOUT,1023) R7,IBETA,W
         END IF
         W = MAX(AIT+W,ZERO)
         WRITE (IOUT,1022) IBETA,W
  300 CONTINUE
C-----------------------------------------------------------------
C  Special tests
C-----------------------------------------------------------------
      WRITE (IOUT,1030)
      WRITE (IOUT,1031)
      Y = BESK0(XMIN)
      WRITE (IOUT,1032) Y
      Y = BESK0(ZERO)
      WRITE (IOUT,1033) 0,Y
      X = REN(JT) * ONENEG
      Y = BESK0(X)
      WRITE (IOUT,1034) X,Y
      Y = BESEK0(XMAX)
      WRITE (IOUT,1035) Y
      XA = LOG(XMAX)
  330 XB = XA - (TOP(XA)+CONST) / BOT(XA)
      IF (ABS(XB-XA)/XB .LE. EPS) THEN 
            GO TO 350
         ELSE
            XA = XB
            GO TO 330
      END IF
  350 XLARGE = XB * XLAM 
      Y = BESK0(XLARGE)
      WRITE (IOUT,1034) XLARGE,Y
      XLARGE = XB * (XNINE / EIGHT)
      Y = BESK0(XLARGE)
      WRITE (IOUT,1034) XLARGE,Y
      STOP
C----------------------------------------------------------------- 
 1000 FORMAT('1Test of K0(X) vs Multiplication Theorem'//)
 1010 FORMAT(I7,' random arguments were tested from the interval (',
     1    F5.1,',',F5.1,')'//)
 1011 FORMAT(' ABS(K0(X)) was larger',I6,' times,'/
     1    20X,' agreed',I6,' times, and'/
     1    16X,'was smaller',I6,' times.'//)
 1020 FORMAT(' There are',I4,' base',I4,
     1    ' significant digits in a floating-point number.'//)
 1021 FORMAT(' The maximum relative error of',E15.4,' = ',I4,' **',
     1    F7.2/4X,'occurred for X =',E13.6)
 1022 FORMAT(' The estimated loss of base',I4,
     1    ' significant digits is',F7.2//)
 1023 FORMAT(' The root mean square relative error was',E15.4,
     1    ' = ',I4,' **',F7.2)
 1024 FORMAT(' The maximum absolute error of',E15.4,' = ',I4,' **',
     1    F7.2/4X,'occurred for X =',E13.6)
 1025 FORMAT(' The root mean square absolute error was',E15.4,
     1    ' = ',I4,' **',F7.2)
 1030 FORMAT('1Special Tests'//)
 1031 FORMAT(//' Test with extreme arguments'/)
 1032 FORMAT(' K0(XMIN) = ',E24.17/)
 1033 FORMAT(' K0(',I1,') = ',E24.17/)
 1034 FORMAT(' K0(',E24.17,' ) = ',E24.17/)
 1035 FORMAT(' E**X * K0(XMAX) = ',E24.17/)
C     ---------- Last line of BESK0 test program ----------
      END
      SUBROUTINE CALCK1(ARG,RESULT,JINT)
C--------------------------------------------------------------------
C
C This packet computes modified Bessel functions of the second kind
C   and order one,  K1(X)  and  EXP(X)*K1(X), for real arguments X.
C   It contains two function type subprograms, BESK1  and  BESEK1,
C   and one subroutine type subprogram, CALCK1.  The calling
C   statements for the primary entries are
C
C                   Y=BESK1(X)
C   and
C                   Y=BESEK1(X)
C
C   where the entry points correspond to the functions K1(X) and
C   EXP(X)*K1(X), respectively.  The routine CALCK1 is intended
C   for internal packet use only, all computations within the
C   packet being concentrated in this routine.  The function
C   subprograms invoke CALCK1 with the statement
C          CALL CALCK1(ARG,RESULT,JINT)
C   where the parameter usage is as follows
C
C      Function                      Parameters for CALCK1
C        Call             ARG                  RESULT          JINT
C
C     BESK1(ARG)  XLEAST .LT. ARG .LT. XMAX    K1(ARG)          1
C     BESEK1(ARG)     XLEAST .LT. ARG       EXP(ARG)*K1(ARG)    2
C
C   The main computation evaluates slightly modified forms of near
C   minimax rational approximations generated by Russon and Blair,
C   Chalk River (Atomic Energy of Canada Limited) Report AECL-3461,
C   1969.  This transportable program is patterned after the
C   machine-dependent FUNPACK packet NATSK1, but cannot match that
C   version for efficiency or accuracy.  This version uses rational
C   functions that theoretically approximate K-SUB-1(X) to at
C   least 18 significant decimal digits.  The accuracy achieved
C   depends on the arithmetic system, the compiler, the intrinsic
C   functions, and proper selection of the machine-dependent
C   constants.
C
C*******************************************************************
C*******************************************************************
C
C Explanation of machine-dependent constants.  Let
C
C   beta   = Radix for the floating-point system
C   minexp = Smallest representable power of beta
C   maxexp = Smallest power of beta that overflows
C
C Then the following machine-dependent constants must be declared
C   in DATA statements.  IEEE values are provided as a default.
C
C   XLEAST = Smallest acceptable argument, i.e., smallest machine
C            number X such that 1/X is machine representable.
C   XSMALL = Argument below which BESK1(X) and BESEK1(X) may
C            each be represented by 1/X.  A safe value is the
C            largest X such that  1.0 + X = 1.0  to machine
C            precision.
C   XINF   = Largest positive machine number; approximately
C            beta**maxexp
C   XMAX   = Largest argument acceptable to BESK1;  Solution to
C            equation:
C               W(X) * (1+3/8X-15/128X**2) = beta**minexp
C            where  W(X) = EXP(-X)*SQRT(PI/2X)
C
C
C     Approximate values for some important machines are:
C
C                           beta       minexp       maxexp
C
C  CRAY-1        (S.P.)       2        -8193         8191
C  Cyber 180/185
C    under NOS   (S.P.)       2         -975         1070
C  IEEE (IBM/XT,
C    SUN, etc.)  (S.P.)       2         -126          128
C  IEEE (IBM/XT,
C    SUN, etc.)  (D.P.)       2        -1022         1024
C  IBM 3033      (D.P.)      16          -65           63
C  VAX D-Format  (D.P.)       2         -128          127
C  VAX G-Format  (D.P.)       2        -1024         1023
C
C
C                         XLEAST     XSMALL      XINF       XMAX
C
C CRAY-1                1.84E-2466  3.55E-15  5.45E+2465  5674.858
C Cyber 180/855
C   under NOS   (S.P.)  3.14E-294   1.77E-15  1.26E+322    672.789
C IEEE (IBM/XT,
C   SUN, etc.)  (S.P.)  1.18E-38    5.95E-8   3.40E+38      85.343
C IEEE (IBM/XT,
C   SUN, etc.)  (D.P.)  2.23D-308   1.11D-16  1.79D+308    705.343
C IBM 3033      (D.P.)  1.39D-76    1.11D-16  7.23D+75     177.855
C VAX D-Format  (D.P.)  5.88D-39    6.95D-18  1.70D+38      86.721
C VAX G-Format  (D.P.)  1.12D-308   5.55D-17  8.98D+307    706.728
C
C*******************************************************************
C*******************************************************************
C
C Error returns
C
C  The program returns the value XINF for ARG .LE. 0.0 and the
C   BESK1 entry returns the value 0.0 for ARG .GT. XMAX.
C
C
C  Intrinsic functions required are:
C
C     LOG, SQRT, EXP
C
C
C  Authors: W. J. Cody and Laura Stoltz
C           Mathematics and Computer Science Division
C           Argonne National Laboratory
C           Argonne, IL 60439
C
C  Latest modification: March 14, 1992
C
C--------------------------------------------------------------------
      INTEGER I,JINT
CS    REAL
CD    DOUBLE PRECISION
     1    ARG,F,G,ONE,P,PP,Q,QQ,RESULT,SUMF,SUMG,
     2    SUMP,SUMQ,X,XINF,XMAX,XLEAST,XSMALL,XX,ZERO
      DIMENSION P(5),Q(3),PP(11),QQ(9),F(5),G(3)
C--------------------------------------------------------------------
C  Mathematical constants
C--------------------------------------------------------------------
CS    DATA ONE/1.0E0/,ZERO/0.0E0/
CD    DATA ONE/1.0D0/,ZERO/0.0D0/
C--------------------------------------------------------------------
C  Machine-dependent constants
C--------------------------------------------------------------------
CS    DATA XLEAST/1.18E-38/,XSMALL/5.95E-8/,XINF/3.40E+38/,
CS   1     XMAX/85.343E+0/
CD    DATA XLEAST/2.23D-308/,XSMALL/1.11D-16/,XINF/1.79D+308/,
CD   1     XMAX/705.343D+0/
C--------------------------------------------------------------------
C  Coefficients for  XLEAST .LE.  ARG  .LE. 1.0
C--------------------------------------------------------------------
CS    DATA   P/ 4.8127070456878442310E-1, 9.9991373567429309922E+1,
CS   1          7.1885382604084798576E+3, 1.7733324035147015630E+5,
CS   2          7.1938920065420586101E+5/
CS    DATA   Q/-2.8143915754538725829E+2, 3.7264298672067697862E+4,
CS   1         -2.2149374878243304548E+6/
CS    DATA   F/-2.2795590826955002390E-1,-5.3103913335180275253E+1,
CS   1         -4.5051623763436087023E+3,-1.4758069205414222471E+5,
CS   2         -1.3531161492785421328E+6/
CS    DATA   G/-3.0507151578787595807E+2, 4.3117653211351080007E+4,
CS   2         -2.7062322985570842656E+6/
CD    DATA   P/ 4.8127070456878442310D-1, 9.9991373567429309922D+1,
CD   1          7.1885382604084798576D+3, 1.7733324035147015630D+5,
CD   2          7.1938920065420586101D+5/
CD    DATA   Q/-2.8143915754538725829D+2, 3.7264298672067697862D+4,
CD   1         -2.2149374878243304548D+6/
CD    DATA   F/-2.2795590826955002390D-1,-5.3103913335180275253D+1,
CD   1         -4.5051623763436087023D+3,-1.4758069205414222471D+5,
CD   2         -1.3531161492785421328D+6/
CD    DATA   G/-3.0507151578787595807D+2, 4.3117653211351080007D+4,
CD   2         -2.7062322985570842656D+6/
C--------------------------------------------------------------------
C  Coefficients for  1.0 .LT.  ARG
C--------------------------------------------------------------------
CS    DATA  PP/ 6.4257745859173138767E-2, 7.5584584631176030810E+0,
CS   1          1.3182609918569941308E+2, 8.1094256146537402173E+2,
CS   2          2.3123742209168871550E+3, 3.4540675585544584407E+3,
CS   3          2.8590657697910288226E+3, 1.3319486433183221990E+3,
CS   4          3.4122953486801312910E+2, 4.4137176114230414036E+1,
CS   5          2.2196792496874548962E+0/
CS    DATA  QQ/ 3.6001069306861518855E+1, 3.3031020088765390854E+2,
CS   1          1.2082692316002348638E+3, 2.1181000487171943810E+3,
CS   2          1.9448440788918006154E+3, 9.6929165726802648634E+2,
CS   3          2.5951223655579051357E+2, 3.4552228452758912848E+1,
CS   4          1.7710478032601086579E+0/
CD    DATA  PP/ 6.4257745859173138767D-2, 7.5584584631176030810D+0,
CD   1          1.3182609918569941308D+2, 8.1094256146537402173D+2,
CD   2          2.3123742209168871550D+3, 3.4540675585544584407D+3,
CD   3          2.8590657697910288226D+3, 1.3319486433183221990D+3,
CD   4          3.4122953486801312910D+2, 4.4137176114230414036D+1,
CD   5          2.2196792496874548962D+0/
CD    DATA  QQ/ 3.6001069306861518855D+1, 3.3031020088765390854D+2,
CD   1          1.2082692316002348638D+3, 2.1181000487171943810D+3,
CD   2          1.9448440788918006154D+3, 9.6929165726802648634D+2,
CD   3          2.5951223655579051357D+2, 3.4552228452758912848D+1,
CD   4          1.7710478032601086579D+0/
C--------------------------------------------------------------------
      X = ARG
      IF (X .LT. XLEAST) THEN
C--------------------------------------------------------------------
C  Error return for  ARG  .LT. XLEAST
C--------------------------------------------------------------------
            RESULT = XINF
         ELSE IF (X .LE. ONE) THEN
C--------------------------------------------------------------------
C  XLEAST .LE.  ARG  .LE. 1.0
C--------------------------------------------------------------------
            IF (X .LT. XSMALL) THEN
C--------------------------------------------------------------------
C  Return for small ARG
C--------------------------------------------------------------------
                  RESULT = ONE / X
               ELSE
                  XX = X * X
                  SUMP = ((((P(1)*XX + P(2))*XX + P(3))*XX + P(4))*XX
     1                   + P(5))*XX + Q(3)
                  SUMQ = ((XX + Q(1))*XX + Q(2))*XX + Q(3)
                  SUMF = (((F(1)*XX + F(2))*XX + F(3))*XX + F(4))*XX
     1                   + F(5)
                  SUMG = ((XX + G(1))*XX + G(2))*XX + G(3)
                  RESULT = (XX * LOG(X) * SUMF/SUMG + SUMP/SUMQ) / X
                  IF (JINT .EQ. 2) RESULT = RESULT * EXP(X)
            END IF
         ELSE IF ((JINT .EQ. 1) .AND. (X .GT. XMAX)) THEN
C--------------------------------------------------------------------
C  Error return for  ARG  .GT. XMAX
C--------------------------------------------------------------------
            RESULT = ZERO
         ELSE
C--------------------------------------------------------------------
C  1.0 .LT.  ARG
C--------------------------------------------------------------------
            XX = ONE / X
            SUMP = PP(1)
            DO 120 I = 2, 11
               SUMP = SUMP * XX + PP(I)
  120       CONTINUE
            SUMQ = XX
            DO 140 I = 1, 8
               SUMQ = (SUMQ + QQ(I)) * XX
  140       CONTINUE
            SUMQ = SUMQ + QQ(9)
            RESULT = SUMP / SUMQ / SQRT(X)
            IF (JINT .EQ. 1) RESULT = RESULT * EXP(-X)
      END IF
      RETURN
C---------- Last line of CALCK1 ----------
      END
CS    REAL FUNCTION BESK1(X)
CD    DOUBLE PRECISION FUNCTION BESK1(X)
C--------------------------------------------------------------------
C
C This function program computes approximate values for the
C   modified Bessel function of the second kind of order one
C   for arguments  XLEAST .LE. ARG .LE. XMAX.
C
C--------------------------------------------------------------------
      INTEGER JINT
CS    REAL 
CD    DOUBLE PRECISION  
     1    X, RESULT
C--------------------------------------------------------------------
      JINT = 1
      CALL CALCK1(X,RESULT,JINT)
      BESK1 = RESULT
      RETURN
C---------- Last line of BESK1 ----------
      END
CS    REAL FUNCTION BESEK1(X)
CD    DOUBLE PRECISION FUNCTION BESEK1(X)
C--------------------------------------------------------------------
C
C This function program computes approximate values for the
C   modified Bessel function of the second kind of order one
C   multiplied by the exponential function, for arguments
C   XLEAST .LE. ARG .LE. XMAX.
C
C--------------------------------------------------------------------
      INTEGER JINT
CS    REAL
CD    DOUBLE PRECISION  
     1    X, RESULT
C--------------------------------------------------------------------
      JINT = 2
      CALL CALCK1(X,RESULT,JINT)
      BESEK1 = RESULT
      RETURN
C---------- Last line of BESEK1 ----------
      END
      PROGRAM K1TEST
C--------------------------------------------------------------------
C  FORTRAN 77 program to test BESK1
C
C  Data required
C
C     None
C
C  Subprograms required from this package
C
C     MACHAR - an environmental inquiry program providing
C              information on the floating-point arithmetic
C              system.  Note that the call to MACHAR can
C              be deleted provided the following three
C              parameters are assigned the values indicated
C
C                 IBETA  - the radix of the floating-point system
C                 IT     - the number of base-IBETA digits in the
C                          significand of a floating-point number
C                 MAXEXP - the smallest positive power of BETA
C                          that overflows
C                 EPS    - the smallest positive floating-point
C                          number such that 1.0+EPS .NE. 1.0
C                 XMIN   - the smallest non-vanishing normalized
C                          floating-point power of the radix, i.e.,
C                          XMIN = FLOAT(IBETA) ** MINEXP
C                 XMAX   - the largest finite floating-point number.
C                          In particular XMAX = (1.0-EPSNEG) * 
C                          FLOAT(IBETA) ** MAXEXP
C
C     REN(K) - a function subprogram returning random real
C              numbers uniformly distributed over (0,1)
C
C
C  Intrinsic functions required are:
C
C         ABS, DBLE, LOG, MAX, REAL, SQRT
C
C  User defined functions
C
C         BOT, TOP
C
C  Reference: "Performance evaluation of programs for certain
C              Bessel functions", W. J. Cody and L. Stoltz,
C              ACM Trans. on Math. Software, Vol. 15, 1989,
C              pp 41-48.
C
C  Latest modification: March 14, 1992
C
C  Author - Laura Stoltz 
C          Mathematics and Computer Science Division
C          Argonne National Laboratory
C          Argonne, IL 60439
C--------------------------------------------------------------------
      LOGICAL SFLAG,TFLAG
      INTEGER I,IBETA,IEXP,II,IND,IOUT,IRND,IT,J,JT,K1,K2,K3,
     1        MACHEP,MAXEXP,MB,MINEXP,N,NDUM,NEGEP,NGRD
CS    REAL
CD    DOUBLE PRECISION
     1   A,AIT,ALBETA,ALL9,AMAXEXP,B,BESEK1,BESK0,BESK1,BETA,BOT,C,
     2   CONST,CONV,DEL,EIGHT,EPS,EPSNEG,FIFTEN,FIVE,FOUR8,HALF,HUND,
     3   ONE,ONENEG,ONE28,PI,REN,R6,R7,SUM,T,T1,THIRTY,THREE,TOP,
     4   TWENTY,TWO,U,W,X,XA,XB,XDEN,XL,XLAM,XLARGE,XLEAST,XMAX,XMB,
     5   XMIN,XN,XNINE,X1,Y,Z,ZERO,ZZ
      DIMENSION U(0:559)
C--------------------------------------------------------------------
C  Mathematical constants
C--------------------------------------------------------------------
CS    DATA ZERO,HALF,ONE,TWO,EIGHT/0.0E0,0.5E0,1.0E0,2.0E0,8.0E0/,
CS   1   XNINE,TWENTY,ONE28/9.0E0,20.0E0,128.0E0/,
CS   2   FIVE,ONENEG,XDEN,ALL9/5.0E0,-1.0E0,16.0E0,-999.0E0/,
CS   3   THREE,FIFTEN,THIRTY,FOUR8/3.0E0,15.0E0,30.0E0,48.0E0/,
CS   4   PI/3.141592653589793E0/,HUND/100.0E0/
CD    DATA ZERO,HALF,ONE,TWO,EIGHT/0.0D0,0.5D0,1.0D0,2.0D0,8.0D0/,
CD   1   XNINE,TWENTY,ONE28/9.0D0,20.0D0,128.0D0/,
CD   2   FIVE,ONENEG,XDEN,ALL9/5.0D0,-1.0D0,16.0D0,-999.0D0/,
CD   3   THREE,FIFTEN,THIRTY,FOUR8/3.0D0,15.0D0,30.0D0,48.0D0/,
CD   4   PI/3.141592653589793D0/,HUND/100.0D0/
C---------------------------------------------------------------------
C  Machine-dependent constant
C---------------------------------------------------------------------
CS    DATA XLEAST/1.18E-38/
CD    DATA XLEAST/2.23D-308/
      DATA IOUT/6/
      TOP(X) = -X - HALF*LOG(TWO*X) + LOG(ONE+(THREE/EIGHT-FIFTEN/
     1   ONE28/X)/X)
      BOT(X) = - ONE - HALF/X + ((- FOUR8*X + THIRTY) / 
     1   (((ONE28*X+FOUR8)*X-FIFTEN)*X))
C---------------------------------------------------------------------
C  Statement functions for conversion between integer and float
C---------------------------------------------------------------------
CS    CONV(NDUM) = REAL(NDUM)
CD    CONV(NDUM) = DBLE(NDUM)
C--------------------------------------------------------------------
C  Determine machine parameters and set constants
C--------------------------------------------------------------------
      CALL MACHAR(IBETA,IT,IRND,NGRD,MACHEP,NEGEP,IEXP,MINEXP,
     1            MAXEXP,EPS,EPSNEG,XMIN,XMAX)
      BETA = CONV(IBETA)
      ALBETA = LOG(BETA)
      AIT = CONV(IT)
      AMAXEXP = CONV(MAXEXP)
      JT = 0
      B = EPS
      XLAM = (XDEN - ONE) / XDEN
      CONST = HALF * LOG(PI) - LOG(XMIN)
C--------------------------------------------------------------------
C     Random argument accuracy tests
C--------------------------------------------------------------------
      DO 300 J = 1, 3
         SFLAG = ((J .EQ. 1) .AND. (AMAXEXP/AIT .LE. FIVE))
         K1 = 0
         K2 = 0
         K3 = 0
         X1 = ZERO
         R6 = ZERO
         R7 = ZERO
         N = 2000
         A = B
         IF (J .EQ. 1) THEN
               B = ONE
            ELSE IF (J .EQ. 2) THEN
               B = EIGHT
            ELSE
               B = TWENTY
         END IF
         XN = CONV(N)
         DEL = (B - A) / XN
         XL = A
C---------------------------------------------------------------------
C   Accuracy test is based on the multiplication theorem
C---------------------------------------------------------------------
         DO 200 I = 1, N
            X = DEL * REN(JT) + XL
            Y = X / XLAM
            W = XDEN * Y
            Y = (W + Y) - W 
            X = Y * XLAM
            U(0) = BESK0(Y)
            U(1) = BESK1(Y)
            TFLAG = SFLAG .AND. (Y .LT. HALF)
            IF (TFLAG) THEN
                  U(0) = U(0) * EPS
                  U(1) = U(1) * EPS
            END IF
            MB = 1
            XMB = ONE
            Y = Y * HALF
            W = (ONE-XLAM) * (ONE+XLAM)
            C = W *Y 
            T = U(0) + C * U(1)
            T1 = EPS / HUND
            DO 110 II = 2, 60
               Z = U(II-1)
               IF (Z/T1 .LT. T) THEN
                     GO TO 120
                  ELSE IF (U(II-1) .GT. ONE) THEN
                     IF ((XMB/Y) .GT. (XMAX/U(II-1))) THEN
                           XL = XL + DEL
                           A = XL
                           GO TO  200
                     END IF
               END IF
               U(II) = XMB/Y * U(II-1) + U(II-2)
               IF (T1 .GT. ONE/EPS) THEN
                     T = T * T1
                     T1 = ONE
               END IF
               T1 = XMB * T1 / C
               XMB = XMB + ONE
               MB = MB + 1
  110       CONTINUE
  120       SUM = U(MB)
            IND = MB
            MB = MB - 1
            DO 155 II = 1, MB
               XMB = XMB - ONE
               IND = IND - 1
               SUM = SUM * W * Y / XMB + U(IND)
  155       CONTINUE
            ZZ = SUM
            IF (TFLAG) ZZ = ZZ / EPS
            ZZ = ZZ * XLAM
            Z = BESK1(X)
            Y = Z
            IF (U(0) .GT. Y) Y= U(0)
            W = (Z - ZZ) / Y
            IF (W .GT. ZERO) THEN 
                  K1 = K1 + 1
               ELSE IF (W .LT. ZERO) THEN 
                  K3 = K3 + 1
               ELSE
                  K2 = K2 + 1
            END IF
            W = ABS(W)
            IF (W .GT. R6) THEN
                  R6 = W
                  X1 = X
            END IF
            R7 = R7 + W * W
            XL = XL + DEL
  200    CONTINUE
         N = K1 + K2 + K3
         XN = CONV(N)
         R7 = SQRT(R7/XN)
         WRITE (IOUT,1000)
         WRITE (IOUT,1010) N,A,B
         WRITE (IOUT,1011) K1,K2,K3
         WRITE (IOUT,1020) IT,IBETA
         W = ALL9
         IF (R6 .NE. ZERO) W = LOG(R6)/ALBETA
         IF (J .EQ. 3) THEN
               WRITE (IOUT,1024) R6,IBETA,W,X1
            ELSE
               WRITE (IOUT,1021) R6,IBETA,W,X1
         END IF
         W = MAX(AIT+W,ZERO)
         WRITE (IOUT,1022) IBETA,W
         W = ALL9
         IF (R7 .NE. ZERO) W = LOG(R7)/ALBETA
         IF (J .EQ. 3) THEN
               WRITE (IOUT,1025) R7,IBETA,W
            ELSE
               WRITE (IOUT,1023) R7,IBETA,W
         END IF
         W = MAX(AIT+W,ZERO)
         WRITE (IOUT,1022) IBETA,W
  300 CONTINUE
C--------------------------------------------------------------------
C  Special tests
C--------------------------------------------------------------------
      WRITE (IOUT,1030)
      WRITE (IOUT,1031)
      Y = BESK1(XLEAST)
      WRITE (IOUT,1032) Y
      Y = BESK1(XMIN)
      WRITE (IOUT,1036) Y
      Y = BESK1(ZERO)
      WRITE (IOUT,1033) 0,Y
      X = REN(JT) * ONENEG
      Y = BESK1(X)
      WRITE (IOUT,1034) X,Y
      Y = BESEK1(XMAX)
      WRITE (IOUT,1035) Y
      XA = LOG(XMAX)
  330 XB = XA - (TOP(XA)+CONST) / BOT(XA)
      IF (ABS(XB-XA)/XB .LE. EPS) THEN 
            GO TO 350
         ELSE
            XA = XB
            GO TO 330
      END IF
  350 XLARGE = XB * XLAM 
      Y = BESK1(XLARGE)
      WRITE (IOUT,1034) XLARGE,Y
      XLARGE = XB * (XNINE / EIGHT)
      Y = BESK1(XLARGE)
      WRITE (IOUT,1034) XLARGE,Y
C-------------------------------------------------------------------- 
C  Test of error returns 
C--------------------------------------------------------------------
      STOP
 1000 FORMAT('1Test of K1(X) vs Multiplication Theorem'//)
 1010 FORMAT(I7,' random arguments were tested from the interval (',
     1    F5.1,',',F5.1,')'//)
 1011 FORMAT(' ABS(K1(X)) was larger',I6,' times,'/
     1    20X,' agreed',I6,' times, and'/
     1    16X,'was smaller',I6,' times.'//)
 1020 FORMAT(' There are',I4,' base',I4,
     1    ' significant digits in a floating-point number.'//)
 1021 FORMAT(' The maximum relative error of',E15.4,' = ',I4,' **',
     1    F7.2/4X,'occurred for X =',E13.6)
 1022 FORMAT(' The estimated loss of base',I4,
     1    ' significant digits is',F7.2//)
 1023 FORMAT(' The root mean square relative error was',E15.4,
     1    ' = ',I4,' **',F7.2)
 1024 FORMAT(' The maximum absolute error of',E15.4,' = ',I4,' **',
     1    F7.2/4X,'occurred for X =',E13.6)
 1025 FORMAT(' The root mean square absolute error was',E15.4,
     1    ' = ',I4,' **',F7.2)
 1030 FORMAT('1Special Tests'//)
 1031 FORMAT(//' Test with extreme arguments'/)
 1032 FORMAT(' K1(XLEAST) = ',E24.17/)
 1033 FORMAT(' K1(',I1,') = ',E24.17/)
 1034 FORMAT(' K1(',E24.17,' ) = ',E24.17/)
 1035 FORMAT(' E**X * K1(XMAX) = ',E24.17/)
 1036 FORMAT(' K1(XMIN) = ',E24.17/)
C---------- Last line of BESK0 test program ----------
      END
CS    REAL FUNCTION PSI(XX)
CD    DOUBLE PRECISION FUNCTION PSI(XX)
C----------------------------------------------------------------------
C
C This function program evaluates the logarithmic derivative of the
C   gamma function, 
C
C      psi(x) = d/dx (gamma(x)) / gamma(x) = d/dx (ln gamma(x))
C
C   for real x, where either
C
C          -xmax1 < x < -xmin (x not a negative integer), or
C            xmin < x.
C
C   The calling sequence for this function is 
C
C                  Y = PSI(X)
C
C   The main computation uses rational Chebyshev approximations
C   published in Math. Comp. 27, 123-127 (1973) by Cody, Strecok and
C   Thacher.  This transportable program is patterned after the
C   machine-dependent FUNPACK program PSI(X), but cannot match that
C   version for efficiency or accuracy.  This version uses rational
C   approximations that are theoretically accurate to 20 significant
C   decimal digits.  The accuracy achieved depends on the arithmetic
C   system, the compiler, the intrinsic functions, and proper selection
C   of the machine-dependent constants.
C
C*******************************************************************
C*******************************************************************
C
C The following machine-dependent constants must be declared in
C   DATA statements.  IEEE values are provided as a default.
C
C   XINF   = largest positive machine number
C   XMAX1  = beta ** (p-1), where beta is the radix for the
C            floating-point system, and p is the number of base-beta
C            digits in the floating-point significand.  This is an
C            upper bound on non-integral floating-point numbers, and
C            the negative of the lower bound on acceptable negative
C            arguments for PSI.  If rounding is necessary, round this
C            value down.
C   XMIN1  = the smallest in magnitude acceptable argument.  We
C            recommend XMIN1 = MAX(1/XINF,xmin) rounded up, where
C            xmin is the smallest positive floating-point number.
C   XSMALL = absolute argument below which  PI*COTAN(PI*X)  may be
C            represented by 1/X.  We recommend XSMALL < sqrt(3 eps)/pi,
C            where eps is the smallest positive number such that
C            1+eps > 1. 
C   XLARGE = argument beyond which PSI(X) may be represented by
C            LOG(X).  The solution to the equation
C               x*ln(x) = beta ** p
C            is a safe value.
C
C     Approximate values for some important machines are
C
C                        beta  p     eps     xmin       XINF  
C
C  CDC 7600      (S.P.)    2  48  7.11E-15  3.13E-294  1.26E+322
C  CRAY-1        (S.P.)    2  48  7.11E-15  4.58E-2467 5.45E+2465
C  IEEE (IBM/XT,
C    SUN, etc.)  (S.P.)    2  24  1.19E-07  1.18E-38   3.40E+38
C  IEEE (IBM/XT,
C    SUN, etc.)  (D.P.)    2  53  1.11D-16  2.23E-308  1.79D+308
C  IBM 3033      (D.P.)   16  14  1.11D-16  5.40D-79   7.23D+75
C  SUN 3/160     (D.P.)    2  53  1.11D-16  2.23D-308  1.79D+308
C  VAX 11/780    (S.P.)    2  24  5.96E-08  2.94E-39   1.70E+38
C                (D.P.)    2  56  1.39D-17  2.94D-39   1.70D+38
C   (G Format)   (D.P.)    2  53  1.11D-16  5.57D-309  8.98D+307
C
C                         XMIN1      XMAX1     XSMALL    XLARGE
C
C  CDC 7600      (S.P.)  3.13E-294  1.40E+14  4.64E-08  9.42E+12
C  CRAY-1        (S.P.)  1.84E-2466 1.40E+14  4.64E-08  9.42E+12
C  IEEE (IBM/XT,
C    SUN, etc.)  (S.P.)  1.18E-38   8.38E+06  1.90E-04  1.20E+06
C  IEEE (IBM/XT,
C    SUN, etc.)  (D.P.)  2.23D-308  4.50D+15  5.80D-09  2.71D+14
C  IBM 3033      (D.P.)  1.39D-76   4.50D+15  5.80D-09  2.05D+15
C  SUN 3/160     (D.P.)  2.23D-308  4.50D+15  5.80D-09  2.71D+14
C  VAX 11/780    (S.P.)  5.89E-39   8.38E+06  1.35E-04  1.20E+06
C                (D.P.)  5.89D-39   3.60D+16  2.05D-09  2.05D+15
C   (G Format)   (D.P.)  1.12D-308  4.50D+15  5.80D-09  2.71D+14
C
C*******************************************************************
C*******************************************************************
C
C Error Returns
C
C  The program returns XINF for  X < -XMAX1, for X zero or a negative
C    integer, or when X lies in (-XMIN1, 0), and returns -XINF
C    when X lies in (0, XMIN1).
C
C Intrinsic functions required are:
C
C     ABS, AINT, DBLE, INT, LOG, REAL, TAN
C
C
C  Author: W. J. Cody
C          Mathematics and Computer Science Division 
C          Argonne National Laboratory
C          Argonne, IL 60439
C
C  Latest modification: March 14, 1992
C
C----------------------------------------------------------------------
      INTEGER I,N,NQ
CS    REAL
CD    DOUBLE PRECISION
     1   AUG,CONV,DEN,FOUR,FOURTH,HALF,ONE,P1,P2,PIOV4,Q1,Q2,
     2   SGN,THREE,XLARGE,UPPER,W,X,XINF,XMAX1,XMIN1,XSMALL,X01,
     3   X01D,X02,XX,Z,ZERO
      DIMENSION P1(9),P2(7),Q1(8),Q2(6)
C----------------------------------------------------------------------
C  Mathematical constants.  PIOV4 = pi / 4
C----------------------------------------------------------------------
CS    DATA ZERO,FOURTH,HALF,ONE/0.0E0,0.25E0,0.5E0,1.0E0/
CS    DATA THREE,FOUR/3.0E0,4.0E0/,PIOV4/7.8539816339744830962E-01/
CD    DATA ZERO,FOURTH,HALF,ONE/0.0D0,0.25D0,0.5D0,1.0D0/
CD    DATA THREE,FOUR/3.0D0,4.0D0/,PIOV4/7.8539816339744830962D-01/
C----------------------------------------------------------------------
C  Machine-dependent constants
C----------------------------------------------------------------------
CS    DATA XINF/3.40E+38/, XMIN1/1.18E-38/, XMAX1/8.38E+06/,
CS   1     XSMALL/1.90E-04/, XLARGE/1.20E+06/
CD    DATA XINF/1.79D+308/, XMIN1/2.23D-308/, XMAX1/4.50D+15/,
CD   1     XSMALL/5.80D-09/, XLARGE/2.71D+14/
C----------------------------------------------------------------------
C  Zero of psi(x)
C----------------------------------------------------------------------
CS    DATA X01/187.0E0/,X01D/128.0E0/,X02/6.9464496836234126266E-04/
CD    DATA X01/187.0D0/,X01D/128.0D0/,X02/6.9464496836234126266D-04/
C----------------------------------------------------------------------
C  Coefficients for approximation to  psi(x)/(x-x0)  over [0.5, 3.0]
C----------------------------------------------------------------------
CS    DATA P1/4.5104681245762934160E-03,5.4932855833000385356E+00,
CS   1        3.7646693175929276856E+02,7.9525490849151998065E+03,
CS   2        7.1451595818951933210E+04,3.0655976301987365674E+05,
CS   3        6.3606997788964458797E+05,5.8041312783537569993E+05,
CS   4        1.6585695029761022321E+05/
CS    DATA Q1/9.6141654774222358525E+01,2.6287715790581193330E+03,
CS   1        2.9862497022250277920E+04,1.6206566091533671639E+05,
CS   2        4.3487880712768329037E+05,5.4256384537269993733E+05,
CS   3        2.4242185002017985252E+05,6.4155223783576225996E-08/
CD    DATA P1/4.5104681245762934160D-03,5.4932855833000385356D+00,
CD   1        3.7646693175929276856D+02,7.9525490849151998065D+03,
CD   2        7.1451595818951933210D+04,3.0655976301987365674D+05,
CD   3        6.3606997788964458797D+05,5.8041312783537569993D+05,
CD   4        1.6585695029761022321D+05/
CD    DATA Q1/9.6141654774222358525D+01,2.6287715790581193330D+03,
CD   1        2.9862497022250277920D+04,1.6206566091533671639D+05,
CD   2        4.3487880712768329037D+05,5.4256384537269993733D+05,
CD   3        2.4242185002017985252D+05,6.4155223783576225996D-08/
C----------------------------------------------------------------------
C  Coefficients for approximation to  psi(x) - ln(x) + 1/(2x) 
C     for  x > 3.0
C----------------------------------------------------------------------
CS    DATA P2/-2.7103228277757834192E+00,-1.5166271776896121383E+01,
CS   1        -1.9784554148719218667E+01,-8.8100958828312219821E+00,
CS   2        -1.4479614616899842986E+00,-7.3689600332394549911E-02,
CS   3        -6.5135387732718171306E-21/
CS    DATA Q2/ 4.4992760373789365846E+01, 2.0240955312679931159E+02,
CS   1         2.4736979003315290057E+02, 1.0742543875702278326E+02,
CS   2         1.7463965060678569906E+01, 8.8427520398873480342E-01/
CD    DATA P2/-2.7103228277757834192D+00,-1.5166271776896121383D+01,
CD   1        -1.9784554148719218667D+01,-8.8100958828312219821D+00,
CD   2        -1.4479614616899842986D+00,-7.3689600332394549911D-02,
CD   3        -6.5135387732718171306D-21/
CD    DATA Q2/ 4.4992760373789365846D+01, 2.0240955312679931159D+02,
CD   1         2.4736979003315290057D+02, 1.0742543875702278326D+02,
CD   2         1.7463965060678569906D+01, 8.8427520398873480342D-01/
C----------------------------------------------------------------------
CS    CONV(I) = REAL(I)
CD    CONV(I) = DBLE(I)
      X = XX
      W = ABS(X)
      AUG = ZERO
C----------------------------------------------------------------------
C  Check for valid arguments, then branch to appropriate algorithm
C----------------------------------------------------------------------
      IF ((-X .GE. XMAX1) .OR. (W .LT. XMIN1)) THEN
            GO TO 410
         ELSE IF (X .GE. HALF) THEN
            GO TO 200
C----------------------------------------------------------------------
C  X < 0.5, use reflection formula: psi(1-x) = psi(x) + pi * cot(pi*x)
C     Use 1/X for PI*COTAN(PI*X)  when  XMIN1 < |X| <= XSMALL.  
C----------------------------------------------------------------------
         ELSE IF (W .LE. XSMALL) THEN
            AUG = -ONE / X
            GO TO 150
      END IF
C----------------------------------------------------------------------
C  Argument reduction for cot
C----------------------------------------------------------------------
  100 IF (X .LT. ZERO) THEN
            SGN = PIOV4
         ELSE
            SGN = -PIOV4
      END IF
      W = W - AINT(W)
      NQ = INT(W * FOUR)
      W = FOUR * (W - CONV(NQ) * FOURTH)
C----------------------------------------------------------------------
C  W is now related to the fractional part of  4.0 * X.
C     Adjust argument to correspond to values in the first
C     quadrant and determine the sign.
C----------------------------------------------------------------------
      N = NQ / 2
      IF ((N+N) .NE. NQ) W = ONE - W
      Z = PIOV4 * W
      IF (MOD(N,2) .NE. 0) SGN = - SGN
C----------------------------------------------------------------------
C  determine the final value for  -pi * cotan(pi*x)
C----------------------------------------------------------------------
      N = (NQ + 1) / 2
      IF (MOD(N,2) .EQ. 0) THEN
C----------------------------------------------------------------------
C  Check for singularity
C----------------------------------------------------------------------
            IF (Z .EQ. ZERO) GO TO 410
            AUG = SGN * (FOUR / TAN(Z))
         ELSE
            AUG = SGN * (FOUR * TAN(Z))
      END IF
  150 X = ONE - X
  200 IF (X .GT. THREE) GO TO 300
C----------------------------------------------------------------------
C  0.5 <= X <= 3.0
C----------------------------------------------------------------------
      DEN = X
      UPPER = P1(1) * X
      DO 210 I = 1, 7
         DEN = (DEN + Q1(I)) * X
         UPPER = (UPPER + P1(I+1)) * X
  210 CONTINUE
      DEN = (UPPER + P1(9)) / (DEN + Q1(8))
      X = (X-X01/X01D) - X02
      PSI = DEN * X + AUG
      GO TO 500
C----------------------------------------------------------------------
C  3.0 < X 
C----------------------------------------------------------------------
  300 IF (X .LT. XLARGE) THEN
         W = ONE / (X * X)
         DEN = W
         UPPER = P2(1) * W
         DO 310 I = 1, 5
            DEN = (DEN + Q2(I)) * W
            UPPER = (UPPER + P2(I+1)) * W
  310    CONTINUE
         AUG = (UPPER + P2(7)) / (DEN + Q2(6)) - HALF / X + AUG
      END IF
      PSI = AUG + LOG(X)
      GO TO 500
C----------------------------------------------------------------------
C  Error return
C----------------------------------------------------------------------
  410 PSI = XINF
      IF (X .GT. ZERO) PSI = -XINF
  500 RETURN
C---------- Last card of PSI ----------
      END
      PROGRAM PSITST
C--------------------------------------------------------------------
C  Fortran 77 program to test PSI
C
C  Data required
C
C     None
C
C  Subprograms required from this package
C
C     MACHAR - an environmental inquiry program providing
C              information on the floating-point arithmetic
C              system.  Note that the call to MACHAR can
C              be deleted provided the following five
C              parameters are assigned the values indicated
C
C                 IBETA  - the radix of the floating-point system
C                 IT     - the number of base-IBETA digits in the
C                          significand of a floating-point number
C                 MINEXP - the largest in magnitude negative
C                          integer such that  FLOAT(IBETA)**MINEXP
C                          is a positive floating-point number
C                 EPS    - the smallest positive floating-point
C                          number such that 1.0+EPS .NE. 1.0
C                 EPSNEG - the smallest positive floating-point
C                          number such that 1.0-EPSNEG .NE. 1.0
C
C     REN(K) - a function subprogram returning random real
C              numbers uniformly distributed over (0,1)
C
C
C  Intrinsic Fortran functions required are:
C
C         ABS, DBLE, LOG, MAX, REAL, SQRT
C
C  Reference: "Performance evaluation of programs related
C              to the real gamma function", W. J. Cody, 
C              submitted for publication.
C
C  Latest modification: March 14, 1992
C
C  Author: W. J. Cody
C          Mathematics and Computer Science Division
C          Argonne National Laboratory
C          Argonne, IL 60439
C
C--------------------------------------------------------------------
      INTEGER I,IBETA,IEXP,IOUT,IRND,IT,J,JT,K1,K2,K3,
     1        MACHEP,MAXEXP,MINEXP,N,NDUM,NEGEP,NGRD
CS    REAL
CD    DOUBLE PRECISION
     1   A,AIT,ALBETA,ALL9,B,BETA,CONV,DEL,EIGHT,EPS,
     2   EPSNEG,HALF,ONE,ONE7,ONE6,PSI,REN,R6,R7,THREE,
     3   TWENTY,Y,V0,W,X,XH,XL,XL2,XMAX,XMIN,XN,XX,X0,
     4   X01,X1,Z,ZERO,ZH,ZZ
CS    DATA ZERO,ONE,THREE/0.0E0,1.0E0,3.0E0/,
CS   1   HALF,EIGHT,TWENTY,ALL9/0.5E0,8.0E0,20.0E0,-999.0E0/,
CS   2   XL2/6.9314718055994530942E-1/,
CS   3   ONE7,ONE6/-17.625E0,-16.875E0/,
CS   4   X0,X01,V0/374.0E0,256.0E0,-6.7240239024288040437E-04/
CD    DATA ZERO,ONE,THREE/0.0E0,1.0E0,3.0E0/,
CD   1   HALF,EIGHT,TWENTY,ALL9/0.5D0,8.0D0,20.0D0,-999.0D0/,
CD   2   XL2/6.9314718055994530942D-1/,
CD   3   ONE7,ONE6/-17.625D0,-16.875D0/,
CD   4   X0,X01,V0/374.0D0,256.0D0,-6.7240239024288040437D-04/
      DATA IOUT/6/
C--------------------------------------------------------------------
C  Statement functions for conversion between integer and float
C--------------------------------------------------------------------
CS    CONV(NDUM) = REAL(NDUM)
CD    CONV(NDUM) = DBLE(NDUM)
C--------------------------------------------------------------------
C  Determine machine parameters and set constants
C--------------------------------------------------------------------
      CALL MACHAR(IBETA,IT,IRND,NGRD,MACHEP,NEGEP,IEXP,MINEXP,
     1            MAXEXP,EPS,EPSNEG,XMIN,XMAX)
      BETA = CONV(IBETA)
      ALBETA = LOG(BETA)
      AIT = CONV(IT)
      JT = 0
C--------------------------------------------------------------------
C     Random argument accuracy tests
C--------------------------------------------------------------------
      DO 300 J = 1, 4
         K1 = 0
         K3 = 0
         X1 = ZERO
         R6 = ZERO
         R7 = ZERO
         N = 2000
         IF (J .EQ. 1) THEN
               A = ZERO
               B = ONE
            ELSE IF (J .EQ. 2) THEN
               A = B + B
               B = EIGHT
            ELSE IF (J .EQ. 3) THEN
               A = B
               B = TWENTY
            ELSE
               A = ONE7
               B = ONE6
               N = 500
         END IF
         XN = CONV(N)
         DEL = (B - A) / XN
         XL = A
         DO 200 I = 1, N
            X = DEL * REN(JT) + XL
C--------------------------------------------------------------------
C  Carefully purify arguments and evaluate identity
C--------------------------------------------------------------------
            XX = X * HALF
            XH = XX + HALF
            XX = XH - HALF
            X = XX + XX
            Z = PSI(X)
            ZH = PSI(XH)
            ZZ = PSI(XX)
            ZZ = (ZZ+ZH)*HALF + XL2
C--------------------------------------------------------------------
C  Accumulate results
C--------------------------------------------------------------------
            W = (ZZ - Z) / ZZ
            IF (W .GT. ZERO) THEN
                  K1 = K1 + 1
               ELSE IF (W .LT. ZERO) THEN
                  K3 = K3 + 1
            END IF
            W = ABS(W)
            IF (W .GT. R6) THEN
               R6 = W
               X1 = X
            END IF
            R7 = R7 + W * W
            XL = XL + DEL
  200    CONTINUE
C--------------------------------------------------------------------
C  Process and output statistics
C--------------------------------------------------------------------
         K2 = N - K3 - K1
         R7 = SQRT(R7/XN)
         IF (2*(J/2) .NE. J) WRITE (IOUT,1000)
         WRITE (IOUT,1001)
         WRITE (IOUT,1010) N,A,B
         WRITE (IOUT,1011) K1,K2,K3
         WRITE (IOUT,1020) IT,IBETA
         IF (R6 .NE. ZERO) THEN
               W = LOG(ABS(R6))/ALBETA
            ELSE
               W = ALL9
         END IF
         WRITE (IOUT,1021) R6,IBETA,W,X1
         W = MAX(AIT+W,ZERO)
         WRITE (IOUT,1022) IBETA,W
         IF (R7 .NE. ZERO) THEN
               W = LOG(ABS(R7))/ALBETA
            ELSE
               W = ALL9
         END IF
         WRITE (IOUT,1023) R7,IBETA,W
         W = MAX(AIT+W,ZERO)
         WRITE (IOUT,1022) IBETA,W
  300 CONTINUE
C--------------------------------------------------------------------
C  Special tests
C--------------------------------------------------------------------
      WRITE (IOUT,1030)
         X = X0/X01
         Y = PSI(X)
         Z = (Y-V0)/V0
         IF (Z .NE. ZERO) THEN
               W = LOG(ABS(Z))/ALBETA
            ELSE
               W = ALL9
         END IF
         W = MAX(AIT+W,ZERO)
         WRITE (IOUT,1031) X,Y,IBETA,W
      WRITE (IOUT,1033)
      IF (XMAX*XMIN .GE. ONE) THEN
            X = XMIN
         ELSE 
            X = ONE / XMAX
      END IF
      WRITE (IOUT,1035) X
      Y = PSI(X)
      WRITE (IOUT,1036) Y
      X = XMAX
      WRITE (IOUT,1035) X
      Y = PSI(X)
      WRITE (IOUT,1036) Y
C--------------------------------------------------------------------
C  Test of error returns
C--------------------------------------------------------------------
      WRITE (IOUT,1037)
      X = ZERO
      WRITE (IOUT,1034) X
      Y = PSI(X)
      WRITE (IOUT,1036) Y
      X = -THREE/EPS
      WRITE (IOUT,1034) X
      Y = PSI(X)
      WRITE (IOUT,1036) Y
      WRITE (IOUT,1100)
      STOP
C--------------------------------------------------------------------
 1000 FORMAT('1')
 1001 FORMAT(' Test of PSI(X) vs (PSI(X/2)+PSI(X/2+1/2))/2 + ln(2)'
     1 //)
 1010 FORMAT(I7,' random arguments were tested from the interval ',
     1 1H(,F5.1,1H,,F5.1,1H)//)
 1011 FORMAT(' ABS(PSI(X)) was larger',I6,' times', /
     1     21X,' agreed',I6,' times, and'/
     1   17X,'was smaller',I6,' times.'//)
 1020 FORMAT(' There are',I4,' base',I4,
     1    ' significant digits in a floating-point number.' //)
 1021 FORMAT(' The maximum relative error of',E15.4,3H = ,I4,3H **,
     1  F7.2/4X,'occurred for X =',E13.6)
 1022 FORMAT(' The estimated loss of base',I4,
     1  ' significant digits is',F7.2//)
 1023 FORMAT(' The root mean square relative error was',E15.4,
     1    3H = ,I4,3H **,F7.2)
 1030 FORMAT('1Special Tests'//)
 1031 FORMAT(' Accuracy near positive zero'//' PSI(',E14.7,') = ',
     1    E24.17/13X,'Loss of base',I3,' digits = ',F7.2/)
 1033 FORMAT(//' Test with extreme arguments'/)
 1034 FORMAT(' PSI will be called with the argument ',E17.10/
     1     ' This may stop execution.'/)
 1035 FORMAT(' PSI will be called with the argument ',E17.10/
     1     ' This should not stop execution.'/)
 1036 FORMAT(' PSI returned the value',E25.17//)
 1037 FORMAT(//' Test of error returns'//)
 1100 FORMAT(' This concludes the tests.')
C---------- Last card of PSI test program ----------
      END
CS    REAL FUNCTION REN(K)
CD    DOUBLE PRECISION FUNCTION REN(K)
C---------------------------------------------------------------------
C  Random number generator - based on Algorithm 266 by Pike and
C   Hill (modified by Hansson), Communications of the ACM,
C   Vol. 8, No. 10, October 1965.
C
C  This subprogram is intended for use on computers with
C   fixed point wordlength of at least 29 bits.  It is
C   best if the floating-point significand has at most
C   29 bits.
C
C  Latest modification: March 13, 1992
C
C  Author: W. J. Cody
C          Mathematics and Computer Science Division
C          Argonne National Laboratory
C          Argonne, IL 60439
C
C---------------------------------------------------------------------
      INTEGER IY,J,K
CS    REAL             CONV,C1,C2,C3,ONE
CD    DOUBLE PRECISION CONV,C1,C2,C3,ONE
      DATA IY/100001/
CS    DATA ONE,C1,C2,C3/1.0E0,2796203.0E0,1.0E-6,1.0E-12/
CD    DATA ONE,C1,C2,C3/1.0D0,2796203.0D0,1.0D-6,1.0D-12/
C---------------------------------------------------------------------
C  Statement functions for conversion between integer and float
C---------------------------------------------------------------------
CS    CONV(J) = REAL(J)
CD    CONV(J) = DBLE(J)
C---------------------------------------------------------------------
      J = K
      IY = IY * 125
      IY = IY - (IY/2796203) * 2796203
      REN = CONV(IY) / C1 * (ONE + C2 + C3)
      RETURN
C---------- Last card of REN ----------
      END
      PROGRAM Y0TEST
C--------------------------------------------------------------------
C  Fortran 77 program to test BESY0
C
C  Data required
C
C     None
C
C  Subprograms required from this package
C
C     MACHAR - an environmental inquiry program providing
C              information on the floating-point arithmetic
C              system.  Note that the call to MACHAR can
C              be deleted provided the following five
C              parameters are assigned the values indicated
C
C                 IBETA  - the radix of the floating-point system
C                 IT     - the number of base-IBETA digits in the
C                          significand of a floating-point number
C                 MINEXP - the largest in magnitude negative
C                          integer such that  FLOAT(IBETA)**MINEXP
C                          is a positive floating-point number
C                 EPS    - the smallest positive floating-point
C                          number such that 1.0+EPS .NE. 1.0
C                 EPSNEG - the smallest positive floating-point
C                          number such that 1.0-EPSNEG .NE. 1.0
C
C     REN(K) - a function subprogram returning random real
C              numbers uniformly distributed over (0,1)
C
C
C  Intrinsic functions required are:
C
C         ABS, DBLE, LOG, MAX, REAL, SQRT
C
C  Reference: "Performance evaluation of programs for certain
C              Bessel functions", W. J. Cody and L. Stoltz,
C              ACM Trans. on Math. Software, Vol. 15, 1989,
C              pp 41-48.
C
C  Latest modification: March 13, 1992
C
C  Author: W. J. Cody
C          Mathematics and Computer Science Division
C          Argonne National Laboratory
C          Argonne, IL 60439
C
C--------------------------------------------------------------------
      LOGICAL SFLAG,TFLAG
      INTEGER I,IBETA,IEXP,II,IND,IOUT,IRND,IT,J,JT,K1,K2,K3,
     1        MACHEP,MAXEXP,MB,MINEXP,N,NDUM,NEGEP,NGRD
CS    REAL
CD    DOUBLE PRECISION
     1   A,AIT,ALBETA,ALL9,B,BESY0,BESY1,BETA,C,CONV,DEL,EIGHT,
     2   EPS,EPSNEG,FIVE5,HALF,HUND,ONE,REN,R6,R7,SIXTEN,SUM,T,
     3   T1,THREE,TWENTY,TWO56,U,W,X,XI,XL,XLAM,XMAX,XMB,XMIN,
     4   X1,Y,YX,Z,ZERO,ZZ
      DIMENSION U(560),XI(3),YX(3)
CS    DATA ZERO,ONE,THREE,FIVE5/0.0E0,1.0E0,3.0E0,5.5E0/,
CS   1   EIGHT,TWENTY,ALL9,TWO56/8.0E0,20.0E0,-999.0E0,256.0E0/,
CS   2   HALF,SIXTEN,XLAM,HUND/0.5E0,16.0E0,0.9375E0,100.0D0/
CS    DATA XI/228.0E0,1013.0E0,1814.0E0/
CS    DATA YX(1)/-2.6003 14272 29334 87915 E-3/,
CS   1     YX(2)/ 2.6053 45491 14567 74983 E-4/,
CS   2     YX(3)/-3.4079 44871 47955 52077 E-5/
CD    DATA ZERO,ONE,THREE,FIVE5/0.0D0,1.0D0,3.0D0,5.5D0/,
CD   1   EIGHT,TWENTY,ALL9,TWO56/8.0D0,20.0D0,-999.0D0,256.0D0/,
CD   2   HALF,SIXTEN,XLAM,HUND/0.5D0,16.0D0,0.9375D0,100.0D0/
CD    DATA XI/228.0D0,1013.0D0,1814.0D0/
CD    DATA YX(1)/-2.6003 14272 29334 87915 D-3/,
CD   1     YX(2)/ 2.6053 45491 14567 74983 D-4/,
CD   2     YX(3)/-3.4079 44871 47955 52077 D-5/
      DATA IOUT/6/
C--------------------------------------------------------------------
C  Statement functions for conversion between integer and float
C--------------------------------------------------------------------
CS    CONV(NDUM) = REAL(NDUM)
CD    CONV(NDUM) = DBLE(NDUM)
C--------------------------------------------------------------------
C  Determine machine parameters and set constants
C--------------------------------------------------------------------
      CALL MACHAR(IBETA,IT,IRND,NGRD,MACHEP,NEGEP,IEXP,MINEXP,
     1            MAXEXP,EPS,EPSNEG,XMIN,XMAX)
      BETA = CONV(IBETA)
      ALBETA = LOG(BETA)
      AIT = CONV(IT)
      JT = 0
      A = EPS
      B = THREE
      N = 2000
C--------------------------------------------------------------------
C  Random argument accuracy tests based on the multiplication theorem
C--------------------------------------------------------------------
      DO 300 J = 1, 4
         SFLAG = (J .EQ. 1) .AND. (MAXEXP/IT .LE. 5)
         K1 = 0
         K2 = 0
         K3 = 0
         X1 = ZERO
         R6 = ZERO
         R7 = ZERO
         DEL = (B - A) / CONV(N)
         XL = A
         DO 200 I = 1, N
            X = DEL * REN(JT) + XL
C--------------------------------------------------------------------
C  Carefully purify arguments
C--------------------------------------------------------------------
            Y = X/XLAM
            W = SIXTEN * Y
            Y = (W + Y) - W
            X = Y * XLAM
C--------------------------------------------------------------------
C  Generate Bessel functions with forward recurrence
C--------------------------------------------------------------------
            U(1) = BESY0(Y)
            U(2) = BESY1(Y)
            TFLAG = SFLAG .AND. (Y .LT. HALF)
            IF (TFLAG) THEN
               U(1) = U(1) * EPS 
               U(2) = U(2) * EPS
            END IF
            MB = 1
            XMB = ONE
            Y = Y * HALF
            W = (ONE-XLAM)*(ONE+XLAM)
            C = W * Y
            T = ABS(U(1)+C*U(2))
            T1 = EPS/HUND
            DO 110 II = 3, 60
               Z = ABS(U(II-1))
               IF (Z/T1 .LT. T) GO TO 120
               IF (Y .LT. XMB) THEN
                  IF (Z .GT. XMAX*(Y/XMB)) THEN
                     A = X
                     XL = XL + DEL
                     GO TO  200
                  END IF
               END IF
               U(II) = XMB/Y * U(II-1) - U(II-2)
               IF (T1 .GT. ONE/EPS) THEN
                  T = T * T1
                  T1 = ONE
               END IF
               T1 = XMB * T1 / C
               XMB = XMB + ONE
               MB = MB + 1
  110       CONTINUE
C--------------------------------------------------------------------
C  Evaluate Bessel series expansion
C--------------------------------------------------------------------
  120       SUM = U(MB)
            IND = MB
            DO 155 II = 2, MB
               IND = IND - 1
               XMB = XMB - ONE
               SUM = SUM * W * Y / XMB + U(IND)
  155       CONTINUE
            ZZ = SUM
            IF (TFLAG) ZZ = ZZ / EPS 
            Z = BESY0(X)
            Y = Z
            IF (ABS(U(1)) .GT. ABS(Y)) Y = U(1)
C--------------------------------------------------------------------
C  Accumulate results
C--------------------------------------------------------------------
            W = (Z - ZZ) / Y
            IF (W .GT. ZERO) THEN
                  K1 = K1 + 1
               ELSE IF (W .LT. ZERO) THEN
                  K3 = K3 + 1
               ELSE
                  K2 = K2 + 1
            END IF
            W = ABS(W)
            IF (W .GT. R6) THEN
               R6 = W
               X1 = X
            END IF
            R7 = R7 + W * W
            XL = XL + DEL
  200    CONTINUE
C--------------------------------------------------------------------
C  Gather and print statistics
C--------------------------------------------------------------------
         N = K1 + K2 + K3
         R7 = SQRT(R7/CONV(N))
         WRITE (IOUT,1000)
         WRITE (IOUT,1010) N,A,B
         WRITE (IOUT,1011) K1,K2,K3
         WRITE (IOUT,1020) IT,IBETA
         W = ALL9
         IF (R6 .NE. ZERO) W = LOG(ABS(R6))/ALBETA
         IF (J .EQ. 4) THEN
               WRITE (IOUT,1024) R6,IBETA,W,X1
            ELSE
               WRITE (IOUT,1021) R6,IBETA,W,X1
         END IF
         W = MAX(AIT+W,ZERO)
         WRITE (IOUT,1022) IBETA,W
         W = ALL9
         IF (R7 .NE. ZERO) W = LOG(ABS(R7))/ALBETA
         IF (J .EQ. 4) THEN
               WRITE (IOUT,1025) R7,IBETA,W
            ELSE
               WRITE (IOUT,1023) R7,IBETA,W
         END IF
         W = MAX(AIT+W,ZERO)
         WRITE (IOUT,1022) IBETA,W
C--------------------------------------------------------------------
C  Initialize for next test
C--------------------------------------------------------------------
         A = B
         IF (J .EQ. 1) THEN
               B = FIVE5
               N = 2000
            ELSE IF (J .EQ. 2) THEN
               B = EIGHT
               N = 2000
            ELSE
               B = TWENTY
               N = 500
         END IF
  300 CONTINUE
C--------------------------------------------------------------------
C  Special tests
C--------------------------------------------------------------------
      WRITE (IOUT,1030)
      WRITE (IOUT,1031) IBETA
      DO 330 I = 1, 3
         X = XI(I)/TWO56
         Y = BESY0(X)
         W = ALL9
         T = (Y-YX(I))/YX(I)
         IF (T .NE. ZERO) W = LOG(ABS(T))/ALBETA
         W = MAX(AIT+W,ZERO)
         WRITE (IOUT,1032) X,Y,W
  330 CONTINUE
C--------------------------------------------------------------------
C  Test of error returns
C--------------------------------------------------------------------
      WRITE (IOUT,1033)
      X = XMIN
      WRITE (IOUT,1035) X
      Y = BESY0(X)
      WRITE (IOUT,1036) Y
      X = ZERO
      WRITE (IOUT,1034) X
      Y = BESY0(X)
      WRITE (IOUT,1036) Y
      X = XMAX
      WRITE (IOUT,1034) X
      Y = BESY0(X)
      WRITE (IOUT,1036) Y
      WRITE (IOUT,1100)
      STOP
 1000 FORMAT('1Test of Y0(X) VS Multiplication Theorem'  //)
 1010 FORMAT(I7,' random arguments were tested from the interval ',
     1 1H(,F5.1,1H,,F5.1,1H)//)
 1011 FORMAT(' ABS(Y0(X)) was larger',I6,' times', /
     1   15X,' agreed',I6,' times, and'/
     1   11X,'was smaller',I6,' times.'//)
 1020 FORMAT(' There are',I4,' base',I4,
     1    ' significant digits in a floating-point number.' //)
 1021 FORMAT(' The maximum relative error of',E15.4,3H = ,I4,3H **,
     1  F7.2/4X,'occurred for X =',E13.6)
 1022 FORMAT(' The estimated loss of base',I4,
     1  ' significant digits is',F7.2//)
 1023 FORMAT(' The root mean square relative error was',E15.4,
     1    3H = ,I4,3H **,F7.2)
 1024 FORMAT(' The maximum absolute error of',E15.4,3H = ,I4,3H **,
     1  F7.2/4X,'occurred for X =',E13.6)
 1025 FORMAT(' The root mean square absolute error was',E15.4,
     1    3H = ,I4,3H **,F7.2)
 1030 FORMAT('1Special Tests'//)
 1031 FORMAT(' Accuracy near zeros'//10X,'X',15X,'BESY0(X)',
     1    13X,'Loss of base',I3,' digits'/)
 1032 FORMAT(E20.10,E25.15,8X,F7.2/)
 1033 FORMAT(//' Test with extreme arguments'/)
 1034 FORMAT(' Y0 will be called with the argument ',E17.10/
     1     ' This may stop execution.'//)
 1035 FORMAT(' Y0 will be called with the argument ',E17.10/
     1     ' This should not stop execution.'//)
 1036 FORMAT(' Y0 returned the value',E25.17/)
 1100 FORMAT(' This concludes the tests.')
C---------- Last card of BESY0 test program ----------
      END
      PROGRAM Y1TEST
C--------------------------------------------------------------------
C  Fortran 77 program to test BESY1
C
C  Data required
C
C     None
C
C  Subprograms required from this package
C
C     MACHAR - an environmental inquiry program providing
C              information on the floating-point arithmetic
C              system.  Note that the call to MACHAR can
C              be deleted provided the following six
C              parameters are assigned the values indicated
C
C                 IBETA  - the radix of the floating-point system
C                 IT     - the number of base-IBETA digits in the
C                          significand of a floating-point number
C                 MAXEXP - the smallest integer such that 
C                          FLOAT(IBETA)**MAXEXP causes overflow
C                 EPS    - the smallest positive floating-point
C                          number such that 1.0+EPS .NE. 1.0
C                 XMIN   - the smallest positive normalized
C                          floating-point power of the radix
C                 XMAX   - the largest finite floating-point
C                          number
C
C     REN(K) - a function subprogram returning random real
C              numbers uniformly distributed over (0,1)
C
C
C  Intrinsic functions required are:
C
C         ABS, DBLE, FLOAT, LOG, MAX, SIGN, SQRT
C
C  Reference: "Performance evaluation of programs for certain
C              Bessel functions", W. J. Cody and L. Stoltz,
C              ACM Trans. on Math. Software, Vol. 15, 1989,
C              pp 41-48.
C
C  Latest modification: March 13, 1992
C
C  Authors: George Zazi, W. J. Cody
C           Mathematics and Computer Science Division
C           Argonne National Laboratory
C           Argonne, IL 60439
C
C--------------------------------------------------------------------
      LOGICAL SFLAG, TFLAG
      INTEGER I,IBETA,IEXP,II,IND,IOUT,IRND,IT,J,JT,K1,K2,K3,
     1        MACHEP,MAXEXP,MB,MBM1,MBP1,MINEXP,N,NDUM,NEGEP,NGRD
CS    REAL
CD    DOUBLE PRECISION
     1   A,AIT,ALBETA,ALL9,B,BESY0,BESY1,BETA,C,CONV,DEL,EIGHT,
     2   EPS,EPSNEG,FOUR,HALF,HUND,ONE,REN,R6,R7,SIXTEN,SUM,T,
     3   TWENTY,TWO56,T1,U,W,X,XI,XL,XLAM,XMAX,XMB,XMIN,X1,Y,YX,
     4   Z,ZERO,ZZ
      DIMENSION U(560),XI(2),YX(2)
C--------------------------------------------------------------------
C  Mathematical constants
C--------------------------------------------------------------------
      DATA IOUT/6/
CS    DATA ZERO,ONE,FOUR/0.0E0,1.0E0,4.0E0/,
CS   1   EIGHT,TWENTY,ALL9,TWO56/8.0E0,20.0E0,-999.0E0,256.0E0/,
CS   2   HALF,SIXTEN,XLAM,HUND/0.5E0,16.0E0,0.9375E0,100.0E0/
CD    DATA ZERO,ONE,FOUR/0.0D0,1.0D0,4.0E0/,
CD   1   EIGHT,TWENTY,ALL9,TWO56/8.0D0,20.0D0,-999.0D0,256.0D0/,
CD   2   HALF,SIXTEN,XLAM,HUND/0.5D0,16.0D0,0.9375D0,100.0D0/
C--------------------------------------------------------------------
C  Zeroes of Y1
C--------------------------------------------------------------------
CS    DATA XI/562.0E0,1390.0E0/
CS    DATA YX(1)/-9.5282 39309 77227 03132 E-4/
CS   1     YX(2)/-2.1981 83008 05980 02741 E-6/
CD    DATA XI/562.0D0,1390.0D0/
CD    DATA YX(1)/-9.5282 39309 77227 03132 D-4/,
CD   1     YX(2)/-2.1981 83008 05980 02741 D-6/
C--------------------------------------------------------------------
C  Statement functions for conversion between integer and float
C--------------------------------------------------------------------
CS    CONV(NDUM) = FLOAT(NDUM)
CD    CONV(NDUM) = DBLE(FLOAT(NDUM))
C--------------------------------------------------------------------
C  Determine machine parameters and set constants
C--------------------------------------------------------------------
      CALL MACHAR(IBETA,IT,IRND,NGRD,MACHEP,NEGEP,IEXP,MINEXP,
     1            MAXEXP,EPS,EPSNEG,XMIN,XMAX)
      BETA = CONV(IBETA)
      ALBETA = LOG(BETA)
      AIT = CONV(IT)
      JT = 0
      B = EPS
C--------------------------------------------------------------------
C  Random argument accuracy tests (based on the
C    multiplication theorem)
C--------------------------------------------------------------------
      DO 300 J = 1, 3
         SFLAG = (J .EQ. 1) .AND. (MAXEXP/IT .LE. 5)
         K1 = 0
         K2 = 0
         K3 = 0
         X1 = ZERO
         R6 = ZERO
         R7 = ZERO
         N = 2000
         A = B
         IF (J .EQ. 1) THEN
               B = FOUR
            ELSE IF (J .EQ. 2) THEN
               B = EIGHT
            ELSE
               B = TWENTY
               N = 500
         END IF
         DEL = (B - A) / CONV(N)
         XL = A
         DO 200 I = 1, N
            X = DEL * REN(JT) + XL
C--------------------------------------------------------------------
C  Carefully purify arguments and evaluate identities
C--------------------------------------------------------------------
            Y = X/XLAM
            W = SIXTEN * Y
            Y = (W + Y) - W
            X = Y * XLAM
            U(1) = BESY0(Y)
            U(2) = BESY1(Y)
            TFLAG = SFLAG .AND. (Y .LT. HALF)
            IF (TFLAG) THEN
               U(1) = U(1) * EPS
               U(2) = U(2) * EPS
            END IF
            MB = 1
            XMB = ONE
            Y = Y * HALF
            W = (ONE-XLAM)*(ONE+XLAM)
            C = W * Y
            T = ABS(XLAM*U(2))
            T1 = EPS/HUND
            DO 110 II = 3, 60
               U(II) = XMB/Y * U(II-1) - U(II-2)
               T1 = XMB * T1 / C
               XMB = XMB + ONE
               MB = MB + 1
               MBP1=MB + 1
               Z = ABS(U(II))
               IF (Z/T1 .LT. T) THEN
                     GO TO 120
                  ELSE IF (Y .LT. XMB) THEN
                     IF (Z .GT. XMAX*(Y/XMB)) THEN
                        A= X
                        XL=XL+DEL
                        GO TO  200
                     END IF
               END IF
               IF (T1 .GT. ONE/EPS) THEN
                  T = T * T1
                  T1 = ONE
               END IF
  110       CONTINUE
  120       SUM = U(MBP1)
            IND = MBP1
            MBM1 =MB-1
            DO 155 II = 1, MBM1
               IND = IND - 1
               XMB = XMB - ONE
               SUM = SUM * W * Y / XMB + U(IND)
  155       CONTINUE
            ZZ = SUM*XLAM
            IF (TFLAG) ZZ = ZZ / EPS
            Z = BESY1(X)
            Y = Z
            IF (ABS(U(2)) .GT. ABS(Y)) Y =  U(2)
C--------------------------------------------------------------------
C  Accumulate results
C--------------------------------------------------------------------
            W = (Z - ZZ) / Y
            IF (W .GT. ZERO) THEN
                  K1 = K1 + 1
               ELSE IF (W .LT. ZERO) THEN
                  K3 = K3 + 1
               ELSE
                  K2 = K2 + 1
            END IF
            W = ABS(W)
            IF (W .GT. R6) THEN
               R6 = W
               X1 = X
            END IF
            R7 = R7 + W * W
            XL = XL + DEL
  200    CONTINUE
C--------------------------------------------------------------------
C  Process and output statistics
C--------------------------------------------------------------------
         N = K1 + K2 + K3
         R7 = SQRT(R7/CONV(N))
         WRITE (IOUT,1000)
         WRITE (IOUT,1010) N,A,B
         WRITE (IOUT,1011) K1,K2,K3
         WRITE (IOUT,1020) IT,IBETA
         IF (R6 .NE. ZERO) THEN
               W = LOG(ABS(R6))/ALBETA
            ELSE
               W = ALL9
         END IF
         IF (J .EQ. 4) THEN
               WRITE (IOUT,1024) R6,IBETA,W,X1
            ELSE
               WRITE (IOUT,1021) R6,IBETA,W,X1
         END IF
         W = MAX(AIT+W,ZERO)
         WRITE (IOUT,1022) IBETA,W
         IF (R7 .NE. ZERO) THEN
               W = LOG(ABS(R7))/ALBETA
            ELSE
               W = ALL9
         END IF
         IF (J .EQ. 4) THEN
               WRITE (IOUT,1025) R7,IBETA,W
            ELSE
               WRITE (IOUT,1023) R7,IBETA,W
         END IF
         W = MAX(AIT+W,ZERO)
         WRITE (IOUT,1022) IBETA,W
  300 CONTINUE
C--------------------------------------------------------------------
C  Special tests
C--------------------------------------------------------------------
      WRITE (IOUT,1030)
      WRITE (IOUT,1031) IBETA
      DO 330 I = 1, 2  
         X = XI(I)/TWO56
         Y = BESY1(X)
         T = (Y-YX(I))/YX(I)
         IF (T .NE. ZERO) THEN
               W = LOG(ABS(T))/ALBETA
            ELSE
               W = ALL9
         END IF
         W = MAX(AIT+W,ZERO)
         WRITE (IOUT,1032) X,Y,W
  330 CONTINUE
C--------------------------------------------------------------------
C  Test of error returns
C--------------------------------------------------------------------
      WRITE (IOUT,1033)
      X = XMIN
      IF (XMIN*XMAX .LT. ONE) THEN
            WRITE (IOUT,1034) X
         ELSE
            WRITE (IOUT,1035) X
      END IF
      Y = BESY1(X)
      WRITE (IOUT,1036) Y
      X = -ONE
      WRITE (IOUT,1034) X
      Y = BESY1(X)
      WRITE (IOUT,1036) Y
      X = XMAX
      WRITE (IOUT,1034) X
      Y = BESY1(X)
      WRITE (IOUT,1036) Y
      WRITE (IOUT,1100)
      STOP
C--------------------------------------------------------------------
 1000 FORMAT('1Test of Y1(X) VS Multiplication Theorem'  //)
 1010 FORMAT(I7,' random arguments were tested from the interval ',
     1 1H(,F5.1,1H,,F5.1,1H)//)
 1011 FORMAT(' ABS(Y1(X)) was larger',I6,' times', /
     1     15X,' agreed',I6,' times, and'/
     1   11X,'was smaller',I6,' times.'//)
 1020 FORMAT(' There are',I4,' base',I4,
     1    ' significant digits in a floating-point number.' //)
 1021 FORMAT(' The maximum relative error of',E15.4,3H = ,I4,3H **,
     1  F7.2/4X,'occurred for X =',E13.6)
 1022 FORMAT(' The estimated loss of base',I4,
     1  ' significant digits is',F7.2//)
 1023 FORMAT(' The root mean square relative error was',E15.4,
     1    3H = ,I4,3H **,F7.2)
 1024 FORMAT(' The maximum absolute error of',E15.4,3H = ,I4,3H **,
     1  F7.2/4X,'occurred for X =',E13.6)
 1025 FORMAT(' The root mean square absolute error was',E15.4,
     1    3H = ,I4,3H **,F7.2)
 1030 FORMAT('1Special Tests'//)
 1031 FORMAT(' Accuracy near zeros'//10X,'X',15X,'BESY1(X)',
     1    13X,'Loss of base',I3,' digits'/)
 1032 FORMAT(E20.10,E25.15,8X,F7.2/)
 1033 FORMAT(//' Test with extreme arguments'///)
 1034 FORMAT(' Y1 will be called with the argument ',E17.10/
     1     ' This may stop execution.'//)
 1035 FORMAT(' Y1 will be called with the argument ',E17.10/
     1     ' This should not stop execution.'//)
 1036 FORMAT(' Y1 returned the value',E25.17/)
 1100 FORMAT(' This concludes the tests.')
C---------- Last card of BESY1 test program ----------
      END
