!
!  slatec_3j_f90.f90
!  slatec.git
!
!  This file contains an extract of the huge Slatec library that allows the user
!  to compute just the 3J and 6J Wigner Symbols (which are closely related to the
!  Clebsch-Gordan and Racah W-coefficients, respectively), the Airy functions and
!  the Bessel functions, both regular and spherical.
!
!  This is part the Fortran90 version of the SLATEC library, which was kindly
!  ported from the Fortran77 original by John Burkardt, which I thank. The F90
!  port can be found at http://people.sc.fsu.edu/~jburkardt/f_src/slatec/slatec.html,
!  while the original F77 version is hosted on Netlib:
!  http://www.netlib.org/slatec/index.html

subroutine DRC3JM (L1, L2, L3, M1, M2MIN, M2MAX, THRCOF, NDIM, &
     IER)
!
!! DRC3JM evaluates the 3j symbol g(M2) for all allowed values of M2.
!
!***PURPOSE  Evaluate the 3j symbol g(M2) = (L1 L2   L3  )
!                                           (M1 M2 -M1-M2)
!            for all allowed values of M2, the other parameters
!            being held fixed.
!
!***LIBRARY   SLATEC
!***CATEGORY  C19
!***TYPE      DOUBLE PRECISION (RC3JM-S, DRC3JM-D)
!***KEYWORDS  3J COEFFICIENTS, 3J SYMBOLS, CLEBSCH-GORDAN COEFFICIENTS,
!             RACAH COEFFICIENTS, VECTOR ADDITION COEFFICIENTS,
!             WIGNER COEFFICIENTS
!***AUTHOR  Gordon, R. G., Harvard University
!           Schulten, K., Max Planck Institute
!***DESCRIPTION
!
! *Usage:
!
!        DOUBLE PRECISION L1, L2, L3, M1, M2MIN, M2MAX, THRCOF(NDIM)
!        INTEGER NDIM, IER
!
!        call DRC3JM (L1, L2, L3, M1, M2MIN, M2MAX, THRCOF, NDIM, IER)
!
! *Arguments:
!
!     L1 :IN      Parameter in 3j symbol.
!
!     L2 :IN      Parameter in 3j symbol.
!
!     L3 :IN      Parameter in 3j symbol.
!
!     M1 :IN      Parameter in 3j symbol.
!
!     M2MIN :OUT  Smallest allowable M2 in 3j symbol.
!
!     M2MAX :OUT  Largest allowable M2 in 3j symbol.
!
!     THRCOF :OUT Set of 3j coefficients generated by evaluating the
!                 3j symbol for all allowed values of M2.  THRCOF(I)
!                 will contain g(M2MIN+I-1), I=1,2,...,M2MAX-M2MIN+1.
!
!     NDIM :IN    Declared length of THRCOF in calling program.
!
!     IER :OUT    Error flag.
!                 IER=0 No errors.
!                 IER=1 Either L1 < ABS(M1) or L1+ABS(M1) non-integer.
!                 IER=2 ABS(L1-L2) <= L3 <= L1+L2 not satisfied.
!                 IER=3 L1+L2+L3 not an integer.
!                 IER=4 M2MAX-M2MIN not an integer.
!                 IER=5 M2MAX less than M2MIN.
!                 IER=6 NDIM less than M2MAX-M2MIN+1.
!
! *Description:
!
!     Although conventionally the parameters of the vector addition
!  coefficients satisfy certain restrictions, such as being integers
!  or integers plus 1/2, the restrictions imposed on input to this
!  subroutine are somewhat weaker. See, for example, Section 27.9 of
!  Abramowitz and Stegun or Appendix C of Volume II of A. Messiah.
!  The restrictions imposed by this subroutine are
!       1. L1 >= ABS(M1) and L1+ABS(M1) must be an integer;
!       2. ABS(L1-L2) <= L3 <= L1+L2;
!       3. L1+L2+L3 must be an integer;
!       4. M2MAX-M2MIN must be an integer, where
!          M2MAX=MIN(L2,L3-M1) and M2MIN=MAX(-L2,-L3-M1).
!  If the conventional restrictions are satisfied, then these
!  restrictions are met.
!
!     The user should be cautious in using input parameters that do
!  not satisfy the conventional restrictions. For example, the
!  the subroutine produces values of
!       g(M2) = (0.751.50   1.75  )
!               (0.25  M2  -0.25-M2)
!  for M2=-1.5,-0.5,0.5,1.5 but none of the symmetry properties of the
!  3j symbol, set forth on page 1056 of Messiah, is satisfied.
!
!     The subroutine generates g(M2MIN), g(M2MIN+1), ..., g(M2MAX)
!  where M2MIN and M2MAX are defined above. The sequence g(M2) is
!  generated by a three-term recurrence algorithm with scaling to
!  control overflow. Both backward and forward recurrence are used to
!  maintain numerical stability. The two recurrence sequences are
!  matched at an interior point and are normalized from the unitary
!  property of 3j coefficients and Wigner's phase convention.
!
!    The algorithm is suited to applications in which large quantum
!  numbers arise, such as in molecular dynamics.
!
!***REFERENCES  1. Abramowitz, M., and Stegun, I. A., Eds., Handbook
!                  of Mathematical Functions with Formulas, Graphs
!                  and Mathematical Tables, NBS Applied Mathematics
!                  Series 55, June 1964 and subsequent printings.
!               2. Messiah, Albert., Quantum Mechanics, Volume II,
!                  North-Holland Publishing Company, 1963.
!               3. Schulten, Klaus and Gordon, Roy G., Exact recursive
!                  evaluation of 3j and 6j coefficients for quantum-
!                  mechanical coupling of angular momenta, J Math
!                  Phys, v 16, no. 10, October 1975, pp. 1961-1970.
!               4. Schulten, Klaus and Gordon, Roy G., Semiclassical
!                  approximations to 3j and 6j coefficients for
!                  quantum-mechanical coupling of angular momenta,
!                  J Math Phys, v 16, no. 10, October 1975,
!                  pp. 1971-1988.
!               5. Schulten, Klaus and Gordon, Roy G., Recursive
!                  evaluation of 3j and 6j coefficients, Computer
!                  Phys Comm, v 11, 1976, pp. 269-278.
!***ROUTINES CALLED  D1MACH, XERMSG
!***REVISION HISTORY  (YYMMDD)
!   750101  DATE WRITTEN
!   880515  SLATEC prologue added by G. C. Nielson, NBS; parameters
!           HUGE and TINY revised to depend on D1MACH.
!   891229  Prologue description rewritten; other prologue sections
!           revised; MMATCH (location of match point for recurrences)
!           removed from argument list; argument IER changed to serve
!           only as an error flag (previously, in cases without error,
!           it returned the number of scalings); number of error codes
!           increased to provide more precise error information;
!           program comments revised; SLATEC error handler calls
!           introduced to enable printing of error messages to meet
!           SLATEC standards. These changes were done by D. W. Lozier,
!           M. A. McClain and J. M. Smith of the National Institute
!           of Standards and Technology, formerly NBS.
!   910415  Mixed type expressions eliminated; variable C1 initialized;
!           description of THRCOF expanded. These changes were done by
!           D. W. Lozier.
!***END PROLOGUE  DRC3JM
!
  INTEGER NDIM, IER
  DOUBLE PRECISION L1, L2, L3, M1, M2MIN, M2MAX, THRCOF(NDIM)
!
  INTEGER I, INDEX, LSTEP, N, NFIN, NFINP1, NFINP2, NFINP3, NLIM, &
          NSTEP2
  DOUBLE PRECISION A1, A1S, C1, C1OLD, C2, CNORM, D1MACH, DV, EPS, &
                   HUGE, M2, M3, NEWFAC, OLDFAC, ONE, RATIO, SIGN1, &
                   SIGN2, SRHUGE, SRTINY, SUM1, SUM2, SUMBAC, &
                   SUMFOR, SUMUNI, THRESH, TINY, TWO, X, X1, X2, X3, &
                   Y, Y1, Y2, Y3, ZERO
!
  DATA  ZERO,EPS,ONE,TWO /0.0D0,0.01D0,1.0D0,2.0D0/

	!! Debug
	! print*, "PARAMETERS FOR FUNCTION DRC3JM"
	! print*, "L1", L1
	! print*, "L2", L2
	! print*, "L3", L3
	! print*, "M1", M1
	! print*, "NDIM", NDIM

!***FIRST EXECUTABLE STATEMENT  DRC3JM
  IER=0
!  HUGE is the square root of one twentieth of the largest floating
!  point number, approximately.
  HUGE = SQRT(D1MACH(2)/20.0D0)
  SRHUGE = SQRT(HUGE)
  TINY = 1.0D0/HUGE
  SRTINY = 1.0D0/SRHUGE
!
!
!  Limits for M2
  M2MIN = MAX(-L2,-L3-M1)
  M2MAX = MIN(L2,L3-M1)
	!! Debug
	! print*, "M2MIN", M2MIN
	! print*, "M2MAX", M2MAX
!
!
!
!  Check error conditions 1, 2, and 3.
  if ( (L1-ABS(M1)+EPS < ZERO).OR. &
     (MOD(L1+ABS(M1)+EPS,ONE) >= EPS+EPS))THEN
     IER=1
	 print*, "Exited with ier = ", IER
     ! call XERMSG('SLATEC','DRC3JM','L1-ABS(M1) less than zero or '// &
     !    'L1+ABS(M1) not integer.',IER,1)
     return
  ELSEIF((L1+L2-L3 < -EPS).OR.(L1-L2+L3 < -EPS).OR. &
     (-L1+L2+L3 < -EPS))THEN
     IER=2
	 print*, "Exited with ier = ", IER
     ! call XERMSG('SLATEC','DRC3JM','L1, L2, L3 do not satisfy '// &
     !    'triangular condition.',IER,1)
     return
  ELSEIF(MOD(L1+L2+L3+EPS,ONE) >= EPS+EPS)THEN
     IER=3
	 print*, "Exited with ier = ", IER
     ! call XERMSG('SLATEC','DRC3JM','L1+L2+L3 not integer.',IER,1)
     return
  end if

!  Check error condition 4.
  if ( MOD(M2MAX-M2MIN+EPS,ONE) >= EPS+EPS)THEN
     IER=4
	 print*, "Exited with ier = ", IER
     ! call XERMSG('SLATEC','DRC3JM','M2MAX-M2MIN not integer.',IER,1)
     return
  end if
  if ( M2MIN < M2MAX-EPS)   go to 20
  if ( M2MIN < M2MAX+EPS)   go to 10
!
!  Check error condition 5.
  IER=5
  print*, "Exited with ier = ", IER
  ! call XERMSG('SLATEC','DRC3JM','M2MIN greater than M2MAX.',IER,1)
  return
!
!
!  This is reached in case that M2 and M3 can take only one value.
   10 CONTINUE
!     MSCALE = 0
  THRCOF(1) = (-ONE) ** INT(ABS(L2-L3-M1)+EPS) / &
   SQRT(L1+L2+L3+ONE)
  return
!
!  This is reached in case that M1 and M2 take more than one value.
   20 CONTINUE
!     MSCALE = 0
  NFIN = INT(M2MAX-M2MIN+ONE+EPS)
	! print*, "NDIM =", NDIM, "NFIN = ", NFIN
	! print*, "M2MAX = ", M2MAX, "M2MIN = ", M2MIN, "ONE = ", ONE, "EPS = ", EPS, "M2MAX-M2MIN+ONE+EPS", M2MAX-M2MIN+ONE+EPS
  if ( NDIM-NFIN)   21, 23, 23
!
!  Check error condition 6.
   21 IER = 6
   print*, "Exited with ier = ", IER
  ! call XERMSG('SLATEC','DRC3JM','Dimension of result array for '// &
  !             '3j coefficients too small.',IER,1)
  return
!
!
!
!  Start of forward recursion from M2 = M2MIN
!
   23 M2 = M2MIN
  THRCOF(1) = SRTINY
  NEWFAC = 0.0D0
  C1 = 0.0D0
  SUM1 = TINY
!
!
  LSTEP = 1
   30 LSTEP = LSTEP + 1
  M2 = M2 + ONE
  M3 = - M1 - M2
!
!
  OLDFAC = NEWFAC
  A1 = (L2-M2+ONE) * (L2+M2) * (L3+M3+ONE) * (L3-M3)
  NEWFAC = SQRT(A1)
!
!
  DV = (L1+L2+L3+ONE)*(L2+L3-L1) - (L2-M2+ONE)*(L3+M3+ONE) &
                                 - (L2+M2-ONE)*(L3-M3-ONE)
!
  if ( LSTEP-2)  32, 32, 31
!
   31 C1OLD = ABS(C1)
   32 C1 = - DV / NEWFAC
!
  if ( LSTEP > 2)   go to 60
!
!
!  If M2 = M2MIN + 1, the third term in the recursion equation vanishes,
!  hence
!
  X = SRTINY * C1
  THRCOF(2) = X
  SUM1 = SUM1 + TINY * C1*C1
  if ( LSTEP == NFIN)   go to 220
  go to 30
!
!
   60 C2 = - OLDFAC / NEWFAC
!
!  Recursion to the next 3j coefficient
  X = C1 * THRCOF(LSTEP-1) + C2 * THRCOF(LSTEP-2)
  THRCOF(LSTEP) = X
  SUMFOR = SUM1
  SUM1 = SUM1 + X*X
  if ( LSTEP == NFIN)   go to 100
!
!  See if last unnormalized 3j coefficient exceeds SRHUGE
!
  if ( ABS(X) < SRHUGE)   go to 80
!
!  This is reached if last 3j coefficient larger than SRHUGE,
!  so that the recursion series THRCOF(1), ... , THRCOF(LSTEP)
!  has to be rescaled to prevent overflow
!
!     MSCALE = MSCALE + 1
  DO 70 I=1,LSTEP
  if ( ABS(THRCOF(I)) < SRTINY)   THRCOF(I) = ZERO
   70 THRCOF(I) = THRCOF(I) / SRHUGE
  SUM1 = SUM1 / HUGE
  SUMFOR = SUMFOR / HUGE
  X = X / SRHUGE
!
!
!  As long as ABS(C1) is decreasing, the recursion proceeds towards
!  increasing 3j values and, hence, is numerically stable.  Once
!  an increase of ABS(C1) is detected, the recursion direction is
!  reversed.
!
   80 if ( C1OLD-ABS(C1))   100, 100, 30
!
!
!  Keep three 3j coefficients around MMATCH for comparison later
!  with backward recursion values.
!
  100 CONTINUE
!     MMATCH = M2 - 1
  NSTEP2 = NFIN - LSTEP + 3
  X1 = X
  X2 = THRCOF(LSTEP-1)
  X3 = THRCOF(LSTEP-2)
!
!  Starting backward recursion from M2MAX taking NSTEP2 steps, so
!  that forwards and backwards recursion overlap at the three points
!  M2 = MMATCH+1, MMATCH, MMATCH-1.
!
  NFINP1 = NFIN + 1
  NFINP2 = NFIN + 2
  NFINP3 = NFIN + 3
  THRCOF(NFIN) = SRTINY
  SUM2 = TINY
!
!
!
  M2 = M2MAX + TWO
  LSTEP = 1
  110 LSTEP = LSTEP + 1
  M2 = M2 - ONE
  M3 = - M1 - M2
  OLDFAC = NEWFAC
  A1S = (L2-M2+TWO) * (L2+M2-ONE) * (L3+M3+TWO) * (L3-M3-ONE)
  NEWFAC = SQRT(A1S)
  DV = (L1+L2+L3+ONE)*(L2+L3-L1) - (L2-M2+ONE)*(L3+M3+ONE) &
                                 - (L2+M2-ONE)*(L3-M3-ONE)
  C1 = - DV / NEWFAC
  if ( LSTEP > 2)   go to 120
!
!  If M2 = M2MAX + 1 the third term in the recursion equation vanishes
!
  Y = SRTINY * C1
  THRCOF(NFIN-1) = Y
  if ( LSTEP == NSTEP2)   go to 200
  SUMBAC = SUM2
  SUM2 = SUM2 + Y*Y
  go to 110
!
  120 C2 = - OLDFAC / NEWFAC
!
!  Recursion to the next 3j coefficient
!
  Y = C1 * THRCOF(NFINP2-LSTEP) + C2 * THRCOF(NFINP3-LSTEP)
!
  if ( LSTEP == NSTEP2)   go to 200
!
  THRCOF(NFINP1-LSTEP) = Y
  SUMBAC = SUM2
  SUM2 = SUM2 + Y*Y
!
!
!  See if last 3j coefficient exceeds SRHUGE
!
  if ( ABS(Y) < SRHUGE)   go to 110
!
!  This is reached if last 3j coefficient larger than SRHUGE,
!  so that the recursion series THRCOF(NFIN), ... , THRCOF(NFIN-LSTEP+1)
!  has to be rescaled to prevent overflow.
!
!     MSCALE = MSCALE + 1
  DO 111 I=1,LSTEP
  INDEX = NFIN - I + 1
  if ( ABS(THRCOF(INDEX)) < SRTINY) &
    THRCOF(INDEX) = ZERO
  111 THRCOF(INDEX) = THRCOF(INDEX) / SRHUGE
  SUM2 = SUM2 / HUGE
  SUMBAC = SUMBAC / HUGE
!
  go to 110
!
!
!
!  The forward recursion 3j coefficients X1, X2, X3 are to be matched
!  with the corresponding backward recursion values Y1, Y2, Y3.
!
  200 Y3 = Y
  Y2 = THRCOF(NFINP2-LSTEP)
  Y1 = THRCOF(NFINP3-LSTEP)
!
!
!  Determine now RATIO such that YI = RATIO * XI  (I=1,2,3) holds
!  with minimal error.
!
  RATIO = ( X1*Y1 + X2*Y2 + X3*Y3 ) / ( X1*X1 + X2*X2 + X3*X3 )
  NLIM = NFIN - NSTEP2 + 1
!
  if ( ABS(RATIO) < ONE)   go to 211
!
  DO 210 N=1,NLIM
  210 THRCOF(N) = RATIO * THRCOF(N)
  SUMUNI = RATIO * RATIO * SUMFOR + SUMBAC
  go to 230
!
  211 NLIM = NLIM + 1
  RATIO = ONE / RATIO
  DO 212 N=NLIM,NFIN
  212 THRCOF(N) = RATIO * THRCOF(N)
  SUMUNI = SUMFOR + RATIO*RATIO*SUMBAC
  go to 230
!
  220 SUMUNI = SUM1
!
!
!  Normalize 3j coefficients
!
  230 CNORM = ONE / SQRT((L1+L1+ONE) * SUMUNI)
!
!  Sign convention for last 3j coefficient determines overall phase
!
  SIGN1 = SIGN(ONE,THRCOF(NFIN))
  SIGN2 = (-ONE) ** INT(ABS(L2-L3-M1)+EPS)
  if ( SIGN1*SIGN2)  235,235,236
  235 CNORM = - CNORM
!
  236 if ( ABS(CNORM) < ONE)   go to 250
!
  DO 240 N=1,NFIN
  240 THRCOF(N) = CNORM * THRCOF(N)
  return
!
  250 THRESH = TINY / ABS(CNORM)
  DO 251 N=1,NFIN
  if ( ABS(THRCOF(N)) < THRESH)   THRCOF(N) = ZERO
  251 THRCOF(N) = CNORM * THRCOF(N)
!
!
!
  return
end

subroutine DRC3JJ (L2, L3, M2, M3, L1MIN, L1MAX, THRCOF, NDIM, &
     IER)
!
!! DRC3JJ evaluates the 3J symbol f(L1) for all allowed values of L1.
!
!***PURPOSE  Evaluate the 3j symbol f(L1) = (  L1   L2 L3)
!                                           (-M2-M3 M2 M3)
!            for all allowed values of L1, the other parameters
!            being held fixed.
!
!***LIBRARY   SLATEC
!***CATEGORY  C19
!***TYPE      DOUBLE PRECISION (RC3JJ-S, DRC3JJ-D)
!***KEYWORDS  3J COEFFICIENTS, 3J SYMBOLS, CLEBSCH-GORDAN COEFFICIENTS,
!             RACAH COEFFICIENTS, VECTOR ADDITION COEFFICIENTS,
!             WIGNER COEFFICIENTS
!***AUTHOR  Gordon, R. G., Harvard University
!           Schulten, K., Max Planck Institute
!***DESCRIPTION
!
! *Usage:
!
!        DOUBLE PRECISION L2, L3, M2, M3, L1MIN, L1MAX, THRCOF(NDIM)
!        INTEGER NDIM, IER
!
!        call DRC3JJ (L2, L3, M2, M3, L1MIN, L1MAX, THRCOF, NDIM, IER)
!
! *Arguments:
!
!     L2 :IN      Parameter in 3j symbol.
!
!     L3 :IN      Parameter in 3j symbol.
!
!     M2 :IN      Parameter in 3j symbol.
!
!     M3 :IN      Parameter in 3j symbol.
!
!     L1MIN :OUT  Smallest allowable L1 in 3j symbol.
!
!     L1MAX :OUT  Largest allowable L1 in 3j symbol.
!
!     THRCOF :OUT Set of 3j coefficients generated by evaluating the
!                 3j symbol for all allowed values of L1.  THRCOF(I)
!                 will contain f(L1MIN+I-1), I=1,2,...,L1MAX+L1MIN+1.
!
!     NDIM :IN    Declared length of THRCOF in calling program.
!
!     IER :OUT    Error flag.
!                 IER=0 No errors.
!                 IER=1 Either L2 < ABS(M2) or L3 < ABS(M3).
!                 IER=2 Either L2+ABS(M2) or L3+ABS(M3) non-integer.
!                 IER=3 L1MAX-L1MIN not an integer.
!                 IER=4 L1MAX less than L1MIN.
!                 IER=5 NDIM less than L1MAX-L1MIN+1.
!
! *Description:
!
!     Although conventionally the parameters of the vector addition
!  coefficients satisfy certain restrictions, such as being integers
!  or integers plus 1/2, the restrictions imposed on input to this
!  subroutine are somewhat weaker. See, for example, Section 27.9 of
!  Abramowitz and Stegun or Appendix C of Volume II of A. Messiah.
!  The restrictions imposed by this subroutine are
!       1. L2  >=  ABS(M2) and L3  >=  ABS(M3);
!       2. L2+ABS(M2) and L3+ABS(M3) must be integers;
!       3. L1MAX-L1MIN must be a non-negative integer, where
!          L1MAX=L2+L3 and L1MIN=MAX(ABS(L2-L3),ABS(M2+M3)).
!  If the conventional restrictions are satisfied, then these
!  restrictions are met.
!
!     The user should be cautious in using input parameters that do
!  not satisfy the conventional restrictions. For example, the
!  the subroutine produces values of
!       f(L1) = ( L1  2.5  5.8)
!               (-0.31.5 -1.2)
!  for L1=3.3,4.3,...,8.3 but none of the symmetry properties of the 3j
!  symbol, set forth on page 1056 of Messiah, is satisfied.
!
!     The subroutine generates f(L1MIN), f(L1MIN+1), ..., f(L1MAX)
!  where L1MIN and L1MAX are defined above. The sequence f(L1) is
!  generated by a three-term recurrence algorithm with scaling to
!  control overflow. Both backward and forward recurrence are used to
!  maintain numerical stability. The two recurrence sequences are
!  matched at an interior point and are normalized from the unitary
!  property of 3j coefficients and Wigner's phase convention.
!
!    The algorithm is suited to applications in which large quantum
!  numbers arise, such as in molecular dynamics.
!
!***REFERENCES  1. Abramowitz, M., and Stegun, I. A., Eds., Handbook
!                  of Mathematical Functions with Formulas, Graphs
!                  and Mathematical Tables, NBS Applied Mathematics
!                  Series 55, June 1964 and subsequent printings.
!               2. Messiah, Albert., Quantum Mechanics, Volume II,
!                  North-Holland Publishing Company, 1963.
!               3. Schulten, Klaus and Gordon, Roy G., Exact recursive
!                  evaluation of 3j and 6j coefficients for quantum-
!                  mechanical coupling of angular momenta, J Math
!                  Phys, v 16, no. 10, October 1975, pp. 1961-1970.
!               4. Schulten, Klaus and Gordon, Roy G., Semiclassical
!                  approximations to 3j  and 6j coefficients for
!                  quantum-mechanical coupling of angular momenta,
!                  J Math Phys, v 16, no. 10, October 1975,
!                  pp. 1971-1988.
!               5. Schulten, Klaus and Gordon, Roy G., Recursive
!                  evaluation of 3j and 6j coefficients, Computer
!                  Phys Comm, v 11, 1976, pp. 269-278.
!***ROUTINES CALLED  D1MACH, XERMSG
!***REVISION HISTORY  (YYMMDD)
!   750101  DATE WRITTEN
!   880515  SLATEC prologue added by G. C. Nielson, NBS; parameters
!           HUGE and TINY revised to depend on D1MACH.
!   891229  Prologue description rewritten; other prologue sections
!           revised; LMATCH (location of match point for recurrences)
!           removed from argument list; argument IER changed to serve
!           only as an error flag (previously, in cases without error,
!           it returned the number of scalings); number of error codes
!           increased to provide more precise error information;
!           program comments revised; SLATEC error handler calls
!           introduced to enable printing of error messages to meet
!           SLATEC standards. These changes were done by D. W. Lozier,
!           M. A. McClain and J. M. Smith of the National Institute
!           of Standards and Technology, formerly NBS.
!   910415  Mixed type expressions eliminated; variable C1 initialized;
!           description of THRCOF expanded. These changes were done by
!           D. W. Lozier.
!***END PROLOGUE  DRC3JJ
!
  INTEGER NDIM, IER
  DOUBLE PRECISION L2, L3, M2, M3, L1MIN, L1MAX, THRCOF(NDIM)
!
  INTEGER I, INDEX, LSTEP, N, NFIN, NFINP1, NFINP2, NFINP3, NLIM, &
          NSTEP2
  DOUBLE PRECISION A1, A1S, A2, A2S, C1, C1OLD, C2, CNORM, D1MACH, &
                   DENOM, DV, EPS, HUGE, L1, M1, NEWFAC, OLDFAC, &
                   ONE, RATIO, SIGN1, SIGN2, SRHUGE, SRTINY, SUM1, &
                   SUM2, SUMBAC, SUMFOR, SUMUNI, THREE, THRESH, &
                   TINY, TWO, X, X1, X2, X3, Y, Y1, Y2, Y3, ZERO
!
  DATA  ZERO,EPS,ONE,TWO,THREE /0.0D0,0.01D0,1.0D0,2.0D0,3.0D0/
!
!***FIRST EXECUTABLE STATEMENT  DRC3JJ
  IER=0
!  HUGE is the square root of one twentieth of the largest floating
!  point number, approximately.
  HUGE = SQRT(D1MACH(2)/20.0D0)
  SRHUGE = SQRT(HUGE)
  TINY = 1.0D0/HUGE
  SRTINY = 1.0D0/SRHUGE
!
!     LMATCH = ZERO
  M1 = - M2 - M3
!
!  Check error conditions 1 and 2.
  if ( (L2-ABS(M2)+EPS < ZERO).OR. &
     (L3-ABS(M3)+EPS < ZERO))THEN
     IER=1
	 print*, "Exited with ier = ", IER
     ! call XERMSG('SLATEC','DRC3JJ','L2-ABS(M2) or L3-ABS(M3) '// &
     !    'less than zero.',IER,1)
     return
  ELSEIF((MOD(L2+ABS(M2)+EPS,ONE) >= EPS+EPS).OR. &
     (MOD(L3+ABS(M3)+EPS,ONE) >= EPS+EPS))THEN
     IER=2
	 print*, "Exited with ier = ", IER
     ! call XERMSG('SLATEC','DRC3JJ','L2+ABS(M2) or L3+ABS(M3) '// &
     !    'not integer.',IER,1)
     return
  end if
!
!
!
!  Limits for L1
!
  L1MIN = MAX(ABS(L2-L3),ABS(M1))
  L1MAX = L2 + L3
!
!  Check error condition 3.
  if ( MOD(L1MAX-L1MIN+EPS,ONE) >= EPS+EPS)THEN
     IER=3
	 print*, "Exited with ier = ", IER
     ! call XERMSG('SLATEC','DRC3JJ','L1MAX-L1MIN not integer.',IER,1)
     ! return
  end if
  if ( L1MIN < L1MAX-EPS)   go to 20
  if ( L1MIN < L1MAX+EPS)   go to 10
!
!  Check error condition 4.
  IER=4
  print*, "Exited with ier = ", IER
  ! call XERMSG('SLATEC','DRC3JJ','L1MIN greater than L1MAX.',IER,1)
  return
!
!  This is reached in case that L1 can take only one value,
!  i.e. L1MIN = L1MAX
!
   10 CONTINUE
!     LSCALE = 0
  THRCOF(1) = (-ONE) ** INT(ABS(L2+M2-L3+M3)+EPS) / &
   SQRT(L1MIN + L2 + L3 + ONE)
  return
!
!  This is reached in case that L1 takes more than one value,
!  i.e. L1MIN < L1MAX.
!
   20 CONTINUE
!     LSCALE = 0
  NFIN = INT(L1MAX-L1MIN+ONE+EPS)
  if ( NDIM-NFIN)  21, 23, 23
!
!  Check error condition 5.
   21 IER = 5
   print*, "Exited with ier = ", IER
  ! call XERMSG('SLATEC','DRC3JJ','Dimension of result array for '// &
  !             '3j coefficients too small.',IER,1)
  return
!
!
!  Starting forward recursion from L1MIN taking NSTEP1 steps
!
   23 L1 = L1MIN
  NEWFAC = 0.0D0
  C1 = 0.0D0
  THRCOF(1) = SRTINY
  SUM1 = (L1+L1+ONE) * TINY
!
!
  LSTEP = 1
   30 LSTEP = LSTEP + 1
  L1 = L1 + ONE
!
!
  OLDFAC = NEWFAC
  A1 = (L1+L2+L3+ONE) * (L1-L2+L3) * (L1+L2-L3) * (-L1+L2+L3+ONE)
  A2 = (L1+M1) * (L1-M1)
  NEWFAC = SQRT(A1*A2)
  if ( L1 < ONE+EPS)   go to 40
!
!
  DV = - L2*(L2+ONE) * M1 + L3*(L3+ONE) * M1 + L1*(L1-ONE) * (M3-M2)
  DENOM = (L1-ONE) * NEWFAC
!
  if ( LSTEP-2)  32, 32, 31
!
   31 C1OLD = ABS(C1)
   32 C1 = - (L1+L1-ONE) * DV / DENOM
  go to 50
!
!  If L1 = 1, (L1-1) has to be factored out of DV, hence
!
   40 C1 = - (L1+L1-ONE) * L1 * (M3-M2) / NEWFAC
!
   50 if ( LSTEP > 2)   go to 60
!
!
!  If L1 = L1MIN + 1, the third term in the recursion equation vanishes,
!  hence
  X = SRTINY * C1
  THRCOF(2) = X
  SUM1 = SUM1 + TINY * (L1+L1+ONE) * C1*C1
  if ( LSTEP == NFIN)   go to 220
  go to 30
!
!
   60 C2 = - L1 * OLDFAC / DENOM
!
!  Recursion to the next 3j coefficient X
!
  X = C1 * THRCOF(LSTEP-1) + C2 * THRCOF(LSTEP-2)
  THRCOF(LSTEP) = X
  SUMFOR = SUM1
  SUM1 = SUM1 + (L1+L1+ONE) * X*X
  if ( LSTEP == NFIN)   go to 100
!
!  See if last unnormalized 3j coefficient exceeds SRHUGE
!
  if ( ABS(X) < SRHUGE)   go to 80
!
!  This is reached if last 3j coefficient larger than SRHUGE,
!  so that the recursion series THRCOF(1), ... , THRCOF(LSTEP)
!  has to be rescaled to prevent overflow
!
!     LSCALE = LSCALE + 1
  DO 70 I=1,LSTEP
  if ( ABS(THRCOF(I)) < SRTINY)   THRCOF(I) = ZERO
   70 THRCOF(I) = THRCOF(I) / SRHUGE
  SUM1 = SUM1 / HUGE
  SUMFOR = SUMFOR / HUGE
  X = X / SRHUGE
!
!  As long as ABS(C1) is decreasing, the recursion proceeds towards
!  increasing 3j values and, hence, is numerically stable.  Once
!  an increase of ABS(C1) is detected, the recursion direction is
!  reversed.
!
   80 if ( C1OLD-ABS(C1))   100, 100, 30
!
!
!  Keep three 3j coefficients around LMATCH for comparison with
!  backward recursion.
!
  100 CONTINUE
!     LMATCH = L1 - 1
  X1 = X
  X2 = THRCOF(LSTEP-1)
  X3 = THRCOF(LSTEP-2)
  NSTEP2 = NFIN - LSTEP + 3
!
!
!
!
!  Starting backward recursion from L1MAX taking NSTEP2 steps, so
!  that forward and backward recursion overlap at three points
!  L1 = LMATCH+1, LMATCH, LMATCH-1.
!
  NFINP1 = NFIN + 1
  NFINP2 = NFIN + 2
  NFINP3 = NFIN + 3
  L1 = L1MAX
  THRCOF(NFIN) = SRTINY
  SUM2 = TINY * (L1+L1+ONE)
!
  L1 = L1 + TWO
  LSTEP = 1
  110 LSTEP = LSTEP + 1
  L1 = L1 - ONE
!
  OLDFAC = NEWFAC
  A1S = (L1+L2+L3)*(L1-L2+L3-ONE)*(L1+L2-L3-ONE)*(-L1+L2+L3+TWO)
  A2S = (L1+M1-ONE) * (L1-M1-ONE)
  NEWFAC = SQRT(A1S*A2S)
!
  DV = - L2*(L2+ONE) * M1 + L3*(L3+ONE) * M1 + L1*(L1-ONE) * (M3-M2)
!
  DENOM = L1 * NEWFAC
  C1 = - (L1+L1-ONE) * DV / DENOM
  if ( LSTEP > 2)   go to 120
!
!  If L1 = L1MAX + 1, the third term in the recursion formula vanishes
!
  Y = SRTINY * C1
  THRCOF(NFIN-1) = Y
  SUMBAC = SUM2
  SUM2 = SUM2 + TINY * (L1+L1-THREE) * C1*C1
!
  go to 110
!
!
  120 C2 = - (L1 - ONE) * OLDFAC / DENOM
!
!  Recursion to the next 3j coefficient Y
!
  Y = C1 * THRCOF(NFINP2-LSTEP) + C2 * THRCOF(NFINP3-LSTEP)
!
  if ( LSTEP == NSTEP2)   go to 200
!
  THRCOF(NFINP1-LSTEP) = Y
  SUMBAC = SUM2
  SUM2 = SUM2 + (L1+L1-THREE) * Y*Y
!
!  See if last unnormalized 3j coefficient exceeds SRHUGE
!
  if ( ABS(Y) < SRHUGE)   go to 110
!
!  This is reached if last 3j coefficient larger than SRHUGE,
!  so that the recursion series THRCOF(NFIN), ... ,THRCOF(NFIN-LSTEP+1)
!  has to be rescaled to prevent overflow
!
!     LSCALE = LSCALE + 1
  DO 130 I=1,LSTEP
  INDEX = NFIN - I + 1
  if ( ABS(THRCOF(INDEX)) < SRTINY)   THRCOF(INDEX) = ZERO
  130 THRCOF(INDEX) = THRCOF(INDEX) / SRHUGE
  SUM2 = SUM2 / HUGE
  SUMBAC = SUMBAC / HUGE
!
!
  go to 110
!
!
!  The forward recursion 3j coefficients X1, X2, X3 are to be matched
!  with the corresponding backward recursion values Y1, Y2, Y3.
!
  200 Y3 = Y
  Y2 = THRCOF(NFINP2-LSTEP)
  Y1 = THRCOF(NFINP3-LSTEP)
!
!
!  Determine now RATIO such that YI = RATIO * XI  (I=1,2,3) holds
!  with minimal error.
!
  RATIO = ( X1*Y1 + X2*Y2 + X3*Y3 ) / ( X1*X1 + X2*X2 + X3*X3 )
  NLIM = NFIN - NSTEP2 + 1
!
  if ( ABS(RATIO) < ONE)   go to 211
!
  DO 210 N=1,NLIM
  210 THRCOF(N) = RATIO * THRCOF(N)
  SUMUNI = RATIO * RATIO * SUMFOR + SUMBAC
  go to 230
!
  211 NLIM = NLIM + 1
  RATIO = ONE / RATIO
  DO 212 N=NLIM,NFIN
  212 THRCOF(N) = RATIO * THRCOF(N)
  SUMUNI = SUMFOR + RATIO*RATIO*SUMBAC
  go to 230
!
  220 SUMUNI = SUM1
!
!
!  Normalize 3j coefficients
!
  230 CNORM = ONE / SQRT(SUMUNI)
!
!  Sign convention for last 3j coefficient determines overall phase
!
  SIGN1 = SIGN(ONE,THRCOF(NFIN))
  SIGN2 = (-ONE) ** INT(ABS(L2+M2-L3+M3)+EPS)
  if ( SIGN1*SIGN2) 235,235,236
  235 CNORM = - CNORM
!
  236 if ( ABS(CNORM) < ONE)   go to 250
!
  DO 240 N=1,NFIN
  240 THRCOF(N) = CNORM * THRCOF(N)
  return
!
  250 THRESH = TINY / ABS(CNORM)
  DO 251 N=1,NFIN
  if ( ABS(THRCOF(N)) < THRESH)   THRCOF(N) = ZERO
  251 THRCOF(N) = CNORM * THRCOF(N)
!
  return
end

subroutine DRC6J (L2, L3, L4, L5, L6, L1MIN, L1MAX, SIXCOF, NDIM, &
     IER)
!
!! DRC6J evaluates the 6j symbol h(L1) for all allowed values of L1.
!
!***PURPOSE  Evaluate the 6j symbol h(L1) = {L1 L2 L3}
!                                           {L4 L5 L6}
!            for all allowed values of L1, the other parameters
!            being held fixed.
!
!***LIBRARY   SLATEC
!***CATEGORY  C19
!***TYPE      DOUBLE PRECISION (RC6J-S, DRC6J-D)
!***KEYWORDS  6J COEFFICIENTS, 6J SYMBOLS, CLEBSCH-GORDAN COEFFICIENTS,
!             RACAH COEFFICIENTS, VECTOR ADDITION COEFFICIENTS,
!             WIGNER COEFFICIENTS
!***AUTHOR  Gordon, R. G., Harvard University
!           Schulten, K., Max Planck Institute
!***DESCRIPTION
!
! *Usage:
!
!        DOUBLE PRECISION L2, L3, L4, L5, L6, L1MIN, L1MAX, SIXCOF(NDIM)
!        INTEGER NDIM, IER
!
!        call DRC6J(L2, L3, L4, L5, L6, L1MIN, L1MAX, SIXCOF, NDIM, IER)
!
! *Arguments:
!
!     L2 :IN      Parameter in 6j symbol.
!
!     L3 :IN      Parameter in 6j symbol.
!
!     L4 :IN      Parameter in 6j symbol.
!
!     L5 :IN      Parameter in 6j symbol.
!
!     L6 :IN      Parameter in 6j symbol.
!
!     L1MIN :OUT  Smallest allowable L1 in 6j symbol.
!
!     L1MAX :OUT  Largest allowable L1 in 6j symbol.
!
!     SIXCOF :OUT Set of 6j coefficients generated by evaluating the
!                 6j symbol for all allowed values of L1.  SIXCOF(I)
!                 will contain h(L1MIN+I-1), I=1,2,...,L1MAX-L1MIN+1.
!
!     NDIM :IN    Declared length of SIXCOF in calling program.
!
!     IER :OUT    Error flag.
!                 IER=0 No errors.
!                 IER=1 L2+L3+L5+L6 or L4+L2+L6 not an integer.
!                 IER=2 L4, L2, L6 triangular condition not satisfied.
!                 IER=3 L4, L5, L3 triangular condition not satisfied.
!                 IER=4 L1MAX-L1MIN not an integer.
!                 IER=5 L1MAX less than L1MIN.
!                 IER=6 NDIM less than L1MAX-L1MIN+1.
!
! *Description:
!
!     The definition and properties of 6j symbols can be found, for
!  example, in Appendix C of Volume II of A. Messiah. Although the
!  parameters of the vector addition coefficients satisfy certain
!  conventional restrictions, the restriction that they be non-negative
!  integers or non-negative integers plus 1/2 is not imposed on input
!  to this subroutine. The restrictions imposed are
!       1. L2+L3+L5+L6 and L2+L4+L6 must be integers;
!       2. ABS(L2-L4) <= L6 <= L2+L4 must be satisfied;
!       3. ABS(L4-L5) <= L3 <= L4+L5 must be satisfied;
!       4. L1MAX-L1MIN must be a non-negative integer, where
!          L1MAX=MIN(L2+L3,L5+L6) and L1MIN=MAX(ABS(L2-L3),ABS(L5-L6)).
!  If all the conventional restrictions are satisfied, then these
!  restrictions are met. Conversely, if input to this subroutine meets
!  all of these restrictions and the conventional restriction stated
!  above, then all the conventional restrictions are satisfied.
!
!     The user should be cautious in using input parameters that do
!  not satisfy the conventional restrictions. For example, the
!  the subroutine produces values of
!       h(L1) = { L12/3  1 }
!               {2/32/32/3}
!  for L1=1/3 and 4/3 but none of the symmetry properties of the 6j
!  symbol, set forth on pages 1063 and 1064 of Messiah, is satisfied.
!
!     The subroutine generates h(L1MIN), h(L1MIN+1), ..., h(L1MAX)
!  where L1MIN and L1MAX are defined above. The sequence h(L1) is
!  generated by a three-term recurrence algorithm with scaling to
!  control overflow. Both backward and forward recurrence are used to
!  maintain numerical stability. The two recurrence sequences are
!  matched at an interior point and are normalized from the unitary
!  property of 6j coefficients and Wigner's phase convention.
!
!    The algorithm is suited to applications in which large quantum
!  numbers arise, such as in molecular dynamics.
!
!***REFERENCES  1. Messiah, Albert., Quantum Mechanics, Volume II,
!                  North-Holland Publishing Company, 1963.
!               2. Schulten, Klaus and Gordon, Roy G., Exact recursive
!                  evaluation of 3j and 6j coefficients for quantum-
!                  mechanical coupling of angular momenta, J Math
!                  Phys, v 16, no. 10, October 1975, pp. 1961-1970.
!               3. Schulten, Klaus and Gordon, Roy G., Semiclassical
!                  approximations to 3j and 6j coefficients for
!                  quantum-mechanical coupling of angular momenta,
!                  J Math Phys, v 16, no. 10, October 1975,
!                  pp. 1971-1988.
!               4. Schulten, Klaus and Gordon, Roy G., Recursive
!                  evaluation of 3j and 6j coefficients, Computer
!                  Phys Comm, v 11, 1976, pp. 269-278.
!***ROUTINES CALLED  D1MACH, XERMSG
!***REVISION HISTORY  (YYMMDD)
!   750101  DATE WRITTEN
!   880515  SLATEC prologue added by G. C. Nielson, NBS; parameters
!           HUGE and TINY revised to depend on D1MACH.
!   891229  Prologue description rewritten; other prologue sections
!           revised; LMATCH (location of match point for recurrences)
!           removed from argument list; argument IER changed to serve
!           only as an error flag (previously, in cases without error,
!           it returned the number of scalings); number of error codes
!           increased to provide more precise error information;
!           program comments revised; SLATEC error handler calls
!           introduced to enable printing of error messages to meet
!           SLATEC standards. These changes were done by D. W. Lozier,
!           M. A. McClain and J. M. Smith of the National Institute
!           of Standards and Technology, formerly NBS.
!   910415  Mixed type expressions eliminated; variable C1 initialized;
!           description of SIXCOF expanded. These changes were done by
!           D. W. Lozier.
!***END PROLOGUE  DRC6J
!
  INTEGER NDIM, IER
  DOUBLE PRECISION L2, L3, L4, L5, L6, L1MIN, L1MAX, SIXCOF(NDIM)
!
  INTEGER I, INDEX, LSTEP, N, NFIN, NFINP1, NFINP2, NFINP3, NLIM, &
          NSTEP2
  DOUBLE PRECISION A1, A1S, A2, A2S, C1, C1OLD, C2, CNORM, D1MACH, &
                   DENOM, DV, EPS, HUGE, L1, NEWFAC, OLDFAC, ONE, &
                   RATIO, SIGN1, SIGN2, SRHUGE, SRTINY, SUM1, SUM2, &
                   SUMBAC, SUMFOR, SUMUNI, THREE, THRESH, TINY, TWO, &
                   X, X1, X2, X3, Y, Y1, Y2, Y3, ZERO
!
  DATA  ZERO,EPS,ONE,TWO,THREE /0.0D0,0.01D0,1.0D0,2.0D0,3.0D0/
!
!***FIRST EXECUTABLE STATEMENT  DRC6J
  IER=0
!  HUGE is the square root of one twentieth of the largest floating
!  point number, approximately.
  HUGE = SQRT(D1MACH(2)/20.0D0)
  SRHUGE = SQRT(HUGE)
  TINY = 1.0D0/HUGE
  SRTINY = 1.0D0/SRHUGE
!
!     LMATCH = ZERO
!
!  Check error conditions 1, 2, and 3.
  if ( (MOD(L2+L3+L5+L6+EPS,ONE) >= EPS+EPS).OR. &
     (MOD(L4+L2+L6+EPS,ONE) >= EPS+EPS))THEN
     IER=1
     ! call XERMSG('SLATEC','DRC6J','L2+L3+L5+L6 or L4+L2+L6 not '// &
     !    'integer.',IER,1)
     return
  ELSEIF((L4+L2-L6 < ZERO).OR.(L4-L2+L6 < ZERO).OR. &
     (-L4+L2+L6 < ZERO))THEN
     IER=2
     ! call XERMSG('SLATEC','DRC6J','L4, L2, L6 triangular '// &
     !    'condition not satisfied.',IER,1)
     return
  ELSEIF((L4-L5+L3 < ZERO).OR.(L4+L5-L3 < ZERO).OR. &
     (-L4+L5+L3 < ZERO))THEN
     IER=3
     ! call XERMSG('SLATEC','DRC6J','L4, L5, L3 triangular '// &
     !    'condition not satisfied.',IER,1)
     return
  end if
!
!  Limits for L1
!
  L1MIN = MAX(ABS(L2-L3),ABS(L5-L6))
  L1MAX = MIN(L2+L3,L5+L6)
!
!  Check error condition 4.
  if ( MOD(L1MAX-L1MIN+EPS,ONE) >= EPS+EPS)THEN
     IER=4
     ! call XERMSG('SLATEC','DRC6J','L1MAX-L1MIN not integer.',IER,1)
     return
  end if
  if ( L1MIN < L1MAX-EPS)   go to 20
  if ( L1MIN < L1MAX+EPS)   go to 10
!
!  Check error condition 5.
  IER=5
  ! call XERMSG('SLATEC','DRC6J','L1MIN greater than L1MAX.',IER,1)
  return
!
!
!  This is reached in case that L1 can take only one value
!
   10 CONTINUE
!     LSCALE = 0
  SIXCOF(1) = (-ONE) ** INT(L2+L3+L5+L6+EPS) / &
              SQRT((L1MIN+L1MIN+ONE)*(L4+L4+ONE))
  return
!
!
!  This is reached in case that L1 can take more than one value.
!
   20 CONTINUE
!     LSCALE = 0
  NFIN = INT(L1MAX-L1MIN+ONE+EPS)
  if ( NDIM-NFIN)   21, 23, 23
!
!  Check error condition 6.
   21 IER = 6
  ! call XERMSG('SLATEC','DRC6J','Dimension of result array for 6j '// &
  !             'coefficients too small.',IER,1)
  return
!
!
!  Start of forward recursion
!
   23 L1 = L1MIN
  NEWFAC = 0.0D0
  C1 = 0.0D0
  SIXCOF(1) = SRTINY
  SUM1 = (L1+L1+ONE) * TINY
!
  LSTEP = 1
   30 LSTEP = LSTEP + 1
  L1 = L1 + ONE
!
  OLDFAC = NEWFAC
  A1 = (L1+L2+L3+ONE) * (L1-L2+L3) * (L1+L2-L3) * (-L1+L2+L3+ONE)
  A2 = (L1+L5+L6+ONE) * (L1-L5+L6) * (L1+L5-L6) * (-L1+L5+L6+ONE)
  NEWFAC = SQRT(A1*A2)
!
  if ( L1 < ONE+EPS)   go to 40
!
  DV = TWO * ( L2*(L2+ONE)*L5*(L5+ONE) + L3*(L3+ONE)*L6*(L6+ONE) &
             - L1*(L1-ONE)*L4*(L4+ONE) ) &
                     - (L2*(L2+ONE) + L3*(L3+ONE) - L1*(L1-ONE)) &
                     * (L5*(L5+ONE) + L6*(L6+ONE) - L1*(L1-ONE))
!
  DENOM = (L1-ONE) * NEWFAC
!
  if ( LSTEP-2)  32, 32, 31
!
   31 C1OLD = ABS(C1)
   32 C1 = - (L1+L1-ONE) * DV / DENOM
  go to 50
!
!  If L1 = 1, (L1 - 1) has to be factored out of DV, hence
!
   40 C1 = - TWO * ( L2*(L2+ONE) + L5*(L5+ONE) - L4*(L4+ONE) ) &
   / NEWFAC
!
   50 if ( LSTEP > 2)   go to 60
!
!  If L1 = L1MIN + 1, the third term in recursion equation vanishes
!
  X = SRTINY * C1
  SIXCOF(2) = X
  SUM1 = SUM1 + TINY * (L1+L1+ONE) * C1 * C1
!
  if ( LSTEP == NFIN)   go to 220
  go to 30
!
!
   60 C2 = - L1 * OLDFAC / DENOM
!
!  Recursion to the next 6j coefficient X
!
  X = C1 * SIXCOF(LSTEP-1) + C2 * SIXCOF(LSTEP-2)
  SIXCOF(LSTEP) = X
!
  SUMFOR = SUM1
  SUM1 = SUM1 + (L1+L1+ONE) * X * X
  if ( LSTEP == NFIN)   go to 100
!
!  See if last unnormalized 6j coefficient exceeds SRHUGE
!
  if ( ABS(X) < SRHUGE)   go to 80
!
!  This is reached if last 6j coefficient larger than SRHUGE,
!  so that the recursion series SIXCOF(1), ... ,SIXCOF(LSTEP)
!  has to be rescaled to prevent overflow
!
!     LSCALE = LSCALE + 1
  DO 70 I=1,LSTEP
  if ( ABS(SIXCOF(I)) < SRTINY)   SIXCOF(I) = ZERO
   70 SIXCOF(I) = SIXCOF(I) / SRHUGE
  SUM1 = SUM1 / HUGE
  SUMFOR = SUMFOR / HUGE
  X = X / SRHUGE
!
!
!  As long as the coefficient ABS(C1) is decreasing, the recursion
!  proceeds towards increasing 6j values and, hence, is numerically
!  stable.  Once an increase of ABS(C1) is detected, the recursion
!  direction is reversed.
!
   80 if ( C1OLD-ABS(C1))   100, 100, 30
!
!
!  Keep three 6j coefficients around LMATCH for comparison later
!  with backward recursion.
!
  100 CONTINUE
!     LMATCH = L1 - 1
  X1 = X
  X2 = SIXCOF(LSTEP-1)
  X3 = SIXCOF(LSTEP-2)
!
!
!
!  Starting backward recursion from L1MAX taking NSTEP2 steps, so
!  that forward and backward recursion overlap at the three points
!  L1 = LMATCH+1, LMATCH, LMATCH-1.
!
  NFINP1 = NFIN + 1
  NFINP2 = NFIN + 2
  NFINP3 = NFIN + 3
  NSTEP2 = NFIN - LSTEP + 3
  L1 = L1MAX
!
  SIXCOF(NFIN) = SRTINY
  SUM2 = (L1+L1+ONE) * TINY
!
!
  L1 = L1 + TWO
  LSTEP = 1
  110 LSTEP = LSTEP + 1
  L1 = L1 - ONE
!
  OLDFAC = NEWFAC
  A1S = (L1+L2+L3)*(L1-L2+L3-ONE)*(L1+L2-L3-ONE)*(-L1+L2+L3+TWO)
  A2S = (L1+L5+L6)*(L1-L5+L6-ONE)*(L1+L5-L6-ONE)*(-L1+L5+L6+TWO)
  NEWFAC = SQRT(A1S*A2S)
!
  DV = TWO * ( L2*(L2+ONE)*L5*(L5+ONE) + L3*(L3+ONE)*L6*(L6+ONE) &
             - L1*(L1-ONE)*L4*(L4+ONE) ) &
                     - (L2*(L2+ONE) + L3*(L3+ONE) - L1*(L1-ONE)) &
                     * (L5*(L5+ONE) + L6*(L6+ONE) - L1*(L1-ONE))
!
  DENOM = L1 * NEWFAC
  C1 = - (L1+L1-ONE) * DV / DENOM
  if ( LSTEP > 2)   go to 120
!
!  If L1 = L1MAX + 1 the third term in the recursion equation vanishes
!
  Y = SRTINY * C1
  SIXCOF(NFIN-1) = Y
  if ( LSTEP == NSTEP2)   go to 200
  SUMBAC = SUM2
  SUM2 = SUM2 + (L1+L1-THREE) * C1 * C1 * TINY
  go to 110
!
!
  120 C2 = - (L1-ONE) * OLDFAC / DENOM
!
!  Recursion to the next 6j coefficient Y
!
  Y = C1 * SIXCOF(NFINP2-LSTEP) + C2 * SIXCOF(NFINP3-LSTEP)
  if ( LSTEP == NSTEP2)   go to 200
  SIXCOF(NFINP1-LSTEP) = Y
  SUMBAC = SUM2
  SUM2 = SUM2 + (L1+L1-THREE) * Y * Y
!
!  See if last unnormalized 6j coefficient exceeds SRHUGE
!
  if ( ABS(Y) < SRHUGE)   go to 110
!
!  This is reached if last 6j coefficient larger than SRHUGE,
!  so that the recursion series SIXCOF(NFIN), ... ,SIXCOF(NFIN-LSTEP+1)
!  has to be rescaled to prevent overflow
!
!     LSCALE = LSCALE + 1
  DO 130 I=1,LSTEP
  INDEX = NFIN-I+1
  if ( ABS(SIXCOF(INDEX)) < SRTINY)   SIXCOF(INDEX) = ZERO
  130 SIXCOF(INDEX) = SIXCOF(INDEX) / SRHUGE
  SUMBAC = SUMBAC / HUGE
  SUM2 = SUM2 / HUGE
!
  go to 110
!
!
!  The forward recursion 6j coefficients X1, X2, X3 are to be matched
!  with the corresponding backward recursion values Y1, Y2, Y3.
!
  200 Y3 = Y
  Y2 = SIXCOF(NFINP2-LSTEP)
  Y1 = SIXCOF(NFINP3-LSTEP)
!
!
!  Determine now RATIO such that YI = RATIO * XI  (I=1,2,3) holds
!  with minimal error.
!
  RATIO = ( X1*Y1 + X2*Y2 + X3*Y3 ) / ( X1*X1 + X2*X2 + X3*X3 )
  NLIM = NFIN - NSTEP2 + 1
!
  if ( ABS(RATIO) < ONE)   go to 211
!
  DO 210 N=1,NLIM
  210 SIXCOF(N) = RATIO * SIXCOF(N)
  SUMUNI = RATIO * RATIO * SUMFOR + SUMBAC
  go to 230
!
  211 NLIM = NLIM + 1
  RATIO = ONE / RATIO
  DO 212 N=NLIM,NFIN
  212 SIXCOF(N) = RATIO * SIXCOF(N)
  SUMUNI = SUMFOR + RATIO*RATIO*SUMBAC
  go to 230
!
  220 SUMUNI = SUM1
!
!
!  Normalize 6j coefficients
!
  230 CNORM = ONE / SQRT((L4+L4+ONE)*SUMUNI)
!
!  Sign convention for last 6j coefficient determines overall phase
!
  SIGN1 = SIGN(ONE,SIXCOF(NFIN))
  SIGN2 = (-ONE) ** INT(L2+L3+L5+L6+EPS)
  if ( SIGN1*SIGN2) 235,235,236
  235 CNORM = - CNORM
!
  236 if ( ABS(CNORM) < ONE)   go to 250
!
  DO 240 N=1,NFIN
  240 SIXCOF(N) = CNORM * SIXCOF(N)
  return
!
  250 THRESH = TINY / ABS(CNORM)
  DO 251 N=1,NFIN
  if ( ABS(SIXCOF(N)) < THRESH)   SIXCOF(N) = ZERO
  251 SIXCOF(N) = CNORM * SIXCOF(N)
!
  return
end

! *** MY MODIFICATIONS
! The SLATEC library has a complex error-handling system that relies on
! the XERMSG, XERPRN and other functions.  In order to make pieces of SLATEC
! easier to include in my C code (that has its own error management), I
! overwrite XERMSG so that it only only prints a simple error message.

subroutine XERMSG (LIBRAR, SUBROU, MESSG, NERR, LEVEL)

  CHARACTER*(*) LIBRAR, SUBROU, MESSG

  PRINT *, "ERROR IN SLATEC '", SUBROU, "': ", MESSG

end

!!!  UPDATED D1MACH FUNCTION TAKEN FROM
!!!  http://www.nsc.liu.se/~boein/ifip/kyoto/workshop-info/proceedings/einarsson/f90/d1mach.f90
!!!  NB: DIFFERENT FROM THE VERSION IN BURKHARDT PORT!
!DECK D1MACH
			DOUBLE PRECISION FUNCTION D1MACH (I)
      IMPLICIT NONE
      INTEGER :: I
      DOUBLE PRECISION :: B, X
!***BEGIN PROLOGUE  D1MACH
!***PURPOSE  Return floating point machine dependent constants.
!***LIBRARY   SLATEC
!***CATEGORY  R1
!***TYPE      SINGLE PRECISION (D1MACH-S, D1MACH-D)
!***KEYWORDS  MACHINE CONSTANTS
!***AUTHOR  Fox, P. A., (Bell Labs)
!           Hall, A. D., (Bell Labs)
!           Schryer, N. L., (Bell Labs)
!***DESCRIPTION
!
!   D1MACH can be used to obtain machine-dependent parameters for the
!   local machine environment.  It is a function subprogram with one
!   (input) argument, and can be referenced as follows:
!
!        A = D1MACH(I)
!
!   where I=1,...,5.  The (output) value of A above is determined by
!   the (input) value of I.  The results for various values of I are
!   discussed below.
!
!   D1MACH(1) = B**(EMIN-1), the smallest positive magnitude.
!   D1MACH(2) = B**EMAX*(1 - B**(-T)), the largest magnitude.
!   D1MACH(3) = B**(-T), the smallest relative spacing.
!   D1MACH(4) = B**(1-T), the largest relative spacing.
!   D1MACH(5) = LOG10(B)
!
!   Assume single precision numbers are represented in the T-digit,
!   base-B form
!
!              sign (B**E)*( (X(1)/B) + ... + (X(T)/B**T) )
!
!   where 0 .LE. X(I) .LT. B for I=1,...,T, 0 .LT. X(1), and
!   EMIN .LE. E .LE. EMAX.
!
!   The values of B, T, EMIN and EMAX are provided in I1MACH as
!   follows:
!   I1MACH(10) = B, the base.
!   I1MACH(11) = T, the number of base-B digits.
!   I1MACH(12) = EMIN, the smallest exponent E.
!   I1MACH(13) = EMAX, the largest exponent E.
!
!
!***REFERENCES  P. A. Fox, A. D. Hall and N. L. Schryer, Framework for
!                 a portable library, ACM Transactions on Mathematical
!                 Software 4, 2 (June 1978), pp. 177-188.
!***ROUTINES CALLED  XERMSG
!***REVISION HISTORY  (YYMMDD)
!   790101  DATE WRITTEN
!   960329  Modified for Fortran 90 (BE after suggestions by EHG)
!***END PROLOGUE  D1MACH
!
      X = 1.0D0
      B = RADIX(X)
      SELECT CASE (I)
        CASE (1)
          D1MACH = B**(MINEXPONENT(X)-1) ! the smallest positive magnitude.
        CASE (2)
          D1MACH = HUGE(X)               ! the largest magnitude.
        CASE (3)
          D1MACH = B**(-DIGITS(X))       ! the smallest relative spacing.
        CASE (4)
          D1MACH = B**(1-DIGITS(X))      ! the largest relative spacing.
        CASE (5)
          D1MACH = LOG10(B)
        CASE DEFAULT
          WRITE (*, FMT = 9000)
 9000     FORMAT ('1ERROR    1 IN D1MACH - I OUT OF BOUNDS')
          STOP
      END SELECT
      RETURN
      END

! Test function.  Used to check that arrays are passed correctly between
! C and Fortran.
subroutine set_array_to_one(pntr, ndim)

	INTEGER ndim, i
	DOUBLE PRECISION pntr(ndim)

	DO i=1,ndim
		pntr(i) = 1.
	ENDDO

end subroutine

!!!  UPDATED R1MACH FUNCTION TAKEN FROM
!!!  http://www.nsc.liu.se/~boein/ifip/kyoto/workshop-info/proceedings/einarsson/f90/r1mach.f90
!!!  NB: DIFFERENT FROM THE VERSION IN BURKHARDT PORT!

!DECK R1MACH
      REAL FUNCTION R1MACH (I)
      IMPLICIT NONE
      INTEGER :: I
      REAL :: B, X
!***BEGIN PROLOGUE  R1MACH
!***PURPOSE  Return floating point machine dependent constants.
!***LIBRARY   SLATEC
!***CATEGORY  R1
!***TYPE      SINGLE PRECISION (R1MACH-S, D1MACH-D)
!***KEYWORDS  MACHINE CONSTANTS
!***AUTHOR  Fox, P. A., (Bell Labs)
!           Hall, A. D., (Bell Labs)
!           Schryer, N. L., (Bell Labs)
!***DESCRIPTION
!
!   R1MACH can be used to obtain machine-dependent parameters for the
!   local machine environment.  It is a function subprogram with one
!   (input) argument, and can be referenced as follows:
!
!        A = R1MACH(I)
!
!   where I=1,...,5.  The (output) value of A above is determined by
!   the (input) value of I.  The results for various values of I are
!   discussed below.
!
!   R1MACH(1) = B**(EMIN-1), the smallest positive magnitude.
!   R1MACH(2) = B**EMAX*(1 - B**(-T)), the largest magnitude.
!   R1MACH(3) = B**(-T), the smallest relative spacing.
!   R1MACH(4) = B**(1-T), the largest relative spacing.
!   R1MACH(5) = LOG10(B)
!
!   Assume single precision numbers are represented in the T-digit,
!   base-B form
!
!              sign (B**E)*( (X(1)/B) + ... + (X(T)/B**T) )
!
!   where 0 .LE. X(I) .LT. B for I=1,...,T, 0 .LT. X(1), and
!   EMIN .LE. E .LE. EMAX.
!
!   The values of B, T, EMIN and EMAX are provided in I1MACH as
!   follows:
!   I1MACH(10) = B, the base.
!   I1MACH(11) = T, the number of base-B digits.
!   I1MACH(12) = EMIN, the smallest exponent E.
!   I1MACH(13) = EMAX, the largest exponent E.
!
!
!***REFERENCES  P. A. Fox, A. D. Hall and N. L. Schryer, Framework for
!                 a portable library, ACM Transactions on Mathematical
!                 Software 4, 2 (June 1978), pp. 177-188.
!***ROUTINES CALLED  XERMSG
!***REVISION HISTORY  (YYMMDD)
!   790101  DATE WRITTEN
!   960329  Modified for Fortran 90 (BE after suggestions by EG)
!***END PROLOGUE  R1MACH
!
      X = 1.0
      B = RADIX(X)
      SELECT CASE (I)
        CASE (1)
          R1MACH = B**(MINEXPONENT(X)-1) ! the smallest positive magnitude.
        CASE (2)
          R1MACH = HUGE(X)               ! the largest magnitude.
        CASE (3)
          R1MACH = B**(-DIGITS(X))       ! the smallest relative spacing.
        CASE (4)
          R1MACH = B**(1-DIGITS(X))      ! the largest relative spacing.
        CASE (5)
          R1MACH = LOG10(B)
        CASE DEFAULT
          WRITE (*, FMT = 9000)
 9000     FORMAT ('1ERROR    1 IN R1MACH - I OUT OF BOUNDS')
          STOP
      END SELECT
      RETURN
      END

! ============================
! = Double precision Bessels =
! ============================

subroutine DBESJ (X, ALPHA, N, Y, NZ)
!
!! DBESJ computes an N member sequence of J Bessel functions ...
!            J/SUB(ALPHA+K-1)/(X), K=1,...,N for non-negative ALPHA
!            and X.
!
!***LIBRARY   SLATEC
!***CATEGORY  C10A3
!***TYPE      DOUBLE PRECISION (BESJ-S, DBESJ-D)
!***KEYWORDS  J BESSEL FUNCTION, SPECIAL FUNCTIONS
!***AUTHOR  Amos, D. E., (SNLA)
!           Daniel, S. L., (SNLA)
!           Weston, M. K., (SNLA)
!***DESCRIPTION
!
!     Abstract  **** a double precision routine ****
!         DBESJ computes an N member sequence of J Bessel functions
!         J/sub(ALPHA+K-1)/(X), K=1,...,N for non-negative ALPHA and X.
!         A combination of the power series, the asymptotic expansion
!         for X to infinity and the uniform asymptotic expansion for
!         NU to infinity are applied over subdivisions of the (NU,X)
!         plane.  For values of (NU,X) not covered by one of these
!         formulae, the order is incremented or decremented by integer
!         values into a region where one of the formulae apply. Backward
!         recursion is applied to reduce orders by integer values except
!         where the entire sequence lies in the oscillatory region.  In
!         this case forward recursion is stable and values from the
!         asymptotic expansion for X to infinity start the recursion
!         when it is efficient to do so. Leading terms of the series and
!         uniform expansion are tested for underflow.  If a sequence is
!         requested and the last member would underflow, the result is
!         set to zero and the next lower order tried, etc., until a
!         member comes on scale or all members are set to zero.
!         Overflow cannot occur.
!
!         The maximum number of significant digits obtainable
!         is the smaller of 14 and the number of digits carried in
!         double precision arithmetic.
!
!     Description of Arguments
!
!         Input      X,ALPHA are double precision
!           X      - X  >=  0.0D0
!           ALPHA  - order of first member of the sequence,
!                    ALPHA  >=  0.0D0
!           N      - number of members in the sequence, N  >=  1
!
!         Output     Y is double precision
!           Y      - a vector whose first N components contain
!                    values for J/sub(ALPHA+K-1)/(X), K=1,...,N
!           NZ     - number of components of Y set to zero due to
!                    underflow,
!                    NZ=0   , normal return, computation completed
!                    NZ  /=  0, last NZ components of Y set to zero,
!                             Y(K)=0.0D0, K=N-NZ+1,...,N.
!
!     Error Conditions
!         Improper input arguments - a fatal error
!         Underflow  - a non-fatal error (NZ  /=  0)
!
!***REFERENCES  D. E. Amos, S. L. Daniel and M. K. Weston, CDC 6600
!                 subroutines IBESS and JBESS for Bessel functions
!                 I(NU,X) and J(NU,X), X  >=  0, NU  >=  0, ACM
!                 Transactions on Mathematical Software 3, (1977),
!                 pp. 76-92.
!               F. W. J. Olver, Tables of Bessel Functions of Moderate
!                 or Large Orders, NPL Mathematical Tables 6, Her
!                 Majesty's Stationery Office, London, 1962.
!***ROUTINES CALLED  D1MACH, DASYJY, DJAIRY, DLNGAM, I1MACH, XERMSG
!***REVISION HISTORY  (YYMMDD)
!   750101  DATE WRITTEN
!   890531  Changed all specific intrinsics to generic.  (WRB)
!   890911  Removed unnecessary intrinsics.  (WRB)
!   890911  REVISION DATE from Version 3.2
!   891214  Prologue converted to Version 4.0 format.  (BAB)
!   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
!   900326  Removed duplicate information from DESCRIPTION section.
!           (WRB)
!   920501  Reformatted the REFERENCES section.  (WRB)
!***END PROLOGUE  DBESJ
  EXTERNAL DJAIRY
  INTEGER I,IALP,IDALP,IFLW,IN,INLIM,IS,I1,I2,K,KK,KM,KT,N,NN, &
          NS,NZ
  INTEGER I1MACH
  DOUBLE PRECISION AK,AKM,ALPHA,ANS,AP,ARG,COEF,DALPHA,DFN,DTM, &
             EARG,ELIM1,ETX,FIDAL,FLGJY,FN,FNF,FNI,FNP1,FNU, &
             FNULIM,GLN,PDF,PIDT,PP,RDEN,RELB,RTTP,RTWO,RTX,RZDEN, &
             S,SA,SB,SXO2,S1,S2,T,TA,TAU,TB,TEMP,TFN,TM,TOL, &
             TOLLN,TRX,TX,T1,T2,WK,X,XO2,XO2L,Y,SLIM,RTOL
  SAVE RTWO, PDF, RTTP, PIDT, PP, INLIM, FNULIM
  DOUBLE PRECISION D1MACH, DLNGAM
  DIMENSION Y(*), TEMP(3), FNULIM(2), PP(4), WK(7)
  DATA RTWO,PDF,RTTP,PIDT                    / 1.34839972492648D+00, &
   7.85398163397448D-01, 7.97884560802865D-01, 1.57079632679490D+00/
  DATA  PP(1),  PP(2),  PP(3),  PP(4)        / 8.72909153935547D+00, &
   2.65693932265030D-01, 1.24578576865586D-01, 7.70133747430388D-04/
  DATA INLIM           /      150            /
  DATA FNULIM(1), FNULIM(2) /      100.0D0,     60.0D0     /
!***FIRST EXECUTABLE STATEMENT  DBESJ
  NZ = 0
  KT = 1
  NS=0
!     I1MACH(14) REPLACES I1MACH(11) IN A DOUBLE PRECISION CODE
!     I1MACH(15) REPLACES I1MACH(12) IN A DOUBLE PRECISION CODE
  TA = D1MACH(3)
  TOL = MAX(TA,1.0D-15)
  I1 = I1MACH(14) + 1
  I2 = I1MACH(15)
  TB = D1MACH(5)
  ELIM1 = -2.303D0*(I2*TB+3.0D0)
  RTOL=1.0D0/TOL
  SLIM=D1MACH(1)*RTOL*1.0D+3
!     TOLLN = -LN(TOL)
  TOLLN = 2.303D0*TB*I1
  TOLLN = MIN(TOLLN,34.5388D0)
  if (N-1) 720, 10, 20
   10 KT = 2
   20 NN = N
  if (X) 730, 30, 80
   30 if (ALPHA) 710, 40, 50
   40 Y(1) = 1.0D0
  if (N == 1) RETURN
  I1 = 2
  go to 60
   50 I1 = 1
   60 DO 70 I=I1,N
    Y(I) = 0.0D0
   70 CONTINUE
  return
   80 CONTINUE
  if (ALPHA < 0.0D0) go to 710
!
  IALP = INT(ALPHA)
  FNI = IALP + N - 1
  FNF = ALPHA - IALP
  DFN = FNI + FNF
  FNU = DFN
  XO2 = X*0.5D0
  SXO2 = XO2*XO2
!
!     DECISION TREE FOR REGION WHERE SERIES, ASYMPTOTIC EXPANSION FOR X
!     TO INFINITY AND ASYMPTOTIC EXPANSION FOR NU TO INFINITY ARE
!     APPLIED.
!
  if (SXO2 <= (FNU+1.0D0)) go to 90
  TA = MAX(20.0D0,FNU)
  if (X > TA) go to 120
  if (X > 12.0D0) go to 110
  XO2L = LOG(XO2)
  NS = INT(SXO2-FNU) + 1
  go to 100
   90 FN = FNU
  FNP1 = FN + 1.0D0
  XO2L = LOG(XO2)
  IS = KT
  if (X <= 0.50D0) go to 330
  NS = 0
  100 FNI = FNI + NS
  DFN = FNI + FNF
  FN = DFN
  FNP1 = FN + 1.0D0
  IS = KT
  if (N-1+NS > 0) IS = 3
  go to 330
  110 ANS = MAX(36.0D0-FNU,0.0D0)
  NS = INT(ANS)
  FNI = FNI + NS
  DFN = FNI + FNF
  FN = DFN
  IS = KT
  if (N-1+NS > 0) IS = 3
  go to 130
  120 CONTINUE
  RTX = SQRT(X)
  TAU = RTWO*RTX
  TA = TAU + FNULIM(KT)
  if (FNU <= TA) go to 480
  FN = FNU
  IS = KT
!
!     UNIFORM ASYMPTOTIC EXPANSION FOR NU TO INFINITY
!
  130 CONTINUE
  I1 = ABS(3-IS)
  I1 = MAX(I1,1)
  FLGJY = 1.0D0
  call DASYJY(DJAIRY,X,FN,FLGJY,I1,TEMP(IS),WK,IFLW)
  if ( IFLW /= 0) go to 380
  go to (320, 450, 620), IS
  310 TEMP(1) = TEMP(3)
  KT = 1
  320 IS = 2
  FNI = FNI - 1.0D0
  DFN = FNI + FNF
  FN = DFN
  if ( I1 == 2) go to 450
  go to 130
!
!     SERIES FOR (X/2)**2 <= NU+1
!
  330 CONTINUE
  GLN = DLNGAM(FNP1)
  ARG = FN*XO2L - GLN
  if (ARG < (-ELIM1)) go to 400
  EARG = EXP(ARG)
  340 CONTINUE
  S = 1.0D0
  if (X < TOL) go to 360
  AK = 3.0D0
  T2 = 1.0D0
  T = 1.0D0
  S1 = FN
  DO 350 K=1,17
    S2 = T2 + S1
    T = -T*SXO2/S2
    S = S + T
    if (ABS(T) < TOL) go to 360
    T2 = T2 + AK
    AK = AK + 2.0D0
    S1 = S1 + FN
  350 CONTINUE
  360 CONTINUE
  TEMP(IS) = S*EARG
  go to (370, 450, 610), IS
  370 EARG = EARG*FN/XO2
  FNI = FNI - 1.0D0
  DFN = FNI + FNF
  FN = DFN
  IS = 2
  go to 340
!
!     SET UNDERFLOW VALUE AND UPDATE PARAMETERS
!     UNDERFLOW CAN ONLY OCCUR FOR NS=0 SINCE THE ORDER MUST BE LARGER
!     THAN 36. THEREFORE, NS NEE NOT BE TESTED.
!
  380 Y(NN) = 0.0D0
  NN = NN - 1
  FNI = FNI - 1.0D0
  DFN = FNI + FNF
  FN = DFN
  if (NN-1) 440, 390, 130
  390 KT = 2
  IS = 2
  go to 130
  400 Y(NN) = 0.0D0
  NN = NN - 1
  FNP1 = FN
  FNI = FNI - 1.0D0
  DFN = FNI + FNF
  FN = DFN
  if (NN-1) 440, 410, 420
  410 KT = 2
  IS = 2
  420 if (SXO2 <= FNP1) go to 430
  go to 130
  430 ARG = ARG - XO2L + LOG(FNP1)
  if (ARG < (-ELIM1)) go to 400
  go to 330
  440 NZ = N - NN
  return
!
!     BACKWARD RECURSION SECTION
!
  450 CONTINUE
  if ( NS /= 0) go to 451
  NZ = N - NN
  if (KT == 2) go to 470
!     BACKWARD RECUR FROM INDEX ALPHA+NN-1 TO ALPHA
  Y(NN) = TEMP(1)
  Y(NN-1) = TEMP(2)
  if (NN == 2) RETURN
  451 CONTINUE
  TRX = 2.0D0/X
  DTM = FNI
  TM = (DTM+FNF)*TRX
  AK=1.0D0
  TA=TEMP(1)
  TB=TEMP(2)
  if ( ABS(TA) > SLIM) go to 455
  TA=TA*RTOL
  TB=TB*RTOL
  AK=TOL
  455 CONTINUE
  KK=2
  IN=NS-1
  if ( IN == 0) go to 690
  if ( NS /= 0) go to 670
  K=NN-2
  DO 460 I=3,NN
    S=TB
    TB = TM*TB - TA
    TA=S
    Y(K)=TB*AK
    DTM = DTM - 1.0D0
    TM = (DTM+FNF)*TRX
    K = K - 1
  460 CONTINUE
  return
  470 Y(1) = TEMP(2)
  return
!
!     ASYMPTOTIC EXPANSION FOR X TO INFINITY WITH FORWARD RECURSION IN
!     OSCILLATORY REGION X > MAX(20, NU), PROVIDED THE LAST MEMBER
!     OF THE SEQUENCE IS ALSO IN THE REGION.
!
  480 CONTINUE
  IN = INT(ALPHA-TAU+2.0D0)
  if (IN <= 0) go to 490
  IDALP = IALP - IN - 1
  KT = 1
  go to 500
  490 CONTINUE
  IDALP = IALP
  IN = 0
  500 IS = KT
  FIDAL = IDALP
  DALPHA = FIDAL + FNF
  ARG = X - PIDT*DALPHA - PDF
  SA = SIN(ARG)
  SB = COS(ARG)
  COEF = RTTP/RTX
  ETX = 8.0D0*X
  510 CONTINUE
  DTM = FIDAL + FIDAL
  DTM = DTM*DTM
  TM = 0.0D0
  if (FIDAL == 0.0D0 .AND. ABS(FNF) < TOL) go to 520
  TM = 4.0D0*FNF*(FIDAL+FIDAL+FNF)
  520 CONTINUE
  TRX = DTM - 1.0D0
  T2 = (TRX+TM)/ETX
  S2 = T2
  RELB = TOL*ABS(T2)
  T1 = ETX
  S1 = 1.0D0
  FN = 1.0D0
  AK = 8.0D0
  DO 530 K=1,13
    T1 = T1 + ETX
    FN = FN + AK
    TRX = DTM - FN
    AP = TRX + TM
    T2 = -T2*AP/T1
    S1 = S1 + T2
    T1 = T1 + ETX
    AK = AK + 8.0D0
    FN = FN + AK
    TRX = DTM - FN
    AP = TRX + TM
    T2 = T2*AP/T1
    S2 = S2 + T2
    if (ABS(T2) <= RELB) go to 540
    AK = AK + 8.0D0
  530 CONTINUE
  540 TEMP(IS) = COEF*(S1*SB-S2*SA)
  if ( IS == 2) go to 560
  FIDAL = FIDAL + 1.0D0
  DALPHA = FIDAL + FNF
  IS = 2
  TB = SA
  SA = -SB
  SB = TB
  go to 510
!
!     FORWARD RECURSION SECTION
!
  560 if (KT == 2) go to 470
  S1 = TEMP(1)
  S2 = TEMP(2)
  TX = 2.0D0/X
  TM = DALPHA*TX
  if (IN == 0) go to 580
!
!     FORWARD RECUR TO INDEX ALPHA
!
  DO 570 I=1,IN
    S = S2
    S2 = TM*S2 - S1
    TM = TM + TX
    S1 = S
  570 CONTINUE
  if (NN == 1) go to 600
  S = S2
  S2 = TM*S2 - S1
  TM = TM + TX
  S1 = S
  580 CONTINUE
!
!     FORWARD RECUR FROM INDEX ALPHA TO ALPHA+N-1
!
  Y(1) = S1
  Y(2) = S2
  if (NN == 2) RETURN
  DO 590 I=3,NN
    Y(I) = TM*Y(I-1) - Y(I-2)
    TM = TM + TX
  590 CONTINUE
  return
  600 Y(1) = S2
  return
!
!     BACKWARD RECURSION WITH NORMALIZATION BY
!     ASYMPTOTIC EXPANSION FOR NU TO INFINITY OR POWER SERIES.
!
  610 CONTINUE
!     COMPUTATION OF LAST ORDER FOR SERIES NORMALIZATION
  AKM = MAX(3.0D0-FN,0.0D0)
  KM = INT(AKM)
  TFN = FN + KM
  TA = (GLN+TFN-0.9189385332D0-0.0833333333D0/TFN)/(TFN+0.5D0)
  TA = XO2L - TA
  TB = -(1.0D0-1.5D0/TFN)/TFN
  AKM = TOLLN/(-TA+SQRT(TA*TA-TOLLN*TB)) + 1.5D0
  IN = KM + INT(AKM)
  go to 660
  620 CONTINUE
!     COMPUTATION OF LAST ORDER FOR ASYMPTOTIC EXPANSION NORMALIZATION
  GLN = WK(3) + WK(2)
  if (WK(6) > 30.0D0) go to 640
  RDEN = (PP(4)*WK(6)+PP(3))*WK(6) + 1.0D0
  RZDEN = PP(1) + PP(2)*WK(6)
  TA = RZDEN/RDEN
  if (WK(1) < 0.10D0) go to 630
  TB = GLN/WK(5)
  go to 650
  630 TB=(1.259921049D0+(0.1679894730D0+0.0887944358D0*WK(1))*WK(1)) &
   /WK(7)
  go to 650
  640 CONTINUE
  TA = 0.5D0*TOLLN/WK(4)
  TA=((0.0493827160D0*TA-0.1111111111D0)*TA+0.6666666667D0)*TA*WK(6)
  if (WK(1) < 0.10D0) go to 630
  TB = GLN/WK(5)
  650 IN = INT(TA/TB+1.5D0)
  if (IN > INLIM) go to 310
  660 CONTINUE
  DTM = FNI + IN
  TRX = 2.0D0/X
  TM = (DTM+FNF)*TRX
  TA = 0.0D0
  TB = TOL
  KK = 1
  AK=1.0D0
  670 CONTINUE
!
!     BACKWARD RECUR UNINDEXED
!
  DO 680 I=1,IN
    S = TB
    TB = TM*TB - TA
    TA = S
    DTM = DTM - 1.0D0
    TM = (DTM+FNF)*TRX
  680 CONTINUE
!     NORMALIZATION
  if (KK /= 1) go to 690
  S=TEMP(3)
  SA=TA/TB
  TA=S
  TB=S
  if ( ABS(S) > SLIM) go to 685
  TA=TA*RTOL
  TB=TB*RTOL
  AK=TOL
  685 CONTINUE
  TA=TA*SA
  KK = 2
  IN = NS
  if (NS /= 0) go to 670
  690 Y(NN) = TB*AK
  NZ = N - NN
  if (NN == 1) RETURN
  K = NN - 1
  S=TB
  TB = TM*TB - TA
  TA=S
  Y(K)=TB*AK
  if (NN == 2) RETURN
  DTM = DTM - 1.0D0
  TM = (DTM+FNF)*TRX
  K=NN-2
!
!     BACKWARD RECUR INDEXED
!
  DO 700 I=3,NN
    S=TB
    TB = TM*TB - TA
    TA=S
    Y(K)=TB*AK
    DTM = DTM - 1.0D0
    TM = (DTM+FNF)*TRX
    K = K - 1
  700 CONTINUE
  return
!
!
!
  710 CONTINUE
  call XERMSG ('SLATEC', 'DBESJ', 'ORDER, ALPHA, LESS THAN ZERO.', &
     2, 1)
  return
  720 CONTINUE
  call XERMSG ('SLATEC', 'DBESJ', 'N LESS THAN ONE.', 2, 1)
  return
  730 CONTINUE
  call XERMSG ('SLATEC', 'DBESJ', 'X LESS THAN ZERO.', 2, 1)
  return
end

DOUBLE PRECISION FUNCTION DBESJ0 (X)
!
!! DBESJ0 computes the Bessel function of the first kind of order zero.
!
!***LIBRARY   SLATEC (FNLIB)
!***CATEGORY  C10A1
!***TYPE      DOUBLE PRECISION (BESJ0-S, DBESJ0-D)
!***KEYWORDS  BESSEL FUNCTION, FIRST KIND, FNLIB, ORDER ZERO,
!             SPECIAL FUNCTIONS
!***AUTHOR  Fullerton, W., (LANL)
!***DESCRIPTION
!
! DBESJ0(X) calculates the double precision Bessel function of
! the first kind of order zero for double precision argument X.
!
! Series for BJ0        on the interval  0.          to  1.60000E+01
!                                        with weighted error   4.39E-32
!                                         log weighted error  31.36
!                               significant figures required  31.21
!                                    decimal places required  32.00
!
!***REFERENCES  (NONE)
!***ROUTINES CALLED  D1MACH, D9B0MP, DCSEVL, INITDS
!***REVISION HISTORY  (YYMMDD)
!   770701  DATE WRITTEN
!   890531  Changed all specific intrinsics to generic.  (WRB)
!   890531  REVISION DATE from Version 3.2
!   891214  Prologue converted to Version 4.0 format.  (BAB)
!***END PROLOGUE  DBESJ0
  DOUBLE PRECISION X, BJ0CS(19), AMPL, THETA, XSML, Y, D1MACH, &
    DCSEVL
  LOGICAL FIRST
  SAVE BJ0CS, NTJ0, XSML, FIRST
  DATA BJ0CS(  1) / +.10025416196893913701073127264074D+0     /
  DATA BJ0CS(  2) / -.66522300776440513177678757831124D+0     /
  DATA BJ0CS(  3) / +.24898370349828131370460468726680D+0     /
  DATA BJ0CS(  4) / -.33252723170035769653884341503854D-1     /
  DATA BJ0CS(  5) / +.23114179304694015462904924117729D-2     /
  DATA BJ0CS(  6) / -.99112774199508092339048519336549D-4     /
  DATA BJ0CS(  7) / +.28916708643998808884733903747078D-5     /
  DATA BJ0CS(  8) / -.61210858663032635057818407481516D-7     /
  DATA BJ0CS(  9) / +.98386507938567841324768748636415D-9     /
  DATA BJ0CS( 10) / -.12423551597301765145515897006836D-10    /
  DATA BJ0CS( 11) / +.12654336302559045797915827210363D-12    /
  DATA BJ0CS( 12) / -.10619456495287244546914817512959D-14    /
  DATA BJ0CS( 13) / +.74706210758024567437098915584000D-17    /
  DATA BJ0CS( 14) / -.44697032274412780547627007999999D-19    /
  DATA BJ0CS( 15) / +.23024281584337436200523093333333D-21    /
  DATA BJ0CS( 16) / -.10319144794166698148522666666666D-23    /
  DATA BJ0CS( 17) / +.40608178274873322700800000000000D-26    /
  DATA BJ0CS( 18) / -.14143836005240913919999999999999D-28    /
  DATA BJ0CS( 19) / +.43910905496698880000000000000000D-31    /
  DATA FIRST /.TRUE./
!***FIRST EXECUTABLE STATEMENT  DBESJ0
  if (FIRST) THEN
     NTJ0 = INITDS (BJ0CS, 19, 0.1*REAL(D1MACH(3)))
     XSML = SQRT(8.0D0*D1MACH(3))
  end if
  FIRST = .FALSE.
!
  Y = ABS(X)
  if (Y > 4.0D0) go to 20
!
  DBESJ0 = 1.0D0
  if (Y > XSML) DBESJ0 = DCSEVL (.125D0*Y*Y-1.D0, BJ0CS, NTJ0)
  return
!
 20   call D9B0MP (Y, AMPL, THETA)
  DBESJ0 = AMPL * COS(THETA)
!
  return
end

DOUBLE PRECISION FUNCTION DBESJ1 (X)
!
!! DBESJ1 computes the Bessel function of the first kind of order one.
!
!***LIBRARY   SLATEC (FNLIB)
!***CATEGORY  C10A1
!***TYPE      DOUBLE PRECISION (BESJ1-S, DBESJ1-D)
!***KEYWORDS  BESSEL FUNCTION, FIRST KIND, FNLIB, ORDER ONE,
!             SPECIAL FUNCTIONS
!***AUTHOR  Fullerton, W., (LANL)
!***DESCRIPTION
!
! DBESJ1(X) calculates the double precision Bessel function of the
! first kind of order one for double precision argument X.
!
! Series for BJ1        on the interval  0.          to  1.60000E+01
!                                        with weighted error   1.16E-33
!                                         log weighted error  32.93
!                               significant figures required  32.36
!                                    decimal places required  33.57
!
!***REFERENCES  (NONE)
!***ROUTINES CALLED  D1MACH, D9B1MP, DCSEVL, INITDS, XERMSG
!***REVISION HISTORY  (YYMMDD)
!   780601  DATE WRITTEN
!   890531  Changed all specific intrinsics to generic.  (WRB)
!   890531  REVISION DATE from Version 3.2
!   891214  Prologue converted to Version 4.0 format.  (BAB)
!   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
!   910401  Corrected error in code which caused values to have the
!           wrong sign for arguments less than 4.0.  (WRB)
!***END PROLOGUE  DBESJ1
  DOUBLE PRECISION X, BJ1CS(19), AMPL, THETA, XSML, XMIN, Y, &
    D1MACH, DCSEVL
  LOGICAL FIRST
  SAVE BJ1CS, NTJ1, XSML, XMIN, FIRST
  DATA BJ1CS(  1) / -.117261415133327865606240574524003D+0    /
  DATA BJ1CS(  2) / -.253615218307906395623030884554698D+0    /
  DATA BJ1CS(  3) / +.501270809844695685053656363203743D-1    /
  DATA BJ1CS(  4) / -.463151480962508191842619728789772D-2    /
  DATA BJ1CS(  5) / +.247996229415914024539124064592364D-3    /
  DATA BJ1CS(  6) / -.867894868627882584521246435176416D-5    /
  DATA BJ1CS(  7) / +.214293917143793691502766250991292D-6    /
  DATA BJ1CS(  8) / -.393609307918317979229322764073061D-8    /
  DATA BJ1CS(  9) / +.559118231794688004018248059864032D-10   /
  DATA BJ1CS( 10) / -.632761640466139302477695274014880D-12   /
  DATA BJ1CS( 11) / +.584099161085724700326945563268266D-14   /
  DATA BJ1CS( 12) / -.448253381870125819039135059199999D-16   /
  DATA BJ1CS( 13) / +.290538449262502466306018688000000D-18   /
  DATA BJ1CS( 14) / -.161173219784144165412118186666666D-20   /
  DATA BJ1CS( 15) / +.773947881939274637298346666666666D-23   /
  DATA BJ1CS( 16) / -.324869378211199841143466666666666D-25   /
  DATA BJ1CS( 17) / +.120223767722741022720000000000000D-27   /
  DATA BJ1CS( 18) / -.395201221265134933333333333333333D-30   /
  DATA BJ1CS( 19) / +.116167808226645333333333333333333D-32   /
  DATA FIRST /.TRUE./
!***FIRST EXECUTABLE STATEMENT  DBESJ1
  if (FIRST) THEN
     NTJ1 = INITDS (BJ1CS, 19, 0.1*REAL(D1MACH(3)))
!
     XSML = SQRT(8.0D0*D1MACH(3))
     XMIN = 2.0D0*D1MACH(1)
  end if
  FIRST = .FALSE.
!
  Y = ABS(X)
  if (Y > 4.0D0) go to 20
!
  DBESJ1 = 0.0D0
  if (Y == 0.0D0) RETURN
  if (Y  <=  XMIN) call XERMSG ('SLATEC', 'DBESJ1', &
     'ABS(X) SO SMALL J1 UNDERFLOWS', 1, 1)
  if (Y > XMIN) DBESJ1 = 0.5D0*X
  if (Y > XSML) DBESJ1 = X*(.25D0 + DCSEVL (.125D0*Y*Y-1.D0, &
    BJ1CS, NTJ1) )
  return
!
 20   call D9B1MP (Y, AMPL, THETA)
  DBESJ1 = SIGN (AMPL, X) * COS(THETA)
!
  return
end

subroutine DASYJY (FUNJY, X, FNU, FLGJY, IN, Y, WK, IFLW)
!
!! DASYJY is subsidiary to DBESJ and DBESY.
!
!***LIBRARY   SLATEC
!***TYPE      DOUBLE PRECISION (ASYJY-S, DASYJY-D)
!***AUTHOR  Amos, D. E., (SNLA)
!***DESCRIPTION
!
!                 DASYJY computes Bessel functions J and Y
!               for arguments X > 0.0 and orders FNU  >=  35.0
!               on FLGJY = 1 and FLGJY = -1 respectively
!
!                                  INPUT
!
!      FUNJY - External subroutine JAIRY or YAIRY
!          X - Argument, X > 0.0D0
!        FNU - Order of the first Bessel function
!      FLGJY - Selection flag
!              FLGJY =  1.0D0 gives the J function
!              FLGJY = -1.0D0 gives the Y function
!         IN - Number of functions desired, IN = 1 or 2
!
!                                  OUTPUT
!
!         Y  - A vector whose first IN components contain the sequence
!       IFLW - A flag indicating underflow or overflow
!                    return variables for BESJ only
!      WK(1) = 1 - (X/FNU)**2 = W**2
!      WK(2) = SQRT(ABS(WK(1)))
!      WK(3) = ABS(WK(2) - ATAN(WK(2)))  or
!              ABS(LN((1 + WK(2))/(X/FNU)) - WK(2))
!            = ABS((2/3)*ZETA**(3/2))
!      WK(4) = FNU*WK(3)
!      WK(5) = (1.5*WK(3)*FNU)**(1/3) = SQRT(ZETA)*FNU**(1/3)
!      WK(6) = SIGN(1.,W**2)*WK(5)**2 = SIGN(1.,W**2)*ZETA*FNU**(2/3)
!      WK(7) = FNU**(1/3)
!
!     Abstract   **** A Double Precision Routine ****
!         DASYJY implements the uniform asymptotic expansion of
!         the J and Y Bessel functions for FNU >= 35 and real
!         X > 0.0D0. The forms are identical except for a change
!         in sign of some of the terms. This change in sign is
!         accomplished by means of the flag FLGJY = 1 or -1. On
!         FLGJY = 1 the Airy functions AI(X) and DAI(X) are
!         supplied by the external function JAIRY, and on
!         FLGJY = -1 the Airy functions BI(X) and DBI(X) are
!         supplied by the external function YAIRY.
!
!***SEE ALSO  DBESJ, DBESY
!***ROUTINES CALLED  D1MACH, I1MACH
!***REVISION HISTORY  (YYMMDD)
!   750101  DATE WRITTEN
!   890531  Changed all specific intrinsics to generic.  (WRB)
!   890911  Removed unnecessary intrinsics.  (WRB)
!   891004  Correction computation of ELIM.  (WRB)
!   891009  Removed unreferenced variable.  (WRB)
!   891214  Prologue converted to Version 4.0 format.  (BAB)
!   900328  Added TYPE section.  (WRB)
!   910408  Updated the AUTHOR section.  (WRB)
!***END PROLOGUE  DASYJY
  INTEGER I, IFLW, IN, J, JN,JR,JU,K, KB,KLAST,KMAX,KP1, KS, KSP1, &
   KSTEMP, L, LR, LRP1, ISETA, ISETB
  INTEGER I1MACH
  DOUBLE PRECISION ABW2, AKM, ALFA, ALFA1, ALFA2, AP, AR, ASUM, AZ, &
   BETA, BETA1, BETA2, BETA3, BR, BSUM, C, CON1, CON2, &
   CON548,CR,CRZ32, DFI,ELIM, DR,FI, FLGJY, FN, FNU, &
   FN2, GAMA, PHI,  RCZ, RDEN, RELB, RFN2,  RTZ, RZDEN, &
   SA, SB, SUMA, SUMB, S1, TA, TAU, TB, TFN, TOL, TOLS, T2, UPOL, &
    WK, X, XX, Y, Z, Z32
  DOUBLE PRECISION D1MACH
  DIMENSION Y(*), WK(*), C(65)
  DIMENSION ALFA(26,4), BETA(26,5)
  DIMENSION ALFA1(26,2), ALFA2(26,2)
  DIMENSION BETA1(26,2), BETA2(26,2), BETA3(26,1)
  DIMENSION GAMA(26), KMAX(5), AR(8), BR(10), UPOL(10)
  DIMENSION CR(10), DR(10)
  EQUIVALENCE (ALFA(1,1),ALFA1(1,1))
  EQUIVALENCE (ALFA(1,3),ALFA2(1,1))
  EQUIVALENCE (BETA(1,1),BETA1(1,1))
  EQUIVALENCE (BETA(1,3),BETA2(1,1))
  EQUIVALENCE (BETA(1,5),BETA3(1,1))
  SAVE TOLS, CON1, CON2, CON548, AR, BR, C, &
   ALFA1, ALFA2, BETA1, BETA2, BETA3, GAMA
  DATA TOLS            /-6.90775527898214D+00/
  DATA CON1,CON2,CON548/ &
   6.66666666666667D-01, 3.33333333333333D-01, 1.04166666666667D-01/
  DATA  AR(1),  AR(2),  AR(3),  AR(4),  AR(5),  AR(6),  AR(7), &
        AR(8)          / 8.35503472222222D-02, 1.28226574556327D-01, &
   2.91849026464140D-01, 8.81627267443758D-01, 3.32140828186277D+00, &
   1.49957629868626D+01, 7.89230130115865D+01, 4.74451538868264D+02/
  DATA  BR(1), BR(2), BR(3), BR(4), BR(5), BR(6), BR(7), BR(8), &
        BR(9), BR(10)  /-1.45833333333333D-01,-9.87413194444444D-02, &
  -1.43312053915895D-01,-3.17227202678414D-01,-9.42429147957120D-01, &
  -3.51120304082635D+00,-1.57272636203680D+01,-8.22814390971859D+01, &
  -4.92355370523671D+02,-3.31621856854797D+03/
  DATA C(1), C(2), C(3), C(4), C(5), C(6), C(7), C(8), C(9), C(10), &
       C(11), C(12), C(13), C(14), C(15), C(16), C(17), C(18), &
       C(19), C(20), C(21), C(22), C(23), C(24)/ &
         -2.08333333333333D-01,        1.25000000000000D-01, &
          3.34201388888889D-01,       -4.01041666666667D-01, &
          7.03125000000000D-02,       -1.02581259645062D+00, &
          1.84646267361111D+00,       -8.91210937500000D-01, &
          7.32421875000000D-02,        4.66958442342625D+00, &
         -1.12070026162230D+01,        8.78912353515625D+00, &
         -2.36408691406250D+00,        1.12152099609375D-01, &
         -2.82120725582002D+01,        8.46362176746007D+01, &
         -9.18182415432400D+01,        4.25349987453885D+01, &
         -7.36879435947963D+00,        2.27108001708984D-01, &
          2.12570130039217D+02,       -7.65252468141182D+02, &
          1.05999045252800D+03,       -6.99579627376133D+02/
  DATA C(25), C(26), C(27), C(28), C(29), C(30), C(31), C(32), &
       C(33), C(34), C(35), C(36), C(37), C(38), C(39), C(40), &
       C(41), C(42), C(43), C(44), C(45), C(46), C(47), C(48)/ &
          2.18190511744212D+02,       -2.64914304869516D+01, &
          5.72501420974731D-01,       -1.91945766231841D+03, &
          8.06172218173731D+03,       -1.35865500064341D+04, &
          1.16553933368645D+04,       -5.30564697861340D+03, &
          1.20090291321635D+03,       -1.08090919788395D+02, &
          1.72772750258446D+00,        2.02042913309661D+04, &
         -9.69805983886375D+04,        1.92547001232532D+05, &
         -2.03400177280416D+05,        1.22200464983017D+05, &
         -4.11926549688976D+04,        7.10951430248936D+03, &
         -4.93915304773088D+02,        6.07404200127348D+00, &
         -2.42919187900551D+05,        1.31176361466298D+06, &
         -2.99801591853811D+06,        3.76327129765640D+06/
  DATA C(49), C(50), C(51), C(52), C(53), C(54), C(55), C(56), &
       C(57), C(58), C(59), C(60), C(61), C(62), C(63), C(64), &
       C(65)/ &
         -2.81356322658653D+06,        1.26836527332162D+06, &
         -3.31645172484564D+05,        4.52187689813627D+04, &
         -2.49983048181121D+03,        2.43805296995561D+01, &
          3.28446985307204D+06,       -1.97068191184322D+07, &
          5.09526024926646D+07,       -7.41051482115327D+07, &
          6.63445122747290D+07,       -3.75671766607634D+07, &
          1.32887671664218D+07,       -2.78561812808645D+06, &
          3.08186404612662D+05,       -1.38860897537170D+04, &
          1.10017140269247D+02/
  DATA ALFA1(1,1), ALFA1(2,1), ALFA1(3,1), ALFA1(4,1), ALFA1(5,1), &
       ALFA1(6,1), ALFA1(7,1), ALFA1(8,1), ALFA1(9,1), ALFA1(10,1), &
       ALFA1(11,1),ALFA1(12,1),ALFA1(13,1),ALFA1(14,1),ALFA1(15,1), &
       ALFA1(16,1),ALFA1(17,1),ALFA1(18,1),ALFA1(19,1),ALFA1(20,1), &
       ALFA1(21,1),ALFA1(22,1),ALFA1(23,1),ALFA1(24,1),ALFA1(25,1), &
       ALFA1(26,1)     /-4.44444444444444D-03,-9.22077922077922D-04, &
  -8.84892884892885D-05, 1.65927687832450D-04, 2.46691372741793D-04, &
   2.65995589346255D-04, 2.61824297061501D-04, 2.48730437344656D-04, &
   2.32721040083232D-04, 2.16362485712365D-04, 2.00738858762752D-04, &
   1.86267636637545D-04, 1.73060775917876D-04, 1.61091705929016D-04, &
   1.50274774160908D-04, 1.40503497391270D-04, 1.31668816545923D-04, &
   1.23667445598253D-04, 1.16405271474738D-04, 1.09798298372713D-04, &
   1.03772410422993D-04, 9.82626078369363D-05, 9.32120517249503D-05, &
   8.85710852478712D-05, 8.42963105715700D-05, 8.03497548407791D-05/
  DATA ALFA1(1,2), ALFA1(2,2), ALFA1(3,2), ALFA1(4,2), ALFA1(5,2), &
       ALFA1(6,2), ALFA1(7,2), ALFA1(8,2), ALFA1(9,2), ALFA1(10,2), &
       ALFA1(11,2),ALFA1(12,2),ALFA1(13,2),ALFA1(14,2),ALFA1(15,2), &
       ALFA1(16,2),ALFA1(17,2),ALFA1(18,2),ALFA1(19,2),ALFA1(20,2), &
       ALFA1(21,2),ALFA1(22,2),ALFA1(23,2),ALFA1(24,2),ALFA1(25,2), &
       ALFA1(26,2)     / 6.93735541354589D-04, 2.32241745182922D-04, &
  -1.41986273556691D-05,-1.16444931672049D-04,-1.50803558053049D-04, &
  -1.55121924918096D-04,-1.46809756646466D-04,-1.33815503867491D-04, &
  -1.19744975684254D-04,-1.06184319207974D-04,-9.37699549891194D-05, &
  -8.26923045588193D-05,-7.29374348155221D-05,-6.44042357721016D-05, &
  -5.69611566009369D-05,-5.04731044303562D-05,-4.48134868008883D-05, &
  -3.98688727717599D-05,-3.55400532972042D-05,-3.17414256609022D-05, &
  -2.83996793904175D-05,-2.54522720634871D-05,-2.28459297164725D-05, &
  -2.05352753106481D-05,-1.84816217627666D-05,-1.66519330021394D-05/
  DATA ALFA2(1,1), ALFA2(2,1), ALFA2(3,1), ALFA2(4,1), ALFA2(5,1), &
       ALFA2(6,1), ALFA2(7,1), ALFA2(8,1), ALFA2(9,1), ALFA2(10,1), &
       ALFA2(11,1),ALFA2(12,1),ALFA2(13,1),ALFA2(14,1),ALFA2(15,1), &
       ALFA2(16,1),ALFA2(17,1),ALFA2(18,1),ALFA2(19,1),ALFA2(20,1), &
       ALFA2(21,1),ALFA2(22,1),ALFA2(23,1),ALFA2(24,1),ALFA2(25,1), &
       ALFA2(26,1)     /-3.54211971457744D-04,-1.56161263945159D-04, &
   3.04465503594936D-05, 1.30198655773243D-04, 1.67471106699712D-04, &
   1.70222587683593D-04, 1.56501427608595D-04, 1.36339170977445D-04, &
   1.14886692029825D-04, 9.45869093034688D-05, 7.64498419250898D-05, &
   6.07570334965197D-05, 4.74394299290509D-05, 3.62757512005344D-05, &
   2.69939714979225D-05, 1.93210938247939D-05, 1.30056674793963D-05, &
   7.82620866744497D-06, 3.59257485819352D-06, 1.44040049814252D-07, &
  -2.65396769697939D-06,-4.91346867098486D-06,-6.72739296091248D-06, &
  -8.17269379678658D-06,-9.31304715093561D-06,-1.02011418798016D-05/
  DATA ALFA2(1,2), ALFA2(2,2), ALFA2(3,2), ALFA2(4,2), ALFA2(5,2), &
       ALFA2(6,2), ALFA2(7,2), ALFA2(8,2), ALFA2(9,2), ALFA2(10,2), &
       ALFA2(11,2),ALFA2(12,2),ALFA2(13,2),ALFA2(14,2),ALFA2(15,2), &
       ALFA2(16,2),ALFA2(17,2),ALFA2(18,2),ALFA2(19,2),ALFA2(20,2), &
       ALFA2(21,2),ALFA2(22,2),ALFA2(23,2),ALFA2(24,2),ALFA2(25,2), &
       ALFA2(26,2)     / 3.78194199201773D-04, 2.02471952761816D-04, &
  -6.37938506318862D-05,-2.38598230603006D-04,-3.10916256027362D-04, &
  -3.13680115247576D-04,-2.78950273791323D-04,-2.28564082619141D-04, &
  -1.75245280340847D-04,-1.25544063060690D-04,-8.22982872820208D-05, &
  -4.62860730588116D-05,-1.72334302366962D-05, 5.60690482304602D-06, &
   2.31395443148287D-05, 3.62642745856794D-05, 4.58006124490189D-05, &
   5.24595294959114D-05, 5.68396208545815D-05, 5.94349820393104D-05, &
   6.06478527578422D-05, 6.08023907788436D-05, 6.01577894539460D-05, &
   5.89199657344698D-05, 5.72515823777593D-05, 5.52804375585853D-05/
  DATA BETA1(1,1), BETA1(2,1), BETA1(3,1), BETA1(4,1), BETA1(5,1), &
       BETA1(6,1), BETA1(7,1), BETA1(8,1), BETA1(9,1), BETA1(10,1), &
       BETA1(11,1),BETA1(12,1),BETA1(13,1),BETA1(14,1),BETA1(15,1), &
       BETA1(16,1),BETA1(17,1),BETA1(18,1),BETA1(19,1),BETA1(20,1), &
       BETA1(21,1),BETA1(22,1),BETA1(23,1),BETA1(24,1),BETA1(25,1), &
       BETA1(26,1)     / 1.79988721413553D-02, 5.59964911064388D-03, &
   2.88501402231133D-03, 1.80096606761054D-03, 1.24753110589199D-03, &
   9.22878876572938D-04, 7.14430421727287D-04, 5.71787281789705D-04, &
   4.69431007606482D-04, 3.93232835462917D-04, 3.34818889318298D-04, &
   2.88952148495752D-04, 2.52211615549573D-04, 2.22280580798883D-04, &
   1.97541838033063D-04, 1.76836855019718D-04, 1.59316899661821D-04, &
   1.44347930197334D-04, 1.31448068119965D-04, 1.20245444949303D-04, &
   1.10449144504599D-04, 1.01828770740567D-04, 9.41998224204238D-05, &
   8.74130545753834D-05, 8.13466262162801D-05, 7.59002269646219D-05/
  DATA BETA1(1,2), BETA1(2,2), BETA1(3,2), BETA1(4,2), BETA1(5,2), &
       BETA1(6,2), BETA1(7,2), BETA1(8,2), BETA1(9,2), BETA1(10,2), &
       BETA1(11,2),BETA1(12,2),BETA1(13,2),BETA1(14,2),BETA1(15,2), &
       BETA1(16,2),BETA1(17,2),BETA1(18,2),BETA1(19,2),BETA1(20,2), &
       BETA1(21,2),BETA1(22,2),BETA1(23,2),BETA1(24,2),BETA1(25,2), &
       BETA1(26,2)     /-1.49282953213429D-03,-8.78204709546389D-04, &
  -5.02916549572035D-04,-2.94822138512746D-04,-1.75463996970783D-04, &
  -1.04008550460816D-04,-5.96141953046458D-05,-3.12038929076098D-05, &
  -1.26089735980230D-05,-2.42892608575730D-07, 8.05996165414274D-06, &
   1.36507009262147D-05, 1.73964125472926D-05, 1.98672978842134D-05, &
   2.14463263790823D-05, 2.23954659232457D-05, 2.28967783814713D-05, &
   2.30785389811178D-05, 2.30321976080909D-05, 2.28236073720349D-05, &
   2.25005881105292D-05, 2.20981015361991D-05, 2.16418427448104D-05, &
   2.11507649256221D-05, 2.06388749782171D-05, 2.01165241997082D-05/
  DATA BETA2(1,1), BETA2(2,1), BETA2(3,1), BETA2(4,1), BETA2(5,1), &
       BETA2(6,1), BETA2(7,1), BETA2(8,1), BETA2(9,1), BETA2(10,1), &
       BETA2(11,1),BETA2(12,1),BETA2(13,1),BETA2(14,1),BETA2(15,1), &
       BETA2(16,1),BETA2(17,1),BETA2(18,1),BETA2(19,1),BETA2(20,1), &
       BETA2(21,1),BETA2(22,1),BETA2(23,1),BETA2(24,1),BETA2(25,1), &
       BETA2(26,1)     / 5.52213076721293D-04, 4.47932581552385D-04, &
   2.79520653992021D-04, 1.52468156198447D-04, 6.93271105657044D-05, &
   1.76258683069991D-05,-1.35744996343269D-05,-3.17972413350427D-05, &
  -4.18861861696693D-05,-4.69004889379141D-05,-4.87665447413787D-05, &
  -4.87010031186735D-05,-4.74755620890087D-05,-4.55813058138628D-05, &
  -4.33309644511266D-05,-4.09230193157750D-05,-3.84822638603221D-05, &
  -3.60857167535411D-05,-3.37793306123367D-05,-3.15888560772110D-05, &
  -2.95269561750807D-05,-2.75978914828336D-05,-2.58006174666884D-05, &
  -2.41308356761280D-05,-2.25823509518346D-05,-2.11479656768913D-05/
  DATA BETA2(1,2), BETA2(2,2), BETA2(3,2), BETA2(4,2), BETA2(5,2), &
       BETA2(6,2), BETA2(7,2), BETA2(8,2), BETA2(9,2), BETA2(10,2), &
       BETA2(11,2),BETA2(12,2),BETA2(13,2),BETA2(14,2),BETA2(15,2), &
       BETA2(16,2),BETA2(17,2),BETA2(18,2),BETA2(19,2),BETA2(20,2), &
       BETA2(21,2),BETA2(22,2),BETA2(23,2),BETA2(24,2),BETA2(25,2), &
       BETA2(26,2)     /-4.74617796559960D-04,-4.77864567147321D-04, &
  -3.20390228067038D-04,-1.61105016119962D-04,-4.25778101285435D-05, &
   3.44571294294968D-05, 7.97092684075675D-05, 1.03138236708272D-04, &
   1.12466775262204D-04, 1.13103642108481D-04, 1.08651634848774D-04, &
   1.01437951597662D-04, 9.29298396593364D-05, 8.40293133016090D-05, &
   7.52727991349134D-05, 6.69632521975731D-05, 5.92564547323195D-05, &
   5.22169308826976D-05, 4.58539485165361D-05, 4.01445513891487D-05, &
   3.50481730031328D-05, 3.05157995034347D-05, 2.64956119950516D-05, &
   2.29363633690998D-05, 1.97893056664022D-05, 1.70091984636413D-05/
  DATA BETA3(1,1), BETA3(2,1), BETA3(3,1), BETA3(4,1), BETA3(5,1), &
       BETA3(6,1), BETA3(7,1), BETA3(8,1), BETA3(9,1), BETA3(10,1), &
       BETA3(11,1),BETA3(12,1),BETA3(13,1),BETA3(14,1),BETA3(15,1), &
       BETA3(16,1),BETA3(17,1),BETA3(18,1),BETA3(19,1),BETA3(20,1), &
       BETA3(21,1),BETA3(22,1),BETA3(23,1),BETA3(24,1),BETA3(25,1), &
       BETA3(26,1)     / 7.36465810572578D-04, 8.72790805146194D-04, &
   6.22614862573135D-04, 2.85998154194304D-04, 3.84737672879366D-06, &
  -1.87906003636972D-04,-2.97603646594555D-04,-3.45998126832656D-04, &
  -3.53382470916038D-04,-3.35715635775049D-04,-3.04321124789040D-04, &
  -2.66722723047613D-04,-2.27654214122820D-04,-1.89922611854562D-04, &
  -1.55058918599094D-04,-1.23778240761874D-04,-9.62926147717644D-05, &
  -7.25178327714425D-05,-5.22070028895634D-05,-3.50347750511901D-05, &
  -2.06489761035552D-05,-8.70106096849767D-06, 1.13698686675100D-06, &
   9.16426474122779D-06, 1.56477785428873D-05, 2.08223629482467D-05/
  DATA GAMA(1),   GAMA(2),   GAMA(3),   GAMA(4),   GAMA(5), &
       GAMA(6),   GAMA(7),   GAMA(8),   GAMA(9),   GAMA(10), &
       GAMA(11),  GAMA(12),  GAMA(13),  GAMA(14),  GAMA(15), &
       GAMA(16),  GAMA(17),  GAMA(18),  GAMA(19),  GAMA(20), &
       GAMA(21),  GAMA(22),  GAMA(23),  GAMA(24),  GAMA(25), &
       GAMA(26)        / 6.29960524947437D-01, 2.51984209978975D-01, &
   1.54790300415656D-01, 1.10713062416159D-01, 8.57309395527395D-02, &
   6.97161316958684D-02, 5.86085671893714D-02, 5.04698873536311D-02, &
   4.42600580689155D-02, 3.93720661543510D-02, 3.54283195924455D-02, &
   3.21818857502098D-02, 2.94646240791158D-02, 2.71581677112934D-02, &
   2.51768272973862D-02, 2.34570755306079D-02, 2.19508390134907D-02, &
   2.06210828235646D-02, 1.94388240897881D-02, 1.83810633800683D-02, &
   1.74293213231963D-02, 1.65685837786612D-02, 1.57865285987918D-02, &
   1.50729501494096D-02, 1.44193250839955D-02, 1.38184805735342D-02/
!***FIRST EXECUTABLE STATEMENT  DASYJY
  TA = D1MACH(3)
  TOL = MAX(TA,1.0D-15)
  TB = D1MACH(5)
  JU = I1MACH(15)
  if ( FLGJY == 1.0D0) go to 6
  JR = I1MACH(14)
  ELIM = -2.303D0*TB*(JU+JR)
  go to 7
    6 CONTINUE
  ELIM = -2.303D0*(TB*JU+3.0D0)
    7 CONTINUE
  FN = FNU
  IFLW = 0
  DO 170 JN=1,IN
    XX = X/FN
    WK(1) = 1.0D0 - XX*XX
    ABW2 = ABS(WK(1))
    WK(2) = SQRT(ABW2)
    WK(7) = FN**CON2
    if (ABW2 > 0.27750D0) go to 80
!
!     ASYMPTOTIC EXPANSION
!     CASES NEAR X=FN, ABS(1.-(X/FN)**2) <= 0.2775
!     COEFFICIENTS OF ASYMPTOTIC EXPANSION BY SERIES
!
!     ZETA AND TRUNCATION FOR A(ZETA) AND B(ZETA) SERIES
!
!     KMAX IS TRUNCATION INDEX FOR A(ZETA) AND B(ZETA) SERIES=MAX(2,SA)
!
    SA = 0.0D0
    if (ABW2 == 0.0D0) go to 10
    SA = TOLS/LOG(ABW2)
   10   SB = SA
    DO 20 I=1,5
      AKM = MAX(SA,2.0D0)
      KMAX(I) = INT(AKM)
      SA = SA + SB
   20   CONTINUE
    KB = KMAX(5)
    KLAST = KB - 1
    SA = GAMA(KB)
    DO 30 K=1,KLAST
      KB = KB - 1
      SA = SA*WK(1) + GAMA(KB)
   30   CONTINUE
    Z = WK(1)*SA
    AZ = ABS(Z)
    RTZ = SQRT(AZ)
    WK(3) = CON1*AZ*RTZ
    WK(4) = WK(3)*FN
    WK(5) = RTZ*WK(7)
    WK(6) = -WK(5)*WK(5)
    if ( Z <= 0.0D0) go to 35
    if ( WK(4) > ELIM) go to 75
    WK(6) = -WK(6)
   35   CONTINUE
    PHI = SQRT(SQRT(SA+SA+SA+SA))
!
!     B(ZETA) FOR S=0
!
    KB = KMAX(5)
    KLAST = KB - 1
    SB = BETA(KB,1)
    DO 40 K=1,KLAST
      KB = KB - 1
      SB = SB*WK(1) + BETA(KB,1)
   40   CONTINUE
    KSP1 = 1
    FN2 = FN*FN
    RFN2 = 1.0D0/FN2
    RDEN = 1.0D0
    ASUM = 1.0D0
    RELB = TOL*ABS(SB)
    BSUM = SB
    DO 60 KS=1,4
      KSP1 = KSP1 + 1
      RDEN = RDEN*RFN2
!
!     A(ZETA) AND B(ZETA) FOR S=1,2,3,4
!
      KSTEMP = 5 - KS
      KB = KMAX(KSTEMP)
      KLAST = KB - 1
      SA = ALFA(KB,KS)
      SB = BETA(KB,KSP1)
      DO 50 K=1,KLAST
        KB = KB - 1
        SA = SA*WK(1) + ALFA(KB,KS)
        SB = SB*WK(1) + BETA(KB,KSP1)
   50     CONTINUE
      TA = SA*RDEN
      TB = SB*RDEN
      ASUM = ASUM + TA
      BSUM = BSUM + TB
      if (ABS(TA) <= TOL .AND. ABS(TB) <= RELB) go to 70
   60   CONTINUE
   70   CONTINUE
    BSUM = BSUM/(FN*WK(7))
    go to 160
!
   75   CONTINUE
    IFLW = 1
    return
!
   80   CONTINUE
    UPOL(1) = 1.0D0
    TAU = 1.0D0/WK(2)
    T2 = 1.0D0/WK(1)
    if (WK(1) >= 0.0D0) go to 90
!
!     CASES FOR (X/FN) > SQRT(1.2775)
!
    WK(3) = ABS(WK(2)-ATAN(WK(2)))
    WK(4) = WK(3)*FN
    RCZ = -CON1/WK(4)
    Z32 = 1.5D0*WK(3)
    RTZ = Z32**CON2
    WK(5) = RTZ*WK(7)
    WK(6) = -WK(5)*WK(5)
    go to 100
   90   CONTINUE
!
!     CASES FOR (X/FN) < SQRT(0.7225)
!
    WK(3) = ABS(LOG((1.0D0+WK(2))/XX)-WK(2))
    WK(4) = WK(3)*FN
    RCZ = CON1/WK(4)
    if ( WK(4) > ELIM) go to 75
    Z32 = 1.5D0*WK(3)
    RTZ = Z32**CON2
    WK(7) = FN**CON2
    WK(5) = RTZ*WK(7)
    WK(6) = WK(5)*WK(5)
  100   CONTINUE
    PHI = SQRT((RTZ+RTZ)*TAU)
    TB = 1.0D0
    ASUM = 1.0D0
    TFN = TAU/FN
    RDEN=1.0D0/FN
    RFN2=RDEN*RDEN
    RDEN=1.0D0
    UPOL(2) = (C(1)*T2+C(2))*TFN
    CRZ32 = CON548*RCZ
    BSUM = UPOL(2) + CRZ32
    RELB = TOL*ABS(BSUM)
    AP = TFN
    KS = 0
    KP1 = 2
    RZDEN = RCZ
    L = 2
    ISETA=0
    ISETB=0
    DO 140 LR=2,8,2
!
!     COMPUTE TWO U POLYNOMIALS FOR NEXT A(ZETA) AND B(ZETA)
!
      LRP1 = LR + 1
      DO 120 K=LR,LRP1
        KS = KS + 1
        KP1 = KP1 + 1
        L = L + 1
        S1 = C(L)
        DO 110 J=2,KP1
          L = L + 1
          S1 = S1*T2 + C(L)
  110       CONTINUE
        AP = AP*TFN
        UPOL(KP1) = AP*S1
        CR(KS) = BR(KS)*RZDEN
        RZDEN = RZDEN*RCZ
        DR(KS) = AR(KS)*RZDEN
  120     CONTINUE
      SUMA = UPOL(LRP1)
      SUMB = UPOL(LR+2) + UPOL(LRP1)*CRZ32
      JU = LRP1
      DO 130 JR=1,LR
        JU = JU - 1
        SUMA = SUMA + CR(JR)*UPOL(JU)
        SUMB = SUMB + DR(JR)*UPOL(JU)
  130     CONTINUE
      RDEN=RDEN*RFN2
      TB = -TB
      if (WK(1) > 0.0D0) TB = ABS(TB)
      if ( RDEN < TOL) go to 131
      ASUM = ASUM + SUMA*TB
      BSUM = BSUM + SUMB*TB
      go to 140
  131     if ( ISETA == 1) go to 132
      if ( ABS(SUMA) < TOL) ISETA=1
      ASUM=ASUM+SUMA*TB
  132     if ( ISETB == 1) go to 133
      if ( ABS(SUMB) < RELB) ISETB=1
      BSUM=BSUM+SUMB*TB
  133     if ( ISETA == 1 .AND. ISETB == 1) go to 150
  140   CONTINUE
  150   TB = WK(5)
    if (WK(1) > 0.0D0) TB = -TB
    BSUM = BSUM/TB
!
  160   CONTINUE
    call FUNJY(WK(6), WK(5), WK(4), FI, DFI)
    TA=1.0D0/TOL
    TB=D1MACH(1)*TA*1.0D+3
    if ( ABS(FI) > TB) go to 165
    FI=FI*TA
    DFI=DFI*TA
    PHI=PHI*TOL
  165   CONTINUE
    Y(JN) = FLGJY*PHI*(FI*ASUM+DFI*BSUM)/WK(7)
    FN = FN - FLGJY
  170 CONTINUE
  return
end

!!!  UPDATED I1MACH FUNCTION TAKEN FROM
!!!  http://www.nsc.liu.se/~boein/ifip/kyoto/workshop-info/proceedings/einarsson/f90/i1mach.f90
!!!  NB: DIFFERENT FROM THE VERSION IN BURKHARDT PORT!

!DECK I1MACH
      INTEGER FUNCTION I1MACH (I)
      IMPLICIT NONE
      INTEGER :: I
      REAL :: X
      DOUBLE PRECISION :: XX
!***BEGIN PROLOGUE  I1MACH
!***PURPOSE  Return integer machine dependent constants.
!***LIBRARY   SLATEC
!***CATEGORY  R1
!***TYPE      INTEGER (I1MACH-I)
!***KEYWORDS  MACHINE CONSTANTS
!***AUTHOR  Fox, P. A., (Bell Labs)
!           Hall, A. D., (Bell Labs)
!           Schryer, N. L., (Bell Labs)
!***DESCRIPTION
!
!   I1MACH can be used to obtain machine-dependent parameters for the
!   local machine environment.  It is a function subprogram with one
!   (input) argument and can be referenced as follows:
!
!        K = I1MACH(I)
!
!   where I=1,...,16.  The (output) value of K above is determined by
!   the (input) value of I.  The results for various values of I are
!   discussed below.
!
!   I/O unit numbers:
!     I1MACH( 1) = the standard input unit.
!     I1MACH( 2) = the standard output unit.
!     I1MACH( 3) = the standard punch unit.
!     I1MACH( 4) = the standard error message unit.
!
!   Words:
!     I1MACH( 5) = the number of bits per integer storage unit.
!     I1MACH( 6) = the number of characters per integer storage unit.
!
!   Integers:
!     assume integers are represented in the S-digit, base-A form
!
!                sign ( X(S-1)*A**(S-1) + ... + X(1)*A + X(0) )
!
!                where 0 .LE. X(I) .LT. A for I=0,...,S-1.
!     I1MACH( 7) = A, the base.
!     I1MACH( 8) = S, the number of base-A digits.
!     I1MACH( 9) = A**S - 1, the largest magnitude.
!
!   Floating-Point Numbers:
!     Assume floating-point numbers are represented in the T-digit,
!     base-B form
!                sign (B**E)*( (X(1)/B) + ... + (X(T)/B**T) )
!
!                where 0 .LE. X(I) .LT. B for I=1,...,T,
!                0 .LT. X(1), and EMIN .LE. E .LE. EMAX.
!     I1MACH(10) = B, the base.
!
!   Single-Precision:
!     I1MACH(11) = T, the number of base-B digits.
!     I1MACH(12) = EMIN, the smallest exponent E.
!     I1MACH(13) = EMAX, the largest exponent E.
!
!   Double-Precision:
!     I1MACH(14) = T, the number of base-B digits.
!     I1MACH(15) = EMIN, the smallest exponent E.
!     I1MACH(16) = EMAX, the largest exponent E.
!
!   To alter this function for a particular environment, the desired
!   set of DATA statements should be activated by removing the C from
!   column 1.  Also, the values of I1MACH(1) - I1MACH(4) should be
!   checked for consistency with the local operating system.
!
!***REFERENCES  P. A. Fox, A. D. Hall and N. L. Schryer, Framework for
!                 a portable library, ACM Transactions on Mathematical
!                 Software 4, 2 (June 1978), pp. 177-188.
!***ROUTINES CALLED  (NONE)
!***REVISION HISTORY  (YYMMDD)
!   750101  DATE WRITTEN
!   960411  Modified for Fortran 90 (BE after suggestions by EHG).
!   980727  Modified value of I1MACH(6) (BE after suggestion by EHG).
!***END PROLOGUE  I1MACH
!
      X  = 1.0
      XX = 1.0D0

      SELECT CASE (I)
        CASE (1)
          I1MACH = 5 ! Input unit
        CASE (2)
          I1MACH = 6 ! Output unit
        CASE (3)
          I1MACH = 0 ! Punch unit is no longer used
        CASE (4)
          I1MACH = 0 ! Error message unit
        CASE (5)
          I1MACH = BIT_SIZE(I)
        CASE (6)
          I1MACH = 4            ! Characters per integer is hopefully no
                                ! longer used.
                                ! If it is used it has to be set manually.
                                ! The value 4 is correct on IEEE-machines.
        CASE (7)
          I1MACH = RADIX(1)
        CASE (8)
          I1MACH = BIT_SIZE(I) - 1
        CASE (9)
          I1MACH = HUGE(1)
        CASE (10)
          I1MACH = RADIX(X)
        CASE (11)
          I1MACH = DIGITS(X)
        CASE (12)
          I1MACH = MINEXPONENT(X)
        CASE (13)
          I1MACH = MAXEXPONENT(X)
        CASE (14)
          I1MACH = DIGITS(XX)
        CASE (15)
          I1MACH = MINEXPONENT(XX)
        CASE (16)
          I1MACH = MAXEXPONENT(XX)
        CASE DEFAULT
          WRITE (*, FMT = 9000)
 9000     FORMAT ('1ERROR    1 IN I1MACH - I OUT OF BOUNDS')
          STOP
        END SELECT
      RETURN
      END

! FUNCTION I1MACH (I)
! !
! !! I1MACH returns integer machine dependent constants.
! !
! !***LIBRARY   SLATEC
! !***CATEGORY  R1
! !***TYPE      INTEGER (I1MACH-I)
! !***KEYWORDS  MACHINE CONSTANTS
! !***AUTHOR  Fox, P. A., (Bell Labs)
! !           Hall, A. D., (Bell Labs)
! !           Schryer, N. L., (Bell Labs)
! !***DESCRIPTION
! !
! !   I1MACH can be used to obtain machine-dependent parameters for the
! !   local machine environment.  It is a function subprogram with one
! !   (input) argument and can be referenced as follows:
! !
! !        K = I1MACH(I)
! !
! !   where I=1,...,16.  The (output) value of K above is determined by
! !   the (input) value of I.  The results for various values of I are
! !   discussed below.
! !
! !   I/O unit numbers:
! !     I1MACH( 1) = the standard input unit.
! !     I1MACH( 2) = the standard output unit.
! !     I1MACH( 3) = the standard punch unit.
! !     I1MACH( 4) = the standard error message unit.
! !
! !   Words:
! !     I1MACH( 5) = the number of bits per integer storage unit.
! !     I1MACH( 6) = the number of characters per integer storage unit.
! !
! !   Integers:
! !     assume integers are represented in the S-digit, base-A form
! !
! !                sign ( X(S-1)*A**(S-1) + ... + X(1)*A + X(0) )
! !
! !                where 0  <=  X(I)  <  A for I=0,...,S-1.
! !     I1MACH( 7) = A, the base.
! !     I1MACH( 8) = S, the number of base-A digits.
! !     I1MACH( 9) = A**S - 1, the largest magnitude.
! !
! !   Floating-Point Numbers:
! !     Assume floating-point numbers are represented in the T-digit,
! !     base-B form
! !                sign (B**E)*( (X(1)/B) + ... + (X(T)/B**T) )
! !
! !                where 0  <=  X(I)  <  B for I=1,...,T,
! !                0  <  X(1), and EMIN  <=  E  <=  EMAX.
! !     I1MACH(10) = B, the base.
! !
! !   Single-Precision:
! !     I1MACH(11) = T, the number of base-B digits.
! !     I1MACH(12) = EMIN, the smallest exponent E.
! !     I1MACH(13) = EMAX, the largest exponent E.
! !
! !   Double-Precision:
! !     I1MACH(14) = T, the number of base-B digits.
! !     I1MACH(15) = EMIN, the smallest exponent E.
! !     I1MACH(16) = EMAX, the largest exponent E.
! !
! !   To alter this function for a particular environment, the desired
! !   set of DATA statements should be activated by removing the C from
! !   column 1.  Also, the values of I1MACH(1) - I1MACH(4) should be
! !   checked for consistency with the local operating system.
! !
! !***REFERENCES  P. A. Fox, A. D. Hall and N. L. Schryer, Framework for
! !                 a portable library, ACM Transactions on Mathematical
! !                 Software 4, 2 (June 1978), pp. 177-188.
! !***ROUTINES CALLED  (NONE)
! !***REVISION HISTORY  (YYMMDD)
! !   750101  DATE WRITTEN
! !   891012  Added VAX G-floating constants.  (WRB)
! !   891012  REVISION DATE from Version 3.2
! !   891214  Prologue converted to Version 4.0 format.  (BAB)
! !   900618  Added DEC RISC constants.  (WRB)
! !   900723  Added IBM RS 6000 constants.  (WRB)
! !   901009  Correct I1MACH(7) for IBM Mainframes. Should be 2 not 16.
! !           (RWC)
! !   910710  Added HP 730 constants.  (SMR)
! !   911114  Added Convex IEEE constants.  (WRB)
! !   920121  Added SUN -r8 compiler option constants.  (WRB)
! !   920229  Added Touchstone Delta i860 constants.  (WRB)
! !   920501  Reformatted the REFERENCES section.  (WRB)
! !   920625  Added Convex -p8 and -pd8 compiler option constants.
! !           (BKS, WRB)
! !   930201  Added DEC Alpha and SGI constants.  (RWC and WRB)
! !   930618  Corrected I1MACH(5) for Convex -p8 and -pd8 compiler
! !           options.  (DWL, RWC and WRB).
! !***END PROLOGUE  I1MACH
! !
!   integer i1mach
!   INTEGER IMACH(16),OUTPUT
!   SAVE IMACH
!   EQUIVALENCE (IMACH(4),OUTPUT)
! !
! !     MACHINE CONSTANTS FOR THE AMIGA
! !     ABSOFT COMPILER
! !
! !     DATA IMACH( 1) /          5 /
! !     DATA IMACH( 2) /          6 /
! !     DATA IMACH( 3) /          5 /
! !     DATA IMACH( 4) /          6 /
! !     DATA IMACH( 5) /         32 /
! !     DATA IMACH( 6) /          4 /
! !     DATA IMACH( 7) /          2 /
! !     DATA IMACH( 8) /         31 /
! !     DATA IMACH( 9) / 2147483647 /
! !     DATA IMACH(10) /          2 /
! !     DATA IMACH(11) /         24 /
! !     DATA IMACH(12) /       -126 /
! !     DATA IMACH(13) /        127 /
! !     DATA IMACH(14) /         53 /
! !     DATA IMACH(15) /      -1022 /
! !     DATA IMACH(16) /       1023 /
! !
! !     MACHINE CONSTANTS FOR THE APOLLO
! !
! !     DATA IMACH( 1) /          5 /
! !     DATA IMACH( 2) /          6 /
! !     DATA IMACH( 3) /          6 /
! !     DATA IMACH( 4) /          6 /
! !     DATA IMACH( 5) /         32 /
! !     DATA IMACH( 6) /          4 /
! !     DATA IMACH( 7) /          2 /
! !     DATA IMACH( 8) /         31 /
! !     DATA IMACH( 9) / 2147483647 /
! !     DATA IMACH(10) /          2 /
! !     DATA IMACH(11) /         24 /
! !     DATA IMACH(12) /       -125 /
! !     DATA IMACH(13) /        129 /
! !     DATA IMACH(14) /         53 /
! !     DATA IMACH(15) /      -1021 /
! !     DATA IMACH(16) /       1025 /
! !
! !     MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM
! !
! !     DATA IMACH( 1) /          7 /
! !     DATA IMACH( 2) /          2 /
! !     DATA IMACH( 3) /          2 /
! !     DATA IMACH( 4) /          2 /
! !     DATA IMACH( 5) /         36 /
! !     DATA IMACH( 6) /          4 /
! !     DATA IMACH( 7) /          2 /
! !     DATA IMACH( 8) /         33 /
! !     DATA IMACH( 9) / Z1FFFFFFFF /
! !     DATA IMACH(10) /          2 /
! !     DATA IMACH(11) /         24 /
! !     DATA IMACH(12) /       -256 /
! !     DATA IMACH(13) /        255 /
! !     DATA IMACH(14) /         60 /
! !     DATA IMACH(15) /       -256 /
! !     DATA IMACH(16) /        255 /
! !
! !     MACHINE CONSTANTS FOR THE BURROUGHS 5700 SYSTEM
! !
! !     DATA IMACH( 1) /          5 /
! !     DATA IMACH( 2) /          6 /
! !     DATA IMACH( 3) /          7 /
! !     DATA IMACH( 4) /          6 /
! !     DATA IMACH( 5) /         48 /
! !     DATA IMACH( 6) /          6 /
! !     DATA IMACH( 7) /          2 /
! !     DATA IMACH( 8) /         39 /
! !     DATA IMACH( 9) / O0007777777777777 /
! !     DATA IMACH(10) /          8 /
! !     DATA IMACH(11) /         13 /
! !     DATA IMACH(12) /        -50 /
! !     DATA IMACH(13) /         76 /
! !     DATA IMACH(14) /         26 /
! !     DATA IMACH(15) /        -50 /
! !     DATA IMACH(16) /         76 /
! !
! !     MACHINE CONSTANTS FOR THE BURROUGHS 6700/7700 SYSTEMS
! !
! !     DATA IMACH( 1) /          5 /
! !     DATA IMACH( 2) /          6 /
! !     DATA IMACH( 3) /          7 /
! !     DATA IMACH( 4) /          6 /
! !     DATA IMACH( 5) /         48 /
! !     DATA IMACH( 6) /          6 /
! !     DATA IMACH( 7) /          2 /
! !     DATA IMACH( 8) /         39 /
! !     DATA IMACH( 9) / O0007777777777777 /
! !     DATA IMACH(10) /          8 /
! !     DATA IMACH(11) /         13 /
! !     DATA IMACH(12) /        -50 /
! !     DATA IMACH(13) /         76 /
! !     DATA IMACH(14) /         26 /
! !     DATA IMACH(15) /     -32754 /
! !     DATA IMACH(16) /      32780 /
! !
! !     MACHINE CONSTANTS FOR THE CDC 170/180 SERIES USING NOS/VE
! !
! !     DATA IMACH( 1) /          5 /
! !     DATA IMACH( 2) /          6 /
! !     DATA IMACH( 3) /          7 /
! !     DATA IMACH( 4) /          6 /
! !     DATA IMACH( 5) /         64 /
! !     DATA IMACH( 6) /          8 /
! !     DATA IMACH( 7) /          2 /
! !     DATA IMACH( 8) /         63 /
! !     DATA IMACH( 9) / 9223372036854775807 /
! !     DATA IMACH(10) /          2 /
! !     DATA IMACH(11) /         47 /
! !     DATA IMACH(12) /      -4095 /
! !     DATA IMACH(13) /       4094 /
! !     DATA IMACH(14) /         94 /
! !     DATA IMACH(15) /      -4095 /
! !     DATA IMACH(16) /       4094 /
! !
! !     MACHINE CONSTANTS FOR THE CDC 6000/7000 SERIES
! !
! !     DATA IMACH( 1) /          5 /
! !     DATA IMACH( 2) /          6 /
! !     DATA IMACH( 3) /          7 /
! !     DATA IMACH( 4) /    6LOUTPUT/
! !     DATA IMACH( 5) /         60 /
! !     DATA IMACH( 6) /         10 /
! !     DATA IMACH( 7) /          2 /
! !     DATA IMACH( 8) /         48 /
! !     DATA IMACH( 9) / 00007777777777777777B /
! !     DATA IMACH(10) /          2 /
! !     DATA IMACH(11) /         47 /
! !     DATA IMACH(12) /       -929 /
! !     DATA IMACH(13) /       1070 /
! !     DATA IMACH(14) /         94 /
! !     DATA IMACH(15) /       -929 /
! !     DATA IMACH(16) /       1069 /
! !
! !     MACHINE CONSTANTS FOR THE CELERITY C1260
! !
! !     DATA IMACH( 1) /          5 /
! !     DATA IMACH( 2) /          6 /
! !     DATA IMACH( 3) /          6 /
! !     DATA IMACH( 4) /          0 /
! !     DATA IMACH( 5) /         32 /
! !     DATA IMACH( 6) /          4 /
! !     DATA IMACH( 7) /          2 /
! !     DATA IMACH( 8) /         31 /
! !     DATA IMACH( 9) / Z'7FFFFFFF' /
! !     DATA IMACH(10) /          2 /
! !     DATA IMACH(11) /         24 /
! !     DATA IMACH(12) /       -126 /
! !     DATA IMACH(13) /        127 /
! !     DATA IMACH(14) /         53 /
! !     DATA IMACH(15) /      -1022 /
! !     DATA IMACH(16) /       1023 /
! !
! !     MACHINE CONSTANTS FOR THE CONVEX
! !     USING THE -fn COMPILER OPTION
! !
! !     DATA IMACH( 1) /          5 /
! !     DATA IMACH( 2) /          6 /
! !     DATA IMACH( 3) /          7 /
! !     DATA IMACH( 4) /          6 /
! !     DATA IMACH( 5) /         32 /
! !     DATA IMACH( 6) /          4 /
! !     DATA IMACH( 7) /          2 /
! !     DATA IMACH( 8) /         31 /
! !     DATA IMACH( 9) / 2147483647 /
! !     DATA IMACH(10) /          2 /
! !     DATA IMACH(11) /         24 /
! !     DATA IMACH(12) /       -127 /
! !     DATA IMACH(13) /        127 /
! !     DATA IMACH(14) /         53 /
! !     DATA IMACH(15) /      -1023 /
! !     DATA IMACH(16) /       1023 /
! !
! !     MACHINE CONSTANTS FOR THE CONVEX
! !     USING THE -fi COMPILER OPTION
! !
! !     DATA IMACH( 1) /          5 /
! !     DATA IMACH( 2) /          6 /
! !     DATA IMACH( 3) /          7 /
! !     DATA IMACH( 4) /          6 /
! !     DATA IMACH( 5) /         32 /
! !     DATA IMACH( 6) /          4 /
! !     DATA IMACH( 7) /          2 /
! !     DATA IMACH( 8) /         31 /
! !     DATA IMACH( 9) / 2147483647 /
! !     DATA IMACH(10) /          2 /
! !     DATA IMACH(11) /         24 /
! !     DATA IMACH(12) /       -125 /
! !     DATA IMACH(13) /        128 /
! !     DATA IMACH(14) /         53 /
! !     DATA IMACH(15) /      -1021 /
! !     DATA IMACH(16) /       1024 /
! !
! !     MACHINE CONSTANTS FOR THE CONVEX
! !     USING THE -p8 COMPILER OPTION
! !
! !     DATA IMACH( 1) /          5 /
! !     DATA IMACH( 2) /          6 /
! !     DATA IMACH( 3) /          7 /
! !     DATA IMACH( 4) /          6 /
! !     DATA IMACH( 5) /         64 /
! !     DATA IMACH( 6) /          4 /
! !     DATA IMACH( 7) /          2 /
! !     DATA IMACH( 8) /         63 /
! !     DATA IMACH( 9) / 9223372036854775807 /
! !     DATA IMACH(10) /          2 /
! !     DATA IMACH(11) /         53 /
! !     DATA IMACH(12) /      -1023 /
! !     DATA IMACH(13) /       1023 /
! !     DATA IMACH(14) /        113 /
! !     DATA IMACH(15) /     -16383 /
! !     DATA IMACH(16) /      16383 /
! !
! !     MACHINE CONSTANTS FOR THE CONVEX
! !     USING THE -pd8 COMPILER OPTION
! !
! !     DATA IMACH( 1) /          5 /
! !     DATA IMACH( 2) /          6 /
! !     DATA IMACH( 3) /          7 /
! !     DATA IMACH( 4) /          6 /
! !     DATA IMACH( 5) /         64 /
! !     DATA IMACH( 6) /          4 /
! !     DATA IMACH( 7) /          2 /
! !     DATA IMACH( 8) /         63 /
! !     DATA IMACH( 9) / 9223372036854775807 /
! !     DATA IMACH(10) /          2 /
! !     DATA IMACH(11) /         53 /
! !     DATA IMACH(12) /      -1023 /
! !     DATA IMACH(13) /       1023 /
! !     DATA IMACH(14) /         53 /
! !     DATA IMACH(15) /      -1023 /
! !     DATA IMACH(16) /       1023 /
! !
! !     MACHINE CONSTANTS FOR THE CRAY
! !     USING THE 46 BIT INTEGER COMPILER OPTION
! !
! !     DATA IMACH( 1) /        100 /
! !     DATA IMACH( 2) /        101 /
! !     DATA IMACH( 3) /        102 /
! !     DATA IMACH( 4) /        101 /
! !     DATA IMACH( 5) /         64 /
! !     DATA IMACH( 6) /          8 /
! !     DATA IMACH( 7) /          2 /
! !     DATA IMACH( 8) /         46 /
! !     DATA IMACH( 9) / 1777777777777777B /
! !     DATA IMACH(10) /          2 /
! !     DATA IMACH(11) /         47 /
! !     DATA IMACH(12) /      -8189 /
! !     DATA IMACH(13) /       8190 /
! !     DATA IMACH(14) /         94 /
! !     DATA IMACH(15) /      -8099 /
! !     DATA IMACH(16) /       8190 /
! !
! !     MACHINE CONSTANTS FOR THE CRAY
! !     USING THE 64 BIT INTEGER COMPILER OPTION
! !
! !     DATA IMACH( 1) /        100 /
! !     DATA IMACH( 2) /        101 /
! !     DATA IMACH( 3) /        102 /
! !     DATA IMACH( 4) /        101 /
! !     DATA IMACH( 5) /         64 /
! !     DATA IMACH( 6) /          8 /
! !     DATA IMACH( 7) /          2 /
! !     DATA IMACH( 8) /         63 /
! !     DATA IMACH( 9) / 777777777777777777777B /
! !     DATA IMACH(10) /          2 /
! !     DATA IMACH(11) /         47 /
! !     DATA IMACH(12) /      -8189 /
! !     DATA IMACH(13) /       8190 /
! !     DATA IMACH(14) /         94 /
! !     DATA IMACH(15) /      -8099 /
! !     DATA IMACH(16) /       8190 /
! !
! !     MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200
! !
! !     DATA IMACH( 1) /         11 /
! !     DATA IMACH( 2) /         12 /
! !     DATA IMACH( 3) /          8 /
! !     DATA IMACH( 4) /         10 /
! !     DATA IMACH( 5) /         16 /
! !     DATA IMACH( 6) /          2 /
! !     DATA IMACH( 7) /          2 /
! !     DATA IMACH( 8) /         15 /
! !     DATA IMACH( 9) /      32767 /
! !     DATA IMACH(10) /         16 /
! !     DATA IMACH(11) /          6 /
! !     DATA IMACH(12) /        -64 /
! !     DATA IMACH(13) /         63 /
! !     DATA IMACH(14) /         14 /
! !     DATA IMACH(15) /        -64 /
! !     DATA IMACH(16) /         63 /
! !
! !     MACHINE CONSTANTS FOR THE DEC ALPHA
! !     USING G_FLOAT
! !
! !     DATA IMACH( 1) /          5 /
! !     DATA IMACH( 2) /          6 /
! !     DATA IMACH( 3) /          5 /
! !     DATA IMACH( 4) /          6 /
! !     DATA IMACH( 5) /         32 /
! !     DATA IMACH( 6) /          4 /
! !     DATA IMACH( 7) /          2 /
! !     DATA IMACH( 8) /         31 /
! !     DATA IMACH( 9) / 2147483647 /
! !     DATA IMACH(10) /          2 /
! !     DATA IMACH(11) /         24 /
! !     DATA IMACH(12) /       -127 /
! !     DATA IMACH(13) /        127 /
! !     DATA IMACH(14) /         53 /
! !     DATA IMACH(15) /      -1023 /
! !     DATA IMACH(16) /       1023 /
! !
! !     MACHINE CONSTANTS FOR THE DEC ALPHA
! !     USING IEEE_FLOAT
! !
!       DATA IMACH( 1) /          5 /
!       DATA IMACH( 2) /          6 /
!       DATA IMACH( 3) /          6 /
!       DATA IMACH( 4) /          6 /
!       DATA IMACH( 5) /         32 /
!       DATA IMACH( 6) /          4 /
!       DATA IMACH( 7) /          2 /
!       DATA IMACH( 8) /         31 /
!       DATA IMACH( 9) / 2147483647 /
!       DATA IMACH(10) /          2 /
!       DATA IMACH(11) /         24 /
!       DATA IMACH(12) /       -125 /
!       DATA IMACH(13) /        128 /
!       DATA IMACH(14) /         53 /
!       DATA IMACH(15) /      -1021 /
!       DATA IMACH(16) /       1024 /
! !
! !     MACHINE CONSTANTS FOR THE DEC RISC
! !
! !     DATA IMACH( 1) /          5 /
! !     DATA IMACH( 2) /          6 /
! !     DATA IMACH( 3) /          6 /
! !     DATA IMACH( 4) /          6 /
! !     DATA IMACH( 5) /         32 /
! !     DATA IMACH( 6) /          4 /
! !     DATA IMACH( 7) /          2 /
! !     DATA IMACH( 8) /         31 /
! !     DATA IMACH( 9) / 2147483647 /
! !     DATA IMACH(10) /          2 /
! !     DATA IMACH(11) /         24 /
! !     DATA IMACH(12) /       -125 /
! !     DATA IMACH(13) /        128 /
! !     DATA IMACH(14) /         53 /
! !     DATA IMACH(15) /      -1021 /
! !     DATA IMACH(16) /       1024 /
! !
! !     MACHINE CONSTANTS FOR THE DEC VAX
! !     USING D_FLOATING
! !
! !     DATA IMACH( 1) /          5 /
! !     DATA IMACH( 2) /          6 /
! !     DATA IMACH( 3) /          5 /
! !     DATA IMACH( 4) /          6 /
! !     DATA IMACH( 5) /         32 /
! !     DATA IMACH( 6) /          4 /
! !     DATA IMACH( 7) /          2 /
! !     DATA IMACH( 8) /         31 /
! !     DATA IMACH( 9) / 2147483647 /
! !     DATA IMACH(10) /          2 /
! !     DATA IMACH(11) /         24 /
! !     DATA IMACH(12) /       -127 /
! !     DATA IMACH(13) /        127 /
! !     DATA IMACH(14) /         56 /
! !     DATA IMACH(15) /       -127 /
! !     DATA IMACH(16) /        127 /
! !
! !     MACHINE CONSTANTS FOR THE DEC VAX
! !     USING G_FLOATING
! !
! !     DATA IMACH( 1) /          5 /
! !     DATA IMACH( 2) /          6 /
! !     DATA IMACH( 3) /          5 /
! !     DATA IMACH( 4) /          6 /
! !     DATA IMACH( 5) /         32 /
! !     DATA IMACH( 6) /          4 /
! !     DATA IMACH( 7) /          2 /
! !     DATA IMACH( 8) /         31 /
! !     DATA IMACH( 9) / 2147483647 /
! !     DATA IMACH(10) /          2 /
! !     DATA IMACH(11) /         24 /
! !     DATA IMACH(12) /       -127 /
! !     DATA IMACH(13) /        127 /
! !     DATA IMACH(14) /         53 /
! !     DATA IMACH(15) /      -1023 /
! !     DATA IMACH(16) /       1023 /
! !
! !     MACHINE CONSTANTS FOR THE ELXSI 6400
! !
! !     DATA IMACH( 1) /          5 /
! !     DATA IMACH( 2) /          6 /
! !     DATA IMACH( 3) /          6 /
! !     DATA IMACH( 4) /          6 /
! !     DATA IMACH( 5) /         32 /
! !     DATA IMACH( 6) /          4 /
! !     DATA IMACH( 7) /          2 /
! !     DATA IMACH( 8) /         32 /
! !     DATA IMACH( 9) / 2147483647 /
! !     DATA IMACH(10) /          2 /
! !     DATA IMACH(11) /         24 /
! !     DATA IMACH(12) /       -126 /
! !     DATA IMACH(13) /        127 /
! !     DATA IMACH(14) /         53 /
! !     DATA IMACH(15) /      -1022 /
! !     DATA IMACH(16) /       1023 /
! !
! !     MACHINE CONSTANTS FOR THE HARRIS 220
! !
! !     DATA IMACH( 1) /          5 /
! !     DATA IMACH( 2) /          6 /
! !     DATA IMACH( 3) /          0 /
! !     DATA IMACH( 4) /          6 /
! !     DATA IMACH( 5) /         24 /
! !     DATA IMACH( 6) /          3 /
! !     DATA IMACH( 7) /          2 /
! !     DATA IMACH( 8) /         23 /
! !     DATA IMACH( 9) /    8388607 /
! !     DATA IMACH(10) /          2 /
! !     DATA IMACH(11) /         23 /
! !     DATA IMACH(12) /       -127 /
! !     DATA IMACH(13) /        127 /
! !     DATA IMACH(14) /         38 /
! !     DATA IMACH(15) /       -127 /
! !     DATA IMACH(16) /        127 /
! !
! !     MACHINE CONSTANTS FOR THE HONEYWELL 600/6000 SERIES
! !
! !     DATA IMACH( 1) /          5 /
! !     DATA IMACH( 2) /          6 /
! !     DATA IMACH( 3) /         43 /
! !     DATA IMACH( 4) /          6 /
! !     DATA IMACH( 5) /         36 /
! !     DATA IMACH( 6) /          6 /
! !     DATA IMACH( 7) /          2 /
! !     DATA IMACH( 8) /         35 /
! !     DATA IMACH( 9) / O377777777777 /
! !     DATA IMACH(10) /          2 /
! !     DATA IMACH(11) /         27 /
! !     DATA IMACH(12) /       -127 /
! !     DATA IMACH(13) /        127 /
! !     DATA IMACH(14) /         63 /
! !     DATA IMACH(15) /       -127 /
! !     DATA IMACH(16) /        127 /
! !
! !     MACHINE CONSTANTS FOR THE HP 730
! !
! !     DATA IMACH( 1) /          5 /
! !     DATA IMACH( 2) /          6 /
! !     DATA IMACH( 3) /          6 /
! !     DATA IMACH( 4) /          6 /
! !     DATA IMACH( 5) /         32 /
! !     DATA IMACH( 6) /          4 /
! !     DATA IMACH( 7) /          2 /
! !     DATA IMACH( 8) /         31 /
! !     DATA IMACH( 9) / 2147483647 /
! !     DATA IMACH(10) /          2 /
! !     DATA IMACH(11) /         24 /
! !     DATA IMACH(12) /       -125 /
! !     DATA IMACH(13) /        128 /
! !     DATA IMACH(14) /         53 /
! !     DATA IMACH(15) /      -1021 /
! !     DATA IMACH(16) /       1024 /
! !
! !     MACHINE CONSTANTS FOR THE HP 2100
! !     3 WORD DOUBLE PRECISION OPTION WITH FTN4
! !
! !     DATA IMACH( 1) /          5 /
! !     DATA IMACH( 2) /          6 /
! !     DATA IMACH( 3) /          4 /
! !     DATA IMACH( 4) /          1 /
! !     DATA IMACH( 5) /         16 /
! !     DATA IMACH( 6) /          2 /
! !     DATA IMACH( 7) /          2 /
! !     DATA IMACH( 8) /         15 /
! !     DATA IMACH( 9) /      32767 /
! !     DATA IMACH(10) /          2 /
! !     DATA IMACH(11) /         23 /
! !     DATA IMACH(12) /       -128 /
! !     DATA IMACH(13) /        127 /
! !     DATA IMACH(14) /         39 /
! !     DATA IMACH(15) /       -128 /
! !     DATA IMACH(16) /        127 /
! !
! !     MACHINE CONSTANTS FOR THE HP 2100
! !     4 WORD DOUBLE PRECISION OPTION WITH FTN4
! !
! !     DATA IMACH( 1) /          5 /
! !     DATA IMACH( 2) /          6 /
! !     DATA IMACH( 3) /          4 /
! !     DATA IMACH( 4) /          1 /
! !     DATA IMACH( 5) /         16 /
! !     DATA IMACH( 6) /          2 /
! !     DATA IMACH( 7) /          2 /
! !     DATA IMACH( 8) /         15 /
! !     DATA IMACH( 9) /      32767 /
! !     DATA IMACH(10) /          2 /
! !     DATA IMACH(11) /         23 /
! !     DATA IMACH(12) /       -128 /
! !     DATA IMACH(13) /        127 /
! !     DATA IMACH(14) /         55 /
! !     DATA IMACH(15) /       -128 /
! !     DATA IMACH(16) /        127 /
! !
! !     MACHINE CONSTANTS FOR THE HP 9000
! !
! !     DATA IMACH( 1) /          5 /
! !     DATA IMACH( 2) /          6 /
! !     DATA IMACH( 3) /          6 /
! !     DATA IMACH( 4) /          7 /
! !     DATA IMACH( 5) /         32 /
! !     DATA IMACH( 6) /          4 /
! !     DATA IMACH( 7) /          2 /
! !     DATA IMACH( 8) /         32 /
! !     DATA IMACH( 9) / 2147483647 /
! !     DATA IMACH(10) /          2 /
! !     DATA IMACH(11) /         24 /
! !     DATA IMACH(12) /       -126 /
! !     DATA IMACH(13) /        127 /
! !     DATA IMACH(14) /         53 /
! !     DATA IMACH(15) /      -1015 /
! !     DATA IMACH(16) /       1017 /
! !
! !     MACHINE CONSTANTS FOR THE IBM 360/370 SERIES,
! !     THE XEROX SIGMA 5/7/9, THE SEL SYSTEMS 85/86, AND
! !     THE PERKIN ELMER (INTERDATA) 7/32.
! !
! !     DATA IMACH( 1) /          5 /
! !     DATA IMACH( 2) /          6 /
! !     DATA IMACH( 3) /          7 /
! !     DATA IMACH( 4) /          6 /
! !     DATA IMACH( 5) /         32 /
! !     DATA IMACH( 6) /          4 /
! !     DATA IMACH( 7) /          2 /
! !     DATA IMACH( 8) /         31 /
! !     DATA IMACH( 9) /  Z7FFFFFFF /
! !     DATA IMACH(10) /         16 /
! !     DATA IMACH(11) /          6 /
! !     DATA IMACH(12) /        -64 /
! !     DATA IMACH(13) /         63 /
! !     DATA IMACH(14) /         14 /
! !     DATA IMACH(15) /        -64 /
! !     DATA IMACH(16) /         63 /
! !
! !     MACHINE CONSTANTS FOR THE IBM PC
! !
! !     DATA IMACH( 1) /          5 /
! !     DATA IMACH( 2) /          6 /
! !     DATA IMACH( 3) /          0 /
! !     DATA IMACH( 4) /          0 /
! !     DATA IMACH( 5) /         32 /
! !     DATA IMACH( 6) /          4 /
! !     DATA IMACH( 7) /          2 /
! !     DATA IMACH( 8) /         31 /
! !     DATA IMACH( 9) / 2147483647 /
! !     DATA IMACH(10) /          2 /
! !     DATA IMACH(11) /         24 /
! !     DATA IMACH(12) /       -125 /
! !     DATA IMACH(13) /        127 /
! !     DATA IMACH(14) /         53 /
! !     DATA IMACH(15) /      -1021 /
! !     DATA IMACH(16) /       1023 /
! !
! !     MACHINE CONSTANTS FOR THE IBM RS 6000
! !
! !     DATA IMACH( 1) /          5 /
! !     DATA IMACH( 2) /          6 /
! !     DATA IMACH( 3) /          6 /
! !     DATA IMACH( 4) /          0 /
! !     DATA IMACH( 5) /         32 /
! !     DATA IMACH( 6) /          4 /
! !     DATA IMACH( 7) /          2 /
! !     DATA IMACH( 8) /         31 /
! !     DATA IMACH( 9) / 2147483647 /
! !     DATA IMACH(10) /          2 /
! !     DATA IMACH(11) /         24 /
! !     DATA IMACH(12) /       -125 /
! !     DATA IMACH(13) /        128 /
! !     DATA IMACH(14) /         53 /
! !     DATA IMACH(15) /      -1021 /
! !     DATA IMACH(16) /       1024 /
! !
! !     MACHINE CONSTANTS FOR THE INTEL i860
! !
! !     DATA IMACH( 1) /          5 /
! !     DATA IMACH( 2) /          6 /
! !     DATA IMACH( 3) /          6 /
! !     DATA IMACH( 4) /          6 /
! !     DATA IMACH( 5) /         32 /
! !     DATA IMACH( 6) /          4 /
! !     DATA IMACH( 7) /          2 /
! !     DATA IMACH( 8) /         31 /
! !     DATA IMACH( 9) / 2147483647 /
! !     DATA IMACH(10) /          2 /
! !     DATA IMACH(11) /         24 /
! !     DATA IMACH(12) /       -125 /
! !     DATA IMACH(13) /        128 /
! !     DATA IMACH(14) /         53 /
! !     DATA IMACH(15) /      -1021 /
! !     DATA IMACH(16) /       1024 /
! !
! !     MACHINE CONSTANTS FOR THE PDP-10 (KA PROCESSOR)
! !
! !     DATA IMACH( 1) /          5 /
! !     DATA IMACH( 2) /          6 /
! !     DATA IMACH( 3) /          5 /
! !     DATA IMACH( 4) /          6 /
! !     DATA IMACH( 5) /         36 /
! !     DATA IMACH( 6) /          5 /
! !     DATA IMACH( 7) /          2 /
! !     DATA IMACH( 8) /         35 /
! !     DATA IMACH( 9) / "377777777777 /
! !     DATA IMACH(10) /          2 /
! !     DATA IMACH(11) /         27 /
! !     DATA IMACH(12) /       -128 /
! !     DATA IMACH(13) /        127 /
! !     DATA IMACH(14) /         54 /
! !     DATA IMACH(15) /       -101 /
! !     DATA IMACH(16) /        127 /
! !
! !     MACHINE CONSTANTS FOR THE PDP-10 (KI PROCESSOR)
! !
! !     DATA IMACH( 1) /          5 /
! !     DATA IMACH( 2) /          6 /
! !     DATA IMACH( 3) /          5 /
! !     DATA IMACH( 4) /          6 /
! !     DATA IMACH( 5) /         36 /
! !     DATA IMACH( 6) /          5 /
! !     DATA IMACH( 7) /          2 /
! !     DATA IMACH( 8) /         35 /
! !     DATA IMACH( 9) / "377777777777 /
! !     DATA IMACH(10) /          2 /
! !     DATA IMACH(11) /         27 /
! !     DATA IMACH(12) /       -128 /
! !     DATA IMACH(13) /        127 /
! !     DATA IMACH(14) /         62 /
! !     DATA IMACH(15) /       -128 /
! !     DATA IMACH(16) /        127 /
! !
! !     MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING
! !     32-BIT INTEGER ARITHMETIC.
! !
! !     DATA IMACH( 1) /          5 /
! !     DATA IMACH( 2) /          6 /
! !     DATA IMACH( 3) /          5 /
! !     DATA IMACH( 4) /          6 /
! !     DATA IMACH( 5) /         32 /
! !     DATA IMACH( 6) /          4 /
! !     DATA IMACH( 7) /          2 /
! !     DATA IMACH( 8) /         31 /
! !     DATA IMACH( 9) / 2147483647 /
! !     DATA IMACH(10) /          2 /
! !     DATA IMACH(11) /         24 /
! !     DATA IMACH(12) /       -127 /
! !     DATA IMACH(13) /        127 /
! !     DATA IMACH(14) /         56 /
! !     DATA IMACH(15) /       -127 /
! !     DATA IMACH(16) /        127 /
! !
! !     MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING
! !     16-BIT INTEGER ARITHMETIC.
! !
! !     DATA IMACH( 1) /          5 /
! !     DATA IMACH( 2) /          6 /
! !     DATA IMACH( 3) /          5 /
! !     DATA IMACH( 4) /          6 /
! !     DATA IMACH( 5) /         16 /
! !     DATA IMACH( 6) /          2 /
! !     DATA IMACH( 7) /          2 /
! !     DATA IMACH( 8) /         15 /
! !     DATA IMACH( 9) /      32767 /
! !     DATA IMACH(10) /          2 /
! !     DATA IMACH(11) /         24 /
! !     DATA IMACH(12) /       -127 /
! !     DATA IMACH(13) /        127 /
! !     DATA IMACH(14) /         56 /
! !     DATA IMACH(15) /       -127 /
! !     DATA IMACH(16) /        127 /
! !
! !     MACHINE CONSTANTS FOR THE SILICON GRAPHICS
! !
! !     DATA IMACH( 1) /          5 /
! !     DATA IMACH( 2) /          6 /
! !     DATA IMACH( 3) /          6 /
! !     DATA IMACH( 4) /          6 /
! !     DATA IMACH( 5) /         32 /
! !     DATA IMACH( 6) /          4 /
! !     DATA IMACH( 7) /          2 /
! !     DATA IMACH( 8) /         31 /
! !     DATA IMACH( 9) / 2147483647 /
! !     DATA IMACH(10) /          2 /
! !     DATA IMACH(11) /         24 /
! !     DATA IMACH(12) /       -125 /
! !     DATA IMACH(13) /        128 /
! !     DATA IMACH(14) /         53 /
! !     DATA IMACH(15) /      -1021 /
! !     DATA IMACH(16) /       1024 /
! !
! !     MACHINE CONSTANTS FOR THE SUN
! !
! !     DATA IMACH( 1) /          5 /
! !     DATA IMACH( 2) /          6 /
! !     DATA IMACH( 3) /          6 /
! !     DATA IMACH( 4) /          6 /
! !     DATA IMACH( 5) /         32 /
! !     DATA IMACH( 6) /          4 /
! !     DATA IMACH( 7) /          2 /
! !     DATA IMACH( 8) /         31 /
! !     DATA IMACH( 9) / 2147483647 /
! !     DATA IMACH(10) /          2 /
! !     DATA IMACH(11) /         24 /
! !     DATA IMACH(12) /       -125 /
! !     DATA IMACH(13) /        128 /
! !     DATA IMACH(14) /         53 /
! !     DATA IMACH(15) /      -1021 /
! !     DATA IMACH(16) /       1024 /
! !
! !     MACHINE CONSTANTS FOR THE SUN
! !     USING THE -r8 COMPILER OPTION
! !
! !     DATA IMACH( 1) /          5 /
! !     DATA IMACH( 2) /          6 /
! !     DATA IMACH( 3) /          6 /
! !     DATA IMACH( 4) /          6 /
! !     DATA IMACH( 5) /         32 /
! !     DATA IMACH( 6) /          4 /
! !     DATA IMACH( 7) /          2 /
! !     DATA IMACH( 8) /         31 /
! !     DATA IMACH( 9) / 2147483647 /
! !     DATA IMACH(10) /          2 /
! !     DATA IMACH(11) /         53 /
! !     DATA IMACH(12) /      -1021 /
! !     DATA IMACH(13) /       1024 /
! !     DATA IMACH(14) /        113 /
! !     DATA IMACH(15) /     -16381 /
! !     DATA IMACH(16) /      16384 /
! !
! !     MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES FTN COMPILER
! !
! !     DATA IMACH( 1) /          5 /
! !     DATA IMACH( 2) /          6 /
! !     DATA IMACH( 3) /          1 /
! !     DATA IMACH( 4) /          6 /
! !     DATA IMACH( 5) /         36 /
! !     DATA IMACH( 6) /          4 /
! !     DATA IMACH( 7) /          2 /
! !     DATA IMACH( 8) /         35 /
! !     DATA IMACH( 9) / O377777777777 /
! !     DATA IMACH(10) /          2 /
! !     DATA IMACH(11) /         27 /
! !     DATA IMACH(12) /       -128 /
! !     DATA IMACH(13) /        127 /
! !     DATA IMACH(14) /         60 /
! !     DATA IMACH(15) /      -1024 /
! !     DATA IMACH(16) /       1023 /
! !
! !     MACHINE CONSTANTS FOR THE Z80 MICROPROCESSOR
! !
! !     DATA IMACH( 1) /          1 /
! !     DATA IMACH( 2) /          1 /
! !     DATA IMACH( 3) /          0 /
! !     DATA IMACH( 4) /          1 /
! !     DATA IMACH( 5) /         16 /
! !     DATA IMACH( 6) /          2 /
! !     DATA IMACH( 7) /          2 /
! !     DATA IMACH( 8) /         15 /
! !     DATA IMACH( 9) /      32767 /
! !     DATA IMACH(10) /          2 /
! !     DATA IMACH(11) /         24 /
! !     DATA IMACH(12) /       -127 /
! !     DATA IMACH(13) /        127 /
! !     DATA IMACH(14) /         56 /
! !     DATA IMACH(15) /       -127 /
! !     DATA IMACH(16) /        127 /
! !
! !***FIRST EXECUTABLE STATEMENT  I1MACH
! !
!   if ( I < 1 .OR. I > 16 ) then
!     WRITE (UNIT = OUTPUT, FMT = 9000)
!  9000 FORMAT ('1ERROR    1 IN I1MACH - I OUT OF BOUNDS')
!     STOP
!   end if
!
!   I1MACH = IMACH(I)
!
!   return
! end

subroutine DJAIRY (X, RX, C, AI, DAI)
!
!! DJAIRY is subsidiary to DBESJ and DBESY.
!
!***LIBRARY   SLATEC
!***TYPE      DOUBLE PRECISION (JAIRY-S, DJAIRY-D)
!***AUTHOR  Amos, D. E., (SNLA)
!           Daniel, S. L., (SNLA)
!           Weston, M. K., (SNLA)
!***DESCRIPTION
!
!                  DJAIRY computes the Airy function AI(X)
!                   and its derivative DAI(X) for DASYJY
!
!                                   INPUT
!
!         X - Argument, computed by DASYJY, X unrestricted
!        RX - RX=SQRT(ABS(X)), computed by DASYJY
!         C - C=2.*(ABS(X)**1.5)/3., computed by DASYJY
!
!                                  OUTPUT
!
!        AI - Value of function AI(X)
!       DAI - Value of the derivative DAI(X)
!
!***SEE ALSO  DBESJ, DBESY
!***ROUTINES CALLED  (NONE)
!***REVISION HISTORY  (YYMMDD)
!   750101  DATE WRITTEN
!   890531  Changed all specific intrinsics to generic.  (WRB)
!   891009  Removed unreferenced variable.  (WRB)
!   891214  Prologue converted to Version 4.0 format.  (BAB)
!   900328  Added TYPE section.  (WRB)
!   910408  Updated the AUTHOR section.  (WRB)
!***END PROLOGUE  DJAIRY
!
  INTEGER I, J, M1, M1D, M2, M2D, M3, M3D, M4, M4D, N1, N1D, N2, &
   N2D, N3, N3D, N4, N4D
  DOUBLE PRECISION A,AI,AJN,AJP,AK1,AK2,AK3,B,C,CCV,CON2, &
   CON3, CON4, CON5, CV, DA, DAI, DAJN, DAJP, DAK1, DAK2, DAK3, &
   DB, EC, E1, E2, FPI12, F1, F2, RTRX, RX, SCV, T, TEMP1, TEMP2, &
   TT, X
  DIMENSION AJP(19), AJN(19), A(15), B(15)
  DIMENSION AK1(14), AK2(23), AK3(14)
  DIMENSION DAJP(19), DAJN(19), DA(15), DB(15)
  DIMENSION DAK1(14), DAK2(24), DAK3(14)
  SAVE N1, N2, N3, N4, M1, M2, M3, M4, FPI12, CON2, CON3, &
   CON4, CON5, AK1, AK2, AK3, AJP, AJN, A, B, &
   N1D, N2D, N3D, N4D, M1D, M2D, M3D, M4D, DAK1, DAK2, DAK3, &
   DAJP, DAJN, DA, DB
  DATA N1,N2,N3,N4/14,23,19,15/
  DATA M1,M2,M3,M4/12,21,17,13/
  DATA FPI12,CON2,CON3,CON4,CON5/ &
   1.30899693899575D+00, 5.03154716196777D+00, 3.80004589867293D-01, &
   8.33333333333333D-01, 8.66025403784439D-01/
  DATA AK1(1), AK1(2), AK1(3), AK1(4), AK1(5), AK1(6), AK1(7), &
       AK1(8), AK1(9), AK1(10),AK1(11),AK1(12),AK1(13), &
       AK1(14)         / 2.20423090987793D-01,-1.25290242787700D-01, &
   1.03881163359194D-02, 8.22844152006343D-04,-2.34614345891226D-04, &
   1.63824280172116D-05, 3.06902589573189D-07,-1.29621999359332D-07, &
   8.22908158823668D-09, 1.53963968623298D-11,-3.39165465615682D-11, &
   2.03253257423626D-12,-1.10679546097884D-14,-5.16169497785080D-15/
  DATA AK2(1), AK2(2), AK2(3), AK2(4), AK2(5), AK2(6), AK2(7), &
       AK2(8), AK2(9), AK2(10),AK2(11),AK2(12),AK2(13),AK2(14), &
       AK2(15),AK2(16),AK2(17),AK2(18),AK2(19),AK2(20),AK2(21), &
       AK2(22),AK2(23) / 2.74366150869598D-01, 5.39790969736903D-03, &
  -1.57339220621190D-03, 4.27427528248750D-04,-1.12124917399925D-04, &
   2.88763171318904D-05,-7.36804225370554D-06, 1.87290209741024D-06, &
  -4.75892793962291D-07, 1.21130416955909D-07,-3.09245374270614D-08, &
   7.92454705282654D-09,-2.03902447167914D-09, 5.26863056595742D-10, &
  -1.36704767639569D-10, 3.56141039013708D-11,-9.31388296548430D-12, &
   2.44464450473635D-12,-6.43840261990955D-13, 1.70106030559349D-13, &
  -4.50760104503281D-14, 1.19774799164811D-14,-3.19077040865066D-15/
  DATA AK3(1), AK3(2), AK3(3), AK3(4), AK3(5), AK3(6), AK3(7), &
       AK3(8), AK3(9), AK3(10),AK3(11),AK3(12),AK3(13), &
       AK3(14)         / 2.80271447340791D-01,-1.78127042844379D-03, &
   4.03422579628999D-05,-1.63249965269003D-06, 9.21181482476768D-08, &
  -6.52294330229155D-09, 5.47138404576546D-10,-5.24408251800260D-11, &
   5.60477904117209D-12,-6.56375244639313D-13, 8.31285761966247D-14, &
  -1.12705134691063D-14, 1.62267976598129D-15,-2.46480324312426D-16/
  DATA AJP(1), AJP(2), AJP(3), AJP(4), AJP(5), AJP(6), AJP(7), &
       AJP(8), AJP(9), AJP(10),AJP(11),AJP(12),AJP(13),AJP(14), &
       AJP(15),AJP(16),AJP(17),AJP(18), &
       AJP(19)         / 7.78952966437581D-02,-1.84356363456801D-01, &
   3.01412605216174D-02, 3.05342724277608D-02,-4.95424702513079D-03, &
  -1.72749552563952D-03, 2.43137637839190D-04, 5.04564777517082D-05, &
  -6.16316582695208D-06,-9.03986745510768D-07, 9.70243778355884D-08, &
   1.09639453305205D-08,-1.04716330588766D-09,-9.60359441344646D-11, &
   8.25358789454134D-12, 6.36123439018768D-13,-4.96629614116015D-14, &
  -3.29810288929615D-15, 2.35798252031104D-16/
  DATA AJN(1), AJN(2), AJN(3), AJN(4), AJN(5), AJN(6), AJN(7), &
       AJN(8), AJN(9), AJN(10),AJN(11),AJN(12),AJN(13),AJN(14), &
       AJN(15),AJN(16),AJN(17),AJN(18), &
       AJN(19)         / 3.80497887617242D-02,-2.45319541845546D-01, &
   1.65820623702696D-01, 7.49330045818789D-02,-2.63476288106641D-02, &
  -5.92535597304981D-03, 1.44744409589804D-03, 2.18311831322215D-04, &
  -4.10662077680304D-05,-4.66874994171766D-06, 7.15218807277160D-07, &
   6.52964770854633D-08,-8.44284027565946D-09,-6.44186158976978D-10, &
   7.20802286505285D-11, 4.72465431717846D-12,-4.66022632547045D-13, &
  -2.67762710389189D-14, 2.36161316570019D-15/
  DATA A(1),   A(2),   A(3),   A(4),   A(5),   A(6),   A(7), &
       A(8),   A(9),   A(10),  A(11),  A(12),  A(13),  A(14), &
       A(15)           / 4.90275424742791D-01, 1.57647277946204D-03, &
  -9.66195963140306D-05, 1.35916080268815D-07, 2.98157342654859D-07, &
  -1.86824767559979D-08,-1.03685737667141D-09, 3.28660818434328D-10, &
  -2.57091410632780D-11,-2.32357655300677D-12, 9.57523279048255D-13, &
  -1.20340828049719D-13,-2.90907716770715D-15, 4.55656454580149D-15, &
  -9.99003874810259D-16/
  DATA B(1),   B(2),   B(3),   B(4),   B(5),   B(6),   B(7), &
       B(8),   B(9),   B(10),  B(11),  B(12),  B(13),  B(14), &
       B(15)           / 2.78593552803079D-01,-3.52915691882584D-03, &
  -2.31149677384994D-05, 4.71317842263560D-06,-1.12415907931333D-07, &
  -2.00100301184339D-08, 2.60948075302193D-09,-3.55098136101216D-11, &
  -3.50849978423875D-11, 5.83007187954202D-12,-2.04644828753326D-13, &
  -1.10529179476742D-13, 2.87724778038775D-14,-2.88205111009939D-15, &
  -3.32656311696166D-16/
  DATA N1D,N2D,N3D,N4D/14,24,19,15/
  DATA M1D,M2D,M3D,M4D/12,22,17,13/
  DATA DAK1(1), DAK1(2), DAK1(3), DAK1(4), DAK1(5), DAK1(6), &
       DAK1(7), DAK1(8), DAK1(9), DAK1(10),DAK1(11),DAK1(12), &
      DAK1(13),DAK1(14)/ 2.04567842307887D-01,-6.61322739905664D-02, &
  -8.49845800989287D-03, 3.12183491556289D-03,-2.70016489829432D-04, &
  -6.35636298679387D-06, 3.02397712409509D-06,-2.18311195330088D-07, &
  -5.36194289332826D-10, 1.13098035622310D-09,-7.43023834629073D-11, &
   4.28804170826891D-13, 2.23810925754539D-13,-1.39140135641182D-14/
  DATA DAK2(1), DAK2(2), DAK2(3), DAK2(4), DAK2(5), DAK2(6), &
       DAK2(7), DAK2(8), DAK2(9), DAK2(10),DAK2(11),DAK2(12), &
       DAK2(13),DAK2(14),DAK2(15),DAK2(16),DAK2(17),DAK2(18), &
       DAK2(19),DAK2(20),DAK2(21),DAK2(22),DAK2(23), &
       DAK2(24)        / 2.93332343883230D-01,-8.06196784743112D-03, &
   2.42540172333140D-03,-6.82297548850235D-04, 1.85786427751181D-04, &
  -4.97457447684059D-05, 1.32090681239497D-05,-3.49528240444943D-06, &
   9.24362451078835D-07,-2.44732671521867D-07, 6.49307837648910D-08, &
  -1.72717621501538D-08, 4.60725763604656D-09,-1.23249055291550D-09, &
   3.30620409488102D-10,-8.89252099772401D-11, 2.39773319878298D-11, &
  -6.48013921153450D-12, 1.75510132023731D-12,-4.76303829833637D-13, &
   1.29498241100810D-13,-3.52679622210430D-14, 9.62005151585923D-15, &
  -2.62786914342292D-15/
  DATA DAK3(1), DAK3(2), DAK3(3), DAK3(4), DAK3(5), DAK3(6), &
       DAK3(7), DAK3(8), DAK3(9), DAK3(10),DAK3(11),DAK3(12), &
      DAK3(13),DAK3(14)/ 2.84675828811349D-01, 2.53073072619080D-03, &
  -4.83481130337976D-05, 1.84907283946343D-06,-1.01418491178576D-07, &
   7.05925634457153D-09,-5.85325291400382D-10, 5.56357688831339D-11, &
  -5.90889094779500D-12, 6.88574353784436D-13,-8.68588256452194D-14, &
   1.17374762617213D-14,-1.68523146510923D-15, 2.55374773097056D-16/
  DATA DAJP(1), DAJP(2), DAJP(3), DAJP(4), DAJP(5), DAJP(6), &
       DAJP(7), DAJP(8), DAJP(9), DAJP(10),DAJP(11),DAJP(12), &
       DAJP(13),DAJP(14),DAJP(15),DAJP(16),DAJP(17),DAJP(18), &
       DAJP(19)        / 6.53219131311457D-02,-1.20262933688823D-01, &
   9.78010236263823D-03, 1.67948429230505D-02,-1.97146140182132D-03, &
  -8.45560295098867D-04, 9.42889620701976D-05, 2.25827860945475D-05, &
  -2.29067870915987D-06,-3.76343991136919D-07, 3.45663933559565D-08, &
   4.29611332003007D-09,-3.58673691214989D-10,-3.57245881361895D-11, &
   2.72696091066336D-12, 2.26120653095771D-13,-1.58763205238303D-14, &
  -1.12604374485125D-15, 7.31327529515367D-17/
  DATA DAJN(1), DAJN(2), DAJN(3), DAJN(4), DAJN(5), DAJN(6), &
       DAJN(7), DAJN(8), DAJN(9), DAJN(10),DAJN(11),DAJN(12), &
       DAJN(13),DAJN(14),DAJN(15),DAJN(16),DAJN(17),DAJN(18), &
       DAJN(19)        / 1.08594539632967D-02, 8.53313194857091D-02, &
  -3.15277068113058D-01,-8.78420725294257D-02, 5.53251906976048D-02, &
   9.41674060503241D-03,-3.32187026018996D-03,-4.11157343156826D-04, &
   1.01297326891346D-04, 9.87633682208396D-06,-1.87312969812393D-06, &
  -1.50798500131468D-07, 2.32687669525394D-08, 1.59599917419225D-09, &
  -2.07665922668385D-10,-1.24103350500302D-11, 1.39631765331043D-12, &
   7.39400971155740D-14,-7.32887475627500D-15/
  DATA DA(1),  DA(2),  DA(3),  DA(4),  DA(5),  DA(6),  DA(7), &
       DA(8),  DA(9),  DA(10), DA(11), DA(12), DA(13), DA(14), &
       DA(15)          / 4.91627321104601D-01, 3.11164930427489D-03, &
   8.23140762854081D-05,-4.61769776172142D-06,-6.13158880534626D-08, &
   2.87295804656520D-08,-1.81959715372117D-09,-1.44752826642035D-10, &
   4.53724043420422D-11,-3.99655065847223D-12,-3.24089119830323D-13, &
   1.62098952568741D-13,-2.40765247974057D-14, 1.69384811284491D-16, &
   8.17900786477396D-16/
  DATA DB(1),  DB(2),  DB(3),  DB(4),  DB(5),  DB(6),  DB(7), &
       DB(8),  DB(9),  DB(10), DB(11), DB(12), DB(13), DB(14), &
       DB(15)          /-2.77571356944231D-01, 4.44212833419920D-03, &
  -8.42328522190089D-05,-2.58040318418710D-06, 3.42389720217621D-07, &
  -6.24286894709776D-09,-2.36377836844577D-09, 3.16991042656673D-10, &
  -4.40995691658191D-12,-5.18674221093575D-12, 9.64874015137022D-13, &
  -4.90190576608710D-14,-1.77253430678112D-14, 5.55950610442662D-15, &
  -7.11793337579530D-16/
!***FIRST EXECUTABLE STATEMENT  DJAIRY
  if (X < 0.0D0) go to 90
  if (C > 5.0D0) go to 60
  if (X > 1.20D0) go to 30
  T = (X+X-1.2D0)*CON4
  TT = T + T
  J = N1
  F1 = AK1(J)
  F2 = 0.0D0
  DO 10 I=1,M1
    J = J - 1
    TEMP1 = F1
    F1 = TT*F1 - F2 + AK1(J)
    F2 = TEMP1
   10 CONTINUE
  AI = T*F1 - F2 + AK1(1)
!
  J = N1D
  F1 = DAK1(J)
  F2 = 0.0D0
  DO 20 I=1,M1D
    J = J - 1
    TEMP1 = F1
    F1 = TT*F1 - F2 + DAK1(J)
    F2 = TEMP1
   20 CONTINUE
  DAI = -(T*F1-F2+DAK1(1))
  return
!
   30 CONTINUE
  T = (X+X-CON2)*CON3
  TT = T + T
  J = N2
  F1 = AK2(J)
  F2 = 0.0D0
  DO 40 I=1,M2
    J = J - 1
    TEMP1 = F1
    F1 = TT*F1 - F2 + AK2(J)
    F2 = TEMP1
   40 CONTINUE
  RTRX = SQRT(RX)
  EC = EXP(-C)
  AI = EC*(T*F1-F2+AK2(1))/RTRX
  J = N2D
  F1 = DAK2(J)
  F2 = 0.0D0
  DO 50 I=1,M2D
    J = J - 1
    TEMP1 = F1
    F1 = TT*F1 - F2 + DAK2(J)
    F2 = TEMP1
   50 CONTINUE
  DAI = -EC*(T*F1-F2+DAK2(1))*RTRX
  return
!
   60 CONTINUE
  T = 10.0D0/C - 1.0D0
  TT = T + T
  J = N1
  F1 = AK3(J)
  F2 = 0.0D0
  DO 70 I=1,M1
    J = J - 1
    TEMP1 = F1
    F1 = TT*F1 - F2 + AK3(J)
    F2 = TEMP1
   70 CONTINUE
  RTRX = SQRT(RX)
  EC = EXP(-C)
  AI = EC*(T*F1-F2+AK3(1))/RTRX
  J = N1D
  F1 = DAK3(J)
  F2 = 0.0D0
  DO 80 I=1,M1D
    J = J - 1
    TEMP1 = F1
    F1 = TT*F1 - F2 + DAK3(J)
    F2 = TEMP1
   80 CONTINUE
  DAI = -RTRX*EC*(T*F1-F2+DAK3(1))
  return
!
   90 CONTINUE
  if (C > 5.0D0) go to 120
  T = 0.4D0*C - 1.0D0
  TT = T + T
  J = N3
  F1 = AJP(J)
  E1 = AJN(J)
  F2 = 0.0D0
  E2 = 0.0D0
  DO 100 I=1,M3
    J = J - 1
    TEMP1 = F1
    TEMP2 = E1
    F1 = TT*F1 - F2 + AJP(J)
    E1 = TT*E1 - E2 + AJN(J)
    F2 = TEMP1
    E2 = TEMP2
  100 CONTINUE
  AI = (T*E1-E2+AJN(1)) - X*(T*F1-F2+AJP(1))
  J = N3D
  F1 = DAJP(J)
  E1 = DAJN(J)
  F2 = 0.0D0
  E2 = 0.0D0
  DO 110 I=1,M3D
    J = J - 1
    TEMP1 = F1
    TEMP2 = E1
    F1 = TT*F1 - F2 + DAJP(J)
    E1 = TT*E1 - E2 + DAJN(J)
    F2 = TEMP1
    E2 = TEMP2
  110 CONTINUE
  DAI = X*X*(T*F1-F2+DAJP(1)) + (T*E1-E2+DAJN(1))
  return
!
  120 CONTINUE
  T = 10.0D0/C - 1.0D0
  TT = T + T
  J = N4
  F1 = A(J)
  E1 = B(J)
  F2 = 0.0D0
  E2 = 0.0D0
  DO 130 I=1,M4
    J = J - 1
    TEMP1 = F1
    TEMP2 = E1
    F1 = TT*F1 - F2 + A(J)
    E1 = TT*E1 - E2 + B(J)
    F2 = TEMP1
    E2 = TEMP2
  130 CONTINUE
  TEMP1 = T*F1 - F2 + A(1)
  TEMP2 = T*E1 - E2 + B(1)
  RTRX = SQRT(RX)
  CV = C - FPI12
  CCV = COS(CV)
  SCV = SIN(CV)
  AI = (TEMP1*CCV-TEMP2*SCV)/RTRX
  J = N4D
  F1 = DA(J)
  E1 = DB(J)
  F2 = 0.0D0
  E2 = 0.0D0
  DO 140 I=1,M4D
    J = J - 1
    TEMP1 = F1
    TEMP2 = E1
    F1 = TT*F1 - F2 + DA(J)
    E1 = TT*E1 - E2 + DB(J)
    F2 = TEMP1
    E2 = TEMP2
  140 CONTINUE
  TEMP1 = T*F1 - F2 + DA(1)
  TEMP2 = T*E1 - E2 + DB(1)
  E1 = CCV*CON5 + 0.5D0*SCV
  E2 = SCV*CON5 - 0.5D0*CCV
  DAI = (TEMP1*E1-TEMP2*E2)*RTRX
  return
end

  DOUBLE PRECISION FUNCTION DLNGAM (X)
!
!! DLNGAM computes the logarithm of the absolute value of the Gamma function.
!
!***LIBRARY   SLATEC (FNLIB)
!***CATEGORY  C7A
!***TYPE      DOUBLE PRECISION (ALNGAM-S, DLNGAM-D, CLNGAM-C)
!***KEYWORDS  ABSOLUTE VALUE, COMPLETE GAMMA FUNCTION, FNLIB, LOGARITHM,
!             SPECIAL FUNCTIONS
!***AUTHOR  Fullerton, W., (LANL)
!***DESCRIPTION
!
! DLNGAM(X) calculates the double precision logarithm of the
! absolute value of the Gamma function for double precision
! argument X.
!
!***REFERENCES  (NONE)
!***ROUTINES CALLED  D1MACH, D9LGMC, DGAMMA, XERMSG
!***REVISION HISTORY  (YYMMDD)
!   770601  DATE WRITTEN
!   890531  Changed all specific intrinsics to generic.  (WRB)
!   890531  REVISION DATE from Version 3.2
!   891214  Prologue converted to Version 4.0 format.  (BAB)
!   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
!   900727  Added EXTERNAL statement.  (WRB)
!***END PROLOGUE  DLNGAM
  DOUBLE PRECISION X, DXREL, PI, SINPIY, SQPI2L, SQ2PIL, XMAX, &
    Y, DGAMMA, D9LGMC, D1MACH, TEMP
  LOGICAL FIRST
  EXTERNAL DGAMMA
  SAVE SQ2PIL, SQPI2L, PI, XMAX, DXREL, FIRST
  DATA SQ2PIL / 0.91893853320467274178032973640562D0 /
  DATA SQPI2L / +.225791352644727432363097614947441D+0    /
  DATA PI / 3.14159265358979323846264338327950D0 /
  DATA FIRST /.TRUE./
!***FIRST EXECUTABLE STATEMENT  DLNGAM
  if (FIRST) THEN
     TEMP = 1.D0/LOG(D1MACH(2))
     XMAX = TEMP*D1MACH(2)
     DXREL = SQRT(D1MACH(4))
  end if
  FIRST = .FALSE.
!
  Y = ABS (X)
  if (Y > 10.D0) go to 20
!
! LOG (ABS (DGAMMA(X)) ) FOR ABS(X)  <=  10.0
!
  DLNGAM = LOG (ABS (DGAMMA(X)) )
  return
!
! LOG ( ABS (DGAMMA(X)) ) FOR ABS(X)  >  10.0
!
 20   if (Y  >  XMAX) call XERMSG ('SLATEC', 'DLNGAM', &
     'ABS(X) SO BIG DLNGAM OVERFLOWS', 2, 2)
!
  if (X > 0.D0) DLNGAM = SQ2PIL + (X-0.5D0)*LOG(X) - X + D9LGMC(Y)
  if (X > 0.D0) RETURN
!
  SINPIY = ABS (SIN(PI*Y))
  if (SINPIY  ==  0.D0) call XERMSG ('SLATEC', 'DLNGAM', &
     'X IS A NEGATIVE INTEGER', 3, 2)
!
  if (ABS((X-AINT(X-0.5D0))/X)  <  DXREL) call XERMSG ('SLATEC', &
     'DLNGAM', &
     'ANSWER LT HALF PRECISION BECAUSE X TOO NEAR NEGATIVE INTEGER', &
     1, 1)
!
  DLNGAM = SQPI2L + (X-0.5D0)*LOG(Y) - X - LOG(SINPIY) - D9LGMC(Y)
  return
!
end

  DOUBLE PRECISION FUNCTION D9LGMC (X)
!
!! D9LGMC computes the log Gamma correction factor so that ...
!  LOG(DGAMMA(X)) = LOG(SQRT(2*PI)) + (X-5.)*LOG(X) - X + D9LGMC(X).
!
!***LIBRARY   SLATEC (FNLIB)
!***CATEGORY  C7E
!***TYPE      DOUBLE PRECISION (R9LGMC-S, D9LGMC-D, C9LGMC-C)
!***KEYWORDS  COMPLETE GAMMA FUNCTION, CORRECTION TERM, FNLIB,
!             LOG GAMMA, LOGARITHM, SPECIAL FUNCTIONS
!***AUTHOR  Fullerton, W., (LANL)
!***DESCRIPTION
!
! Compute the log gamma correction factor for X  >=  10. so that
! LOG (DGAMMA(X)) = LOG(SQRT(2*PI)) + (X-.5)*LOG(X) - X + D9lGMC(X)
!
! Series for ALGM       on the interval  0.          to  1.00000E-02
!                                        with weighted error   1.28E-31
!                                         log weighted error  30.89
!                               significant figures required  29.81
!                                    decimal places required  31.48
!
!***REFERENCES  (NONE)
!***ROUTINES CALLED  D1MACH, DCSEVL, INITDS, XERMSG
!***REVISION HISTORY  (YYMMDD)
!   770601  DATE WRITTEN
!   890531  Changed all specific intrinsics to generic.  (WRB)
!   890531  REVISION DATE from Version 3.2
!   891214  Prologue converted to Version 4.0 format.  (BAB)
!   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
!   900720  Routine changed from user-callable to subsidiary.  (WRB)
!***END PROLOGUE  D9LGMC
  DOUBLE PRECISION X, ALGMCS(15), XBIG, XMAX, DCSEVL, D1MACH
  LOGICAL FIRST
  SAVE ALGMCS, NALGM, XBIG, XMAX, FIRST
  DATA ALGMCS(  1) / +.1666389480451863247205729650822D+0      /
  DATA ALGMCS(  2) / -.1384948176067563840732986059135D-4      /
  DATA ALGMCS(  3) / +.9810825646924729426157171547487D-8      /
  DATA ALGMCS(  4) / -.1809129475572494194263306266719D-10     /
  DATA ALGMCS(  5) / +.6221098041892605227126015543416D-13     /
  DATA ALGMCS(  6) / -.3399615005417721944303330599666D-15     /
  DATA ALGMCS(  7) / +.2683181998482698748957538846666D-17     /
  DATA ALGMCS(  8) / -.2868042435334643284144622399999D-19     /
  DATA ALGMCS(  9) / +.3962837061046434803679306666666D-21     /
  DATA ALGMCS( 10) / -.6831888753985766870111999999999D-23     /
  DATA ALGMCS( 11) / +.1429227355942498147573333333333D-24     /
  DATA ALGMCS( 12) / -.3547598158101070547199999999999D-26     /
  DATA ALGMCS( 13) / +.1025680058010470912000000000000D-27     /
  DATA ALGMCS( 14) / -.3401102254316748799999999999999D-29     /
  DATA ALGMCS( 15) / +.1276642195630062933333333333333D-30     /
  DATA FIRST /.TRUE./
!***FIRST EXECUTABLE STATEMENT  D9LGMC
  if (FIRST) THEN
     NALGM = INITDS (ALGMCS, 15, REAL(D1MACH(3)) )
     XBIG = 1.0D0/SQRT(D1MACH(3))
     XMAX = EXP (MIN(LOG(D1MACH(2)/12.D0), -LOG(12.D0*D1MACH(1))))
  end if
  FIRST = .FALSE.
!
  if (X  <  10.D0) call XERMSG ('SLATEC', 'D9LGMC', &
     'X MUST BE GE 10', 1, 2)
  if (X >= XMAX) go to 20
!
  D9LGMC = 1.D0/(12.D0*X)
  if (X < XBIG) D9LGMC = DCSEVL (2.0D0*(10.D0/X)**2-1.D0, ALGMCS, &
    NALGM) / X
  return
!
 20   D9LGMC = 0.D0
  call XERMSG ('SLATEC', 'D9LGMC', 'X SO BIG D9LGMC UNDERFLOWS', 2, &
     1)
  return
!
end

  DOUBLE PRECISION FUNCTION DCSEVL (X, CS, N)
!
!! DCSEVL evaluates a Chebyshev series.
!
!***LIBRARY   SLATEC (FNLIB)
!***CATEGORY  C3A2
!***TYPE      DOUBLE PRECISION (CSEVL-S, DCSEVL-D)
!***KEYWORDS  CHEBYSHEV SERIES, FNLIB, SPECIAL FUNCTIONS
!***AUTHOR  Fullerton, W., (LANL)
!***DESCRIPTION
!
!  Evaluate the N-term Chebyshev series CS at X.  Adapted from
!  a method presented in the paper by Broucke referenced below.
!
!       Input Arguments --
!  X    value at which the series is to be evaluated.
!  CS   array of N terms of a Chebyshev series.  In evaluating
!       CS, only half the first coefficient is summed.
!  N    number of terms in array CS.
!
!***REFERENCES  R. Broucke, Ten subroutines for the manipulation of
!                 Chebyshev series, Algorithm 446, Communications of
!                 the A.C.M. 16, (1973) pp. 254-256.
!               L. Fox and I. B. Parker, Chebyshev Polynomials in
!                 Numerical Analysis, Oxford University Press, 1968,
!                 page 56.
!***ROUTINES CALLED  D1MACH, XERMSG
!***REVISION HISTORY  (YYMMDD)
!   770401  DATE WRITTEN
!   890831  Modified array declarations.  (WRB)
!   890831  REVISION DATE from Version 3.2
!   891214  Prologue converted to Version 4.0 format.  (BAB)
!   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
!   900329  Prologued revised extensively and code rewritten to allow
!           X to be slightly outside interval (-1,+1).  (WRB)
!   920501  Reformatted the REFERENCES section.  (WRB)
!***END PROLOGUE  DCSEVL
  DOUBLE PRECISION B0, B1, B2, CS(*), ONEPL, TWOX, X, D1MACH
  LOGICAL FIRST
  SAVE FIRST, ONEPL
  DATA FIRST /.TRUE./
!***FIRST EXECUTABLE STATEMENT  DCSEVL
  if (FIRST) ONEPL = 1.0D0 + D1MACH(4)
  FIRST = .FALSE.
  if (N  <  1) call XERMSG ('SLATEC', 'DCSEVL', &
     'NUMBER OF TERMS  <=  0', 2, 2)
  if (N  >  1000) call XERMSG ('SLATEC', 'DCSEVL', &
     'NUMBER OF TERMS  >  1000', 3, 2)
  if (ABS(X)  >  ONEPL) call XERMSG ('SLATEC', 'DCSEVL', &
     'X OUTSIDE THE INTERVAL (-1,+1)', 1, 1)
!
  B1 = 0.0D0
  B0 = 0.0D0
  TWOX = 2.0D0*X
  DO 10 I = 1,N
     B2 = B1
     B1 = B0
     NI = N + 1 - I
     B0 = TWOX*B1 - B2 + CS(NI)
   10 CONTINUE
!
  DCSEVL = 0.5D0*(B0-B2)
!
  return
end

function INITDS (OS, NOS, ETA)
!
!! INITDS determines the number of terms needed in an orthogonal ...
!            polynomial series so that it meets a specified accuracy.
!
!***LIBRARY   SLATEC (FNLIB)
!***CATEGORY  C3A2
!***TYPE      DOUBLE PRECISION (INITS-S, INITDS-D)
!***KEYWORDS  CHEBYSHEV, FNLIB, INITIALIZE, ORTHOGONAL POLYNOMIAL,
!             ORTHOGONAL SERIES, SPECIAL FUNCTIONS
!***AUTHOR  Fullerton, W., (LANL)
!***DESCRIPTION
!
!  Initialize the orthogonal series, represented by the array OS, so
!  that INITDS is the number of terms needed to insure the error is no
!  larger than ETA.  Ordinarily, ETA will be chosen to be one-tenth
!  machine precision.
!
!             Input Arguments --
!   OS     double precision array of NOS coefficients in an orthogonal
!          series.
!   NOS    number of coefficients in OS.
!   ETA    single precision scalar containing requested accuracy of
!          series.
!
!***REFERENCES  (NONE)
!***ROUTINES CALLED  XERMSG
!***REVISION HISTORY  (YYMMDD)
!   770601  DATE WRITTEN
!   890531  Changed all specific intrinsics to generic.  (WRB)
!   890831  Modified array declarations.  (WRB)
!   891115  Modified error message.  (WRB)
!   891115  REVISION DATE from Version 3.2
!   891214  Prologue converted to Version 4.0 format.  (BAB)
!   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
!***END PROLOGUE  INITDS
  DOUBLE PRECISION OS(*)
!***FIRST EXECUTABLE STATEMENT  INITDS
  if (NOS  <  1) call XERMSG ('SLATEC', 'INITDS', &
     'Number of coefficients is less than 1', 2, 1)
!
  ERR = 0.
  DO 10 II = 1,NOS
    I = NOS + 1 - II
    ERR = ERR + ABS(REAL(OS(I)))
    if (ERR > ETA) go to 20
   10 CONTINUE
!
   20 if (I  ==  NOS) call XERMSG ('SLATEC', 'INITDS', &
     'Chebyshev series too short for specified accuracy', 1, 1)
  INITDS = I
!
  return
end

  DOUBLE PRECISION FUNCTION DGAMMA (X)
!
!! DGAMMA computes the complete Gamma function.
!
!***LIBRARY   SLATEC (FNLIB)
!***CATEGORY  C7A
!***TYPE      DOUBLE PRECISION (GAMMA-S, DGAMMA-D, CGAMMA-C)
!***KEYWORDS  COMPLETE GAMMA FUNCTION, FNLIB, SPECIAL FUNCTIONS
!***AUTHOR  Fullerton, W., (LANL)
!***DESCRIPTION
!
! DGAMMA(X) calculates the double precision complete Gamma function
! for double precision argument X.
!
! Series for GAM        on the interval  0.          to  1.00000E+00
!                                        with weighted error   5.79E-32
!                                         log weighted error  31.24
!                               significant figures required  30.00
!                                    decimal places required  32.05
!
!***REFERENCES  (NONE)
!***ROUTINES CALLED  D1MACH, D9LGMC, DCSEVL, DGAMLM, INITDS, XERMSG
!***REVISION HISTORY  (YYMMDD)
!   770601  DATE WRITTEN
!   890531  Changed all specific intrinsics to generic.  (WRB)
!   890911  Removed unnecessary intrinsics.  (WRB)
!   890911  REVISION DATE from Version 3.2
!   891214  Prologue converted to Version 4.0 format.  (BAB)
!   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
!   920618  Removed space from variable name.  (RWC, WRB)
!***END PROLOGUE  DGAMMA
  DOUBLE PRECISION X, GAMCS(42), DXREL, PI, SINPIY, SQ2PIL, XMAX, &
    XMIN, Y, D9LGMC, DCSEVL, D1MACH
  LOGICAL FIRST
!
  SAVE GAMCS, PI, SQ2PIL, NGAM, XMIN, XMAX, DXREL, FIRST
  DATA GAMCS(  1) / +.8571195590989331421920062399942D-2      /
  DATA GAMCS(  2) / +.4415381324841006757191315771652D-2      /
  DATA GAMCS(  3) / +.5685043681599363378632664588789D-1      /
  DATA GAMCS(  4) / -.4219835396418560501012500186624D-2      /
  DATA GAMCS(  5) / +.1326808181212460220584006796352D-2      /
  DATA GAMCS(  6) / -.1893024529798880432523947023886D-3      /
  DATA GAMCS(  7) / +.3606925327441245256578082217225D-4      /
  DATA GAMCS(  8) / -.6056761904460864218485548290365D-5      /
  DATA GAMCS(  9) / +.1055829546302283344731823509093D-5      /
  DATA GAMCS( 10) / -.1811967365542384048291855891166D-6      /
  DATA GAMCS( 11) / +.3117724964715322277790254593169D-7      /
  DATA GAMCS( 12) / -.5354219639019687140874081024347D-8      /
  DATA GAMCS( 13) / +.9193275519859588946887786825940D-9      /
  DATA GAMCS( 14) / -.1577941280288339761767423273953D-9      /
  DATA GAMCS( 15) / +.2707980622934954543266540433089D-10     /
  DATA GAMCS( 16) / -.4646818653825730144081661058933D-11     /
  DATA GAMCS( 17) / +.7973350192007419656460767175359D-12     /
  DATA GAMCS( 18) / -.1368078209830916025799499172309D-12     /
  DATA GAMCS( 19) / +.2347319486563800657233471771688D-13     /
  DATA GAMCS( 20) / -.4027432614949066932766570534699D-14     /
  DATA GAMCS( 21) / +.6910051747372100912138336975257D-15     /
  DATA GAMCS( 22) / -.1185584500221992907052387126192D-15     /
  DATA GAMCS( 23) / +.2034148542496373955201026051932D-16     /
  DATA GAMCS( 24) / -.3490054341717405849274012949108D-17     /
  DATA GAMCS( 25) / +.5987993856485305567135051066026D-18     /
  DATA GAMCS( 26) / -.1027378057872228074490069778431D-18     /
  DATA GAMCS( 27) / +.1762702816060529824942759660748D-19     /
  DATA GAMCS( 28) / -.3024320653735306260958772112042D-20     /
  DATA GAMCS( 29) / +.5188914660218397839717833550506D-21     /
  DATA GAMCS( 30) / -.8902770842456576692449251601066D-22     /
  DATA GAMCS( 31) / +.1527474068493342602274596891306D-22     /
  DATA GAMCS( 32) / -.2620731256187362900257328332799D-23     /
  DATA GAMCS( 33) / +.4496464047830538670331046570666D-24     /
  DATA GAMCS( 34) / -.7714712731336877911703901525333D-25     /
  DATA GAMCS( 35) / +.1323635453126044036486572714666D-25     /
  DATA GAMCS( 36) / -.2270999412942928816702313813333D-26     /
  DATA GAMCS( 37) / +.3896418998003991449320816639999D-27     /
  DATA GAMCS( 38) / -.6685198115125953327792127999999D-28     /
  DATA GAMCS( 39) / +.1146998663140024384347613866666D-28     /
  DATA GAMCS( 40) / -.1967938586345134677295103999999D-29     /
  DATA GAMCS( 41) / +.3376448816585338090334890666666D-30     /
  DATA GAMCS( 42) / -.5793070335782135784625493333333D-31     /
  DATA PI / 3.14159265358979323846264338327950D0 /
  DATA SQ2PIL / 0.91893853320467274178032973640562D0 /
  DATA FIRST /.TRUE./
!***FIRST EXECUTABLE STATEMENT  DGAMMA
  if (FIRST) THEN
     NGAM = INITDS (GAMCS, 42, 0.1*REAL(D1MACH(3)) )
!
     call DGAMLM (XMIN, XMAX)
     DXREL = SQRT(D1MACH(4))
  end if
  FIRST = .FALSE.
!
  Y = ABS(X)
  if (Y > 10.D0) go to 50
!
! COMPUTE GAMMA(X) FOR -XBND  <=  X  <=  XBND.  REDUCE INTERVAL AND FIND
! GAMMA(1+Y) FOR 0.0  <=  Y  <  1.0 FIRST OF ALL.
!
  N = X
  if (X < 0.D0) N = N - 1
  Y = X - N
  N = N - 1
  DGAMMA = 0.9375D0 + DCSEVL (2.D0*Y-1.D0, GAMCS, NGAM)
  if (N == 0) RETURN
!
  if (N > 0) go to 30
!
! COMPUTE GAMMA(X) FOR X  <  1.0
!
  N = -N
  if (X  ==  0.D0) call XERMSG ('SLATEC', 'DGAMMA', 'X IS 0', 4, 2)
  if (X  <  0.0 .AND. X+N-2  ==  0.D0) call XERMSG ('SLATEC', &
     'DGAMMA', 'X IS A NEGATIVE INTEGER', 4, 2)
  if (X  <  (-0.5D0) .AND. ABS((X-AINT(X-0.5D0))/X)  <  DXREL) &
     call XERMSG ('SLATEC', 'DGAMMA', &
     'ANSWER LT HALF PRECISION BECAUSE X TOO NEAR NEGATIVE INTEGER', &
     1, 1)
!
  DO 20 I=1,N
    DGAMMA = DGAMMA/(X+I-1 )
 20   CONTINUE
  return
!
! GAMMA(X) FOR X  >=  2.0 AND X  <=  10.0
!
 30   DO 40 I=1,N
    DGAMMA = (Y+I) * DGAMMA
 40   CONTINUE
  return
!
! GAMMA(X) FOR ABS(X)  >  10.0.  RECALL Y = ABS(X).
!
 50   if (X  >  XMAX) call XERMSG ('SLATEC', 'DGAMMA', &
     'X SO BIG GAMMA OVERFLOWS', 3, 2)
!
  DGAMMA = 0.D0
  if (X  <  XMIN) call XERMSG ('SLATEC', 'DGAMMA', &
     'X SO SMALL GAMMA UNDERFLOWS', 2, 1)
  if (X < XMIN) RETURN
!
  DGAMMA = EXP ((Y-0.5D0)*LOG(Y) - Y + SQ2PIL + D9LGMC(Y) )
  if (X > 0.D0) RETURN
!
  if (ABS((X-AINT(X-0.5D0))/X)  <  DXREL) call XERMSG ('SLATEC', &
     'DGAMMA', &
     'ANSWER LT HALF PRECISION, X TOO NEAR NEGATIVE INTEGER', 1, 1)
!
  SINPIY = SIN (PI*Y)
  if (SINPIY  ==  0.D0) call XERMSG ('SLATEC', 'DGAMMA', &
     'X IS A NEGATIVE INTEGER', 4, 2)
!
  DGAMMA = -PI/(Y*SINPIY*DGAMMA)
!
  return
end

subroutine DGAMLM (XMIN, XMAX)
!
!! DGAMLM computes bounds for the argument in the Gamma function.
!
!***LIBRARY   SLATEC (FNLIB)
!***CATEGORY  C7A, R2
!***TYPE      DOUBLE PRECISION (GAMLIM-S, DGAMLM-D)
!***KEYWORDS  COMPLETE GAMMA FUNCTION, FNLIB, LIMITS, SPECIAL FUNCTIONS
!***AUTHOR  Fullerton, W., (LANL)
!***DESCRIPTION
!
! Calculate the minimum and maximum legal bounds for X in gamma(X).
! XMIN and XMAX are not the only bounds, but they are the only non-
! trivial ones to calculate.
!
!             Output Arguments --
! XMIN   double precision minimum legal value of X in gamma(X).  Any
!        smaller value of X might result in underflow.
! XMAX   double precision maximum legal value of X in gamma(X).  Any
!        larger value of X might cause overflow.
!
!***REFERENCES  (NONE)
!***ROUTINES CALLED  D1MACH, XERMSG
!***REVISION HISTORY  (YYMMDD)
!   770601  DATE WRITTEN
!   890531  Changed all specific intrinsics to generic.  (WRB)
!   890531  REVISION DATE from Version 3.2
!   891214  Prologue converted to Version 4.0 format.  (BAB)
!   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
!***END PROLOGUE  DGAMLM
  DOUBLE PRECISION XMIN, XMAX, ALNBIG, ALNSML, XLN, XOLD, D1MACH
!***FIRST EXECUTABLE STATEMENT  DGAMLM
  ALNSML = LOG(D1MACH(1))
  XMIN = -ALNSML
  DO 10 I=1,10
    XOLD = XMIN
    XLN = LOG(XMIN)
    XMIN = XMIN - XMIN*((XMIN+0.5D0)*XLN - XMIN - 0.2258D0 + ALNSML) &
      / (XMIN*XLN+0.5D0)
    if (ABS(XMIN-XOLD) < 0.005D0) go to 20
 10   CONTINUE
  call XERMSG ('SLATEC', 'DGAMLM', 'UNABLE TO FIND XMIN', 1, 2)
!
 20   XMIN = -XMIN + 0.01D0
!
  ALNBIG = LOG (D1MACH(2))
  XMAX = ALNBIG
  DO 30 I=1,10
    XOLD = XMAX
    XLN = LOG(XMAX)
    XMAX = XMAX - XMAX*((XMAX-0.5D0)*XLN - XMAX + 0.9189D0 - ALNBIG) &
      / (XMAX*XLN-0.5D0)
    if (ABS(XMAX-XOLD) < 0.005D0) go to 40
 30   CONTINUE
  call XERMSG ('SLATEC', 'DGAMLM', 'UNABLE TO FIND XMAX', 2, 2)
!
 40   XMAX = XMAX - 0.01D0
  XMIN = MAX (XMIN, -XMAX+1.D0)
!
  return
end
  DOUBLE PRECISION FUNCTION DGAMLN (Z, IERR)
!
!! DGAMLN computes the logarithm of the Gamma function.
!
!***LIBRARY   SLATEC
!***CATEGORY  C7A
!***TYPE      DOUBLE PRECISION (GAMLN-S, DGAMLN-D)
!***KEYWORDS  LOGARITHM OF GAMMA FUNCTION
!***AUTHOR  Amos, D. E., (SNL)
!***DESCRIPTION
!
!               **** A DOUBLE PRECISION ROUTINE ****
!         DGAMLN COMPUTES THE NATURAL LOG OF THE GAMMA FUNCTION FOR
!         Z > 0.  THE ASYMPTOTIC EXPANSION IS USED TO GENERATE VALUES
!         GREATER THAN ZMIN WHICH ARE ADJUSTED BY THE RECURSION
!         G(Z+1)=Z*G(Z) FOR Z <= ZMIN.  THE FUNCTION WAS MADE AS
!         PORTABLE AS POSSIBLE BY COMPUTING ZMIN FROM THE NUMBER OF BASE
!         10 DIGITS IN A WORD, RLN=MAX(-ALOG10(R1MACH(4)),0.5E-18)
!         LIMITED TO 18 DIGITS OF (RELATIVE) ACCURACY.
!
!         SINCE INTEGER ARGUMENTS ARE COMMON, A TABLE LOOK UP ON 100
!         VALUES IS USED FOR SPEED OF EXECUTION.
!
!     DESCRIPTION OF ARGUMENTS
!
!         INPUT      Z IS DOUBLE PRECISION
!           Z      - ARGUMENT, Z > 0.0D0
!
!         OUTPUT      DGAMLN IS DOUBLE PRECISION
!           DGAMLN  - NATURAL LOG OF THE GAMMA FUNCTION AT Z /= 0.0D0
!           IERR    - ERROR FLAG
!                     IERR=0, NORMAL RETURN, COMPUTATION COMPLETED
!                     IERR=1, Z <= 0.0D0,    NO COMPUTATION
!
!
!***REFERENCES  COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT
!                 BY D. E. AMOS, SAND83-0083, MAY, 1983.
!***ROUTINES CALLED  D1MACH, I1MACH
!***REVISION HISTORY  (YYMMDD)
!   830501  DATE WRITTEN
!   830501  REVISION DATE from Version 3.2
!   910415  Prologue converted to Version 4.0 format.  (BAB)
!   920128  Category corrected.  (WRB)
!   921215  DGAMLN defined for Z negative.  (WRB)
!***END PROLOGUE  DGAMLN
  DOUBLE PRECISION CF, CON, FLN, FZ, GLN, RLN, S, TLG, TRM, TST, &
   T1, WDTOL, Z, ZDMY, ZINC, ZM, ZMIN, ZP, ZSQ, D1MACH
  INTEGER I, IERR, I1M, K, MZ, NZ, I1MACH
  DIMENSION CF(22), GLN(100)
!           LNGAMMA(N), N=1,100
  DATA GLN(1), GLN(2), GLN(3), GLN(4), GLN(5), GLN(6), GLN(7), &
       GLN(8), GLN(9), GLN(10), GLN(11), GLN(12), GLN(13), GLN(14), &
       GLN(15), GLN(16), GLN(17), GLN(18), GLN(19), GLN(20), &
       GLN(21), GLN(22)/ &
       0.00000000000000000D+00,     0.00000000000000000D+00, &
       6.93147180559945309D-01,     1.79175946922805500D+00, &
       3.17805383034794562D+00,     4.78749174278204599D+00, &
       6.57925121201010100D+00,     8.52516136106541430D+00, &
       1.06046029027452502D+01,     1.28018274800814696D+01, &
       1.51044125730755153D+01,     1.75023078458738858D+01, &
       1.99872144956618861D+01,     2.25521638531234229D+01, &
       2.51912211827386815D+01,     2.78992713838408916D+01, &
       3.06718601060806728D+01,     3.35050734501368889D+01, &
       3.63954452080330536D+01,     3.93398841871994940D+01, &
       4.23356164607534850D+01,     4.53801388984769080D+01/
  DATA GLN(23), GLN(24), GLN(25), GLN(26), GLN(27), GLN(28), &
       GLN(29), GLN(30), GLN(31), GLN(32), GLN(33), GLN(34), &
       GLN(35), GLN(36), GLN(37), GLN(38), GLN(39), GLN(40), &
       GLN(41), GLN(42), GLN(43), GLN(44)/ &
       4.84711813518352239D+01,     5.16066755677643736D+01, &
       5.47847293981123192D+01,     5.80036052229805199D+01, &
       6.12617017610020020D+01,     6.45575386270063311D+01, &
       6.78897431371815350D+01,     7.12570389671680090D+01, &
       7.46582363488301644D+01,     7.80922235533153106D+01, &
       8.15579594561150372D+01,     8.50544670175815174D+01, &
       8.85808275421976788D+01,     9.21361756036870925D+01, &
       9.57196945421432025D+01,     9.93306124547874269D+01, &
       1.02968198614513813D+02,     1.06631760260643459D+02, &
       1.10320639714757395D+02,     1.14034211781461703D+02, &
       1.17771881399745072D+02,     1.21533081515438634D+02/
  DATA GLN(45), GLN(46), GLN(47), GLN(48), GLN(49), GLN(50), &
       GLN(51), GLN(52), GLN(53), GLN(54), GLN(55), GLN(56), &
       GLN(57), GLN(58), GLN(59), GLN(60), GLN(61), GLN(62), &
       GLN(63), GLN(64), GLN(65), GLN(66)/ &
       1.25317271149356895D+02,     1.29123933639127215D+02, &
       1.32952575035616310D+02,     1.36802722637326368D+02, &
       1.40673923648234259D+02,     1.44565743946344886D+02, &
       1.48477766951773032D+02,     1.52409592584497358D+02, &
       1.56360836303078785D+02,     1.60331128216630907D+02, &
       1.64320112263195181D+02,     1.68327445448427652D+02, &
       1.72352797139162802D+02,     1.76395848406997352D+02, &
       1.80456291417543771D+02,     1.84533828861449491D+02, &
       1.88628173423671591D+02,     1.92739047287844902D+02, &
       1.96866181672889994D+02,     2.01009316399281527D+02, &
       2.05168199482641199D+02,     2.09342586752536836D+02/
  DATA GLN(67), GLN(68), GLN(69), GLN(70), GLN(71), GLN(72), &
       GLN(73), GLN(74), GLN(75), GLN(76), GLN(77), GLN(78), &
       GLN(79), GLN(80), GLN(81), GLN(82), GLN(83), GLN(84), &
       GLN(85), GLN(86), GLN(87), GLN(88)/ &
       2.13532241494563261D+02,     2.17736934113954227D+02, &
       2.21956441819130334D+02,     2.26190548323727593D+02, &
       2.30439043565776952D+02,     2.34701723442818268D+02, &
       2.38978389561834323D+02,     2.43268849002982714D+02, &
       2.47572914096186884D+02,     2.51890402209723194D+02, &
       2.56221135550009525D+02,     2.60564940971863209D+02, &
       2.64921649798552801D+02,     2.69291097651019823D+02, &
       2.73673124285693704D+02,     2.78067573440366143D+02, &
       2.82474292687630396D+02,     2.86893133295426994D+02, &
       2.91323950094270308D+02,     2.95766601350760624D+02, &
       3.00220948647014132D+02,     3.04686856765668715D+02/
  DATA GLN(89), GLN(90), GLN(91), GLN(92), GLN(93), GLN(94), &
       GLN(95), GLN(96), GLN(97), GLN(98), GLN(99), GLN(100)/ &
       3.09164193580146922D+02,     3.13652829949879062D+02, &
       3.18152639620209327D+02,     3.22663499126726177D+02, &
       3.27185287703775217D+02,     3.31717887196928473D+02, &
       3.36261181979198477D+02,     3.40815058870799018D+02, &
       3.45379407062266854D+02,     3.49954118040770237D+02, &
       3.54539085519440809D+02,     3.59134205369575399D+02/
!             COEFFICIENTS OF ASYMPTOTIC EXPANSION
  DATA CF(1), CF(2), CF(3), CF(4), CF(5), CF(6), CF(7), CF(8), &
       CF(9), CF(10), CF(11), CF(12), CF(13), CF(14), CF(15), &
       CF(16), CF(17), CF(18), CF(19), CF(20), CF(21), CF(22)/ &
       8.33333333333333333D-02,    -2.77777777777777778D-03, &
       7.93650793650793651D-04,    -5.95238095238095238D-04, &
       8.41750841750841751D-04,    -1.91752691752691753D-03, &
       6.41025641025641026D-03,    -2.95506535947712418D-02, &
       1.79644372368830573D-01,    -1.39243221690590112D+00, &
       1.34028640441683920D+01,    -1.56848284626002017D+02, &
       2.19310333333333333D+03,    -3.61087712537249894D+04, &
       6.91472268851313067D+05,    -1.52382215394074162D+07, &
       3.82900751391414141D+08,    -1.08822660357843911D+10, &
       3.47320283765002252D+11,    -1.23696021422692745D+13, &
       4.88788064793079335D+14,    -2.13203339609193739D+16/
!
!             LN(2*PI)
  DATA CON                    /     1.83787706640934548D+00/
!
!***FIRST EXECUTABLE STATEMENT  DGAMLN
  IERR=0
  if (Z <= 0.0D0) go to 70
  if (Z > 101.0D0) go to 10
  NZ = Z
  FZ = Z - NZ
  if (FZ > 0.0D0) go to 10
  if (NZ > 100) go to 10
  DGAMLN = GLN(NZ)
  return
   10 CONTINUE
  WDTOL = D1MACH(4)
  WDTOL = MAX(WDTOL,0.5D-18)
  I1M = I1MACH(14)
  RLN = D1MACH(5)*I1M
  FLN = MIN(RLN,20.0D0)
  FLN = MAX(FLN,3.0D0)
  FLN = FLN - 3.0D0
  ZM = 1.8000D0 + 0.3875D0*FLN
  MZ = ZM + 1
  ZMIN = MZ
  ZDMY = Z
  ZINC = 0.0D0
  if (Z >= ZMIN) go to 20
  ZINC = ZMIN - NZ
  ZDMY = Z + ZINC
   20 CONTINUE
  ZP = 1.0D0/ZDMY
  T1 = CF(1)*ZP
  S = T1
  if (ZP < WDTOL) go to 40
  ZSQ = ZP*ZP
  TST = T1*WDTOL
  DO 30 K=2,22
    ZP = ZP*ZSQ
    TRM = CF(K)*ZP
    if (ABS(TRM) < TST) go to 40
    S = S + TRM
   30 CONTINUE
   40 CONTINUE
  if (ZINC /= 0.0D0) go to 50
  TLG = LOG(Z)
  DGAMLN = Z*(TLG-1.0D0) + 0.5D0*(CON-TLG) + S
  return
   50 CONTINUE
  ZP = 1.0D0
  NZ = ZINC
  DO 60 I=1,NZ
    ZP = ZP*(Z+(I-1))
   60 CONTINUE
  TLG = LOG(ZDMY)
  DGAMLN = ZDMY*(TLG-1.0D0) - LOG(ZP) + 0.5D0*(CON-TLG) + S
  return
!
!
   70 CONTINUE
  DGAMLN = D1MACH(2)
  IERR=1
  return
end

subroutine D9B0MP (X, AMPL, THETA)
!
!! D9B0MP evaluates the modulus and phase for the J0 and Y0 Bessel functions.
!
!***LIBRARY   SLATEC (FNLIB)
!***CATEGORY  C10A1
!***TYPE      DOUBLE PRECISION (D9B0MP-D)
!***KEYWORDS  BESSEL FUNCTION, FNLIB, MODULUS, PHASE, SPECIAL FUNCTIONS
!***AUTHOR  Fullerton, W., (LANL)
!***DESCRIPTION
!
! Evaluate the modulus and phase for the Bessel J0 and Y0 functions.
!
! Series for BM0        on the interval  1.56250E-02 to  6.25000E-02
!                                        with weighted error   4.40E-32
!                                         log weighted error  31.36
!                               significant figures required  30.02
!                                    decimal places required  32.14
!
! Series for BTH0       on the interval  0.          to  1.56250E-02
!                                        with weighted error   2.66E-32
!                                         log weighted error  31.57
!                               significant figures required  30.67
!                                    decimal places required  32.40
!
! Series for BM02       on the interval  0.          to  1.56250E-02
!                                        with weighted error   4.72E-32
!                                         log weighted error  31.33
!                               significant figures required  30.00
!                                    decimal places required  32.13
!
! Series for BT02       on the interval  1.56250E-02 to  6.25000E-02
!                                        with weighted error   2.99E-32
!                                         log weighted error  31.52
!                               significant figures required  30.61
!                                    decimal places required  32.32
!
!***REFERENCES  (NONE)
!***ROUTINES CALLED  D1MACH, DCSEVL, INITDS, XERMSG
!***REVISION HISTORY  (YYMMDD)
!   770701  DATE WRITTEN
!   890531  Changed all specific intrinsics to generic.  (WRB)
!   890531  REVISION DATE from Version 3.2
!   891214  Prologue converted to Version 4.0 format.  (BAB)
!   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
!   900720  Routine changed from user-callable to subsidiary.  (WRB)
!   920618  Removed space from variable names.  (RWC, WRB)
!***END PROLOGUE  D9B0MP
  DOUBLE PRECISION X, AMPL, THETA, BM0CS(37), BT02CS(39), &
    BM02CS(40), BTH0CS(44), XMAX, PI4, Z, D1MACH, DCSEVL
  LOGICAL FIRST
  SAVE BM0CS, BTH0CS, BM02CS, BT02CS, PI4, NBM0, NBT02, &
   NBM02, NBTH0, XMAX, FIRST
  DATA BM0CS(  1) / +.9211656246827742712573767730182D-1      /
  DATA BM0CS(  2) / -.1050590997271905102480716371755D-2      /
  DATA BM0CS(  3) / +.1470159840768759754056392850952D-4      /
  DATA BM0CS(  4) / -.5058557606038554223347929327702D-6      /
  DATA BM0CS(  5) / +.2787254538632444176630356137881D-7      /
  DATA BM0CS(  6) / -.2062363611780914802618841018973D-8      /
  DATA BM0CS(  7) / +.1870214313138879675138172596261D-9      /
  DATA BM0CS(  8) / -.1969330971135636200241730777825D-10     /
  DATA BM0CS(  9) / +.2325973793999275444012508818052D-11     /
  DATA BM0CS( 10) / -.3009520344938250272851224734482D-12     /
  DATA BM0CS( 11) / +.4194521333850669181471206768646D-13     /
  DATA BM0CS( 12) / -.6219449312188445825973267429564D-14     /
  DATA BM0CS( 13) / +.9718260411336068469601765885269D-15     /
  DATA BM0CS( 14) / -.1588478585701075207366635966937D-15     /
  DATA BM0CS( 15) / +.2700072193671308890086217324458D-16     /
  DATA BM0CS( 16) / -.4750092365234008992477504786773D-17     /
  DATA BM0CS( 17) / +.8615128162604370873191703746560D-18     /
  DATA BM0CS( 18) / -.1605608686956144815745602703359D-18     /
  DATA BM0CS( 19) / +.3066513987314482975188539801599D-19     /
  DATA BM0CS( 20) / -.5987764223193956430696505617066D-20     /
  DATA BM0CS( 21) / +.1192971253748248306489069841066D-20     /
  DATA BM0CS( 22) / -.2420969142044805489484682581333D-21     /
  DATA BM0CS( 23) / +.4996751760510616453371002879999D-22     /
  DATA BM0CS( 24) / -.1047493639351158510095040511999D-22     /
  DATA BM0CS( 25) / +.2227786843797468101048183466666D-23     /
  DATA BM0CS( 26) / -.4801813239398162862370542933333D-24     /
  DATA BM0CS( 27) / +.1047962723470959956476996266666D-24     /
  DATA BM0CS( 28) / -.2313858165678615325101260800000D-25     /
  DATA BM0CS( 29) / +.5164823088462674211635199999999D-26     /
  DATA BM0CS( 30) / -.1164691191850065389525401599999D-26     /
  DATA BM0CS( 31) / +.2651788486043319282958336000000D-27     /
  DATA BM0CS( 32) / -.6092559503825728497691306666666D-28     /
  DATA BM0CS( 33) / +.1411804686144259308038826666666D-28     /
  DATA BM0CS( 34) / -.3298094961231737245750613333333D-29     /
  DATA BM0CS( 35) / +.7763931143074065031714133333333D-30     /
  DATA BM0CS( 36) / -.1841031343661458478421333333333D-30     /
  DATA BM0CS( 37) / +.4395880138594310737100799999999D-31     /
  DATA BTH0CS(  1) / -.24901780862128936717709793789967D+0     /
  DATA BTH0CS(  2) / +.48550299609623749241048615535485D-3     /
  DATA BTH0CS(  3) / -.54511837345017204950656273563505D-5     /
  DATA BTH0CS(  4) / +.13558673059405964054377445929903D-6     /
  DATA BTH0CS(  5) / -.55691398902227626227583218414920D-8     /
  DATA BTH0CS(  6) / +.32609031824994335304004205719468D-9     /
  DATA BTH0CS(  7) / -.24918807862461341125237903877993D-10    /
  DATA BTH0CS(  8) / +.23449377420882520554352413564891D-11    /
  DATA BTH0CS(  9) / -.26096534444310387762177574766136D-12    /
  DATA BTH0CS( 10) / +.33353140420097395105869955014923D-13    /
  DATA BTH0CS( 11) / -.47890000440572684646750770557409D-14    /
  DATA BTH0CS( 12) / +.75956178436192215972642568545248D-15    /
  DATA BTH0CS( 13) / -.13131556016891440382773397487633D-15    /
  DATA BTH0CS( 14) / +.24483618345240857495426820738355D-16    /
  DATA BTH0CS( 15) / -.48805729810618777683256761918331D-17    /
  DATA BTH0CS( 16) / +.10327285029786316149223756361204D-17    /
  DATA BTH0CS( 17) / -.23057633815057217157004744527025D-18    /
  DATA BTH0CS( 18) / +.54044443001892693993017108483765D-19    /
  DATA BTH0CS( 19) / -.13240695194366572724155032882385D-19    /
  DATA BTH0CS( 20) / +.33780795621371970203424792124722D-20    /
  DATA BTH0CS( 21) / -.89457629157111779003026926292299D-21    /
  DATA BTH0CS( 22) / +.24519906889219317090899908651405D-21    /
  DATA BTH0CS( 23) / -.69388422876866318680139933157657D-22    /
  DATA BTH0CS( 24) / +.20228278714890138392946303337791D-22    /
  DATA BTH0CS( 25) / -.60628500002335483105794195371764D-23    /
  DATA BTH0CS( 26) / +.18649748964037635381823788396270D-23    /
  DATA BTH0CS( 27) / -.58783732384849894560245036530867D-24    /
  DATA BTH0CS( 28) / +.18958591447999563485531179503513D-24    /
  DATA BTH0CS( 29) / -.62481979372258858959291620728565D-25    /
  DATA BTH0CS( 30) / +.21017901684551024686638633529074D-25    /
  DATA BTH0CS( 31) / -.72084300935209253690813933992446D-26    /
  DATA BTH0CS( 32) / +.25181363892474240867156405976746D-26    /
  DATA BTH0CS( 33) / -.89518042258785778806143945953643D-27    /
  DATA BTH0CS( 34) / +.32357237479762298533256235868587D-27    /
  DATA BTH0CS( 35) / -.11883010519855353657047144113796D-27    /
  DATA BTH0CS( 36) / +.44306286907358104820579231941731D-28    /
  DATA BTH0CS( 37) / -.16761009648834829495792010135681D-28    /
  DATA BTH0CS( 38) / +.64292946921207466972532393966088D-29    /
  DATA BTH0CS( 39) / -.24992261166978652421207213682763D-29    /
  DATA BTH0CS( 40) / +.98399794299521955672828260355318D-30    /
  DATA BTH0CS( 41) / -.39220375242408016397989131626158D-30    /
  DATA BTH0CS( 42) / +.15818107030056522138590618845692D-30    /
  DATA BTH0CS( 43) / -.64525506144890715944344098365426D-31    /
  DATA BTH0CS( 44) / +.26611111369199356137177018346367D-31    /
  DATA BM02CS(  1) / +.9500415145228381369330861335560D-1      /
  DATA BM02CS(  2) / -.3801864682365670991748081566851D-3      /
  DATA BM02CS(  3) / +.2258339301031481192951829927224D-5      /
  DATA BM02CS(  4) / -.3895725802372228764730621412605D-7      /
  DATA BM02CS(  5) / +.1246886416512081697930990529725D-8      /
  DATA BM02CS(  6) / -.6065949022102503779803835058387D-10     /
  DATA BM02CS(  7) / +.4008461651421746991015275971045D-11     /
  DATA BM02CS(  8) / -.3350998183398094218467298794574D-12     /
  DATA BM02CS(  9) / +.3377119716517417367063264341996D-13     /
  DATA BM02CS( 10) / -.3964585901635012700569356295823D-14     /
  DATA BM02CS( 11) / +.5286111503883857217387939744735D-15     /
  DATA BM02CS( 12) / -.7852519083450852313654640243493D-16     /
  DATA BM02CS( 13) / +.1280300573386682201011634073449D-16     /
  DATA BM02CS( 14) / -.2263996296391429776287099244884D-17     /
  DATA BM02CS( 15) / +.4300496929656790388646410290477D-18     /
  DATA BM02CS( 16) / -.8705749805132587079747535451455D-19     /
  DATA BM02CS( 17) / +.1865862713962095141181442772050D-19     /
  DATA BM02CS( 18) / -.4210482486093065457345086972301D-20     /
  DATA BM02CS( 19) / +.9956676964228400991581627417842D-21     /
  DATA BM02CS( 20) / -.2457357442805313359605921478547D-21     /
  DATA BM02CS( 21) / +.6307692160762031568087353707059D-22     /
  DATA BM02CS( 22) / -.1678773691440740142693331172388D-22     /
  DATA BM02CS( 23) / +.4620259064673904433770878136087D-23     /
  DATA BM02CS( 24) / -.1311782266860308732237693402496D-23     /
  DATA BM02CS( 25) / +.3834087564116302827747922440276D-24     /
  DATA BM02CS( 26) / -.1151459324077741271072613293576D-24     /
  DATA BM02CS( 27) / +.3547210007523338523076971345213D-25     /
  DATA BM02CS( 28) / -.1119218385815004646264355942176D-25     /
  DATA BM02CS( 29) / +.3611879427629837831698404994257D-26     /
  DATA BM02CS( 30) / -.1190687765913333150092641762463D-26     /
  DATA BM02CS( 31) / +.4005094059403968131802476449536D-27     /
  DATA BM02CS( 32) / -.1373169422452212390595193916017D-27     /
  DATA BM02CS( 33) / +.4794199088742531585996491526437D-28     /
  DATA BM02CS( 34) / -.1702965627624109584006994476452D-28     /
  DATA BM02CS( 35) / +.6149512428936330071503575161324D-29     /
  DATA BM02CS( 36) / -.2255766896581828349944300237242D-29     /
  DATA BM02CS( 37) / +.8399707509294299486061658353200D-30     /
  DATA BM02CS( 38) / -.3172997595562602355567423936152D-30     /
  DATA BM02CS( 39) / +.1215205298881298554583333026514D-30     /
  DATA BM02CS( 40) / -.4715852749754438693013210568045D-31     /
  DATA BT02CS(  1) / -.24548295213424597462050467249324D+0     /
  DATA BT02CS(  2) / +.12544121039084615780785331778299D-2     /
  DATA BT02CS(  3) / -.31253950414871522854973446709571D-4     /
  DATA BT02CS(  4) / +.14709778249940831164453426969314D-5     /
  DATA BT02CS(  5) / -.99543488937950033643468850351158D-7     /
  DATA BT02CS(  6) / +.85493166733203041247578711397751D-8     /
  DATA BT02CS(  7) / -.86989759526554334557985512179192D-9     /
  DATA BT02CS(  8) / +.10052099533559791084540101082153D-9     /
  DATA BT02CS(  9) / -.12828230601708892903483623685544D-10    /
  DATA BT02CS( 10) / +.17731700781805131705655750451023D-11    /
  DATA BT02CS( 11) / -.26174574569485577488636284180925D-12    /
  DATA BT02CS( 12) / +.40828351389972059621966481221103D-13    /
  DATA BT02CS( 13) / -.66751668239742720054606749554261D-14    /
  DATA BT02CS( 14) / +.11365761393071629448392469549951D-14    /
  DATA BT02CS( 15) / -.20051189620647160250559266412117D-15    /
  DATA BT02CS( 16) / +.36497978794766269635720591464106D-16    /
  DATA BT02CS( 17) / -.68309637564582303169355843788800D-17    /
  DATA BT02CS( 18) / +.13107583145670756620057104267946D-17    /
  DATA BT02CS( 19) / -.25723363101850607778757130649599D-18    /
  DATA BT02CS( 20) / +.51521657441863959925267780949333D-19    /
  DATA BT02CS( 21) / -.10513017563758802637940741461333D-19    /
  DATA BT02CS( 22) / +.21820381991194813847301084501333D-20    /
  DATA BT02CS( 23) / -.46004701210362160577225905493333D-21    /
  DATA BT02CS( 24) / +.98407006925466818520953651199999D-22    /
  DATA BT02CS( 25) / -.21334038035728375844735986346666D-22    /
  DATA BT02CS( 26) / +.46831036423973365296066286933333D-23    /
  DATA BT02CS( 27) / -.10400213691985747236513382399999D-23    /
  DATA BT02CS( 28) / +.23349105677301510051777740800000D-24    /
  DATA BT02CS( 29) / -.52956825323318615788049749333333D-25    /
  DATA BT02CS( 30) / +.12126341952959756829196287999999D-25    /
  DATA BT02CS( 31) / -.28018897082289428760275626666666D-26    /
  DATA BT02CS( 32) / +.65292678987012873342593706666666D-27    /
  DATA BT02CS( 33) / -.15337980061873346427835733333333D-27    /
  DATA BT02CS( 34) / +.36305884306364536682359466666666D-28    /
  DATA BT02CS( 35) / -.86560755713629122479172266666666D-29    /
  DATA BT02CS( 36) / +.20779909972536284571238399999999D-29    /
  DATA BT02CS( 37) / -.50211170221417221674325333333333D-30    /
  DATA BT02CS( 38) / +.12208360279441714184191999999999D-30    /
  DATA BT02CS( 39) / -.29860056267039913454250666666666D-31    /
  DATA PI4 / 0.785398163397448309615660845819876D0 /
  DATA FIRST /.TRUE./
!***FIRST EXECUTABLE STATEMENT  D9B0MP
  if (FIRST) THEN
     ETA = 0.1*REAL(D1MACH(3))
     NBM0 = INITDS (BM0CS, 37, ETA)
     NBT02 = INITDS (BT02CS, 39, ETA)
     NBM02 = INITDS (BM02CS, 40, ETA)
     NBTH0 = INITDS (BTH0CS, 44, ETA)
!
     XMAX = 1.0D0/D1MACH(4)
  end if
  FIRST = .FALSE.
!
  if (X  <  4.D0) call XERMSG ('SLATEC', 'D9B0MP', &
     'X MUST BE GE 4', 1, 2)
!
  if (X > 8.D0) go to 20
  Z = (128.D0/(X*X) - 5.D0)/3.D0
  AMPL = (.75D0 + DCSEVL (Z, BM0CS, NBM0))/SQRT(X)
  THETA = X - PI4 + DCSEVL (Z, BT02CS, NBT02)/X
  return
!
 20   if (X  >  XMAX) call XERMSG ('SLATEC', 'D9B0MP', &
     'NO PRECISION BECAUSE X IS BIG', 2, 2)
!
  Z = 128.D0/(X*X) - 1.D0
  AMPL = (.75D0 + DCSEVL (Z, BM02CS, NBM02))/SQRT(X)
  THETA = X - PI4 + DCSEVL (Z, BTH0CS, NBTH0)/X
  return
!
end

subroutine D9B1MP (X, AMPL, THETA)
!
!! D9B1MP evaluates the modulus and phase for the J1 and Y1 Bessel functions.
!
!***LIBRARY   SLATEC (FNLIB)
!***CATEGORY  C10A1
!***TYPE      DOUBLE PRECISION (D9B1MP-D)
!***KEYWORDS  BESSEL FUNCTION, FNLIB, MODULUS, PHASE, SPECIAL FUNCTIONS
!***AUTHOR  Fullerton, W., (LANL)
!***DESCRIPTION
!
! Evaluate the modulus and phase for the Bessel J1 and Y1 functions.
!
! Series for BM1        on the interval  1.56250E-02 to  6.25000E-02
!                                        with weighted error   4.91E-32
!                                         log weighted error  31.31
!                               significant figures required  30.04
!                                    decimal places required  32.09
!
! Series for BT12       on the interval  1.56250E-02 to  6.25000E-02
!                                        with weighted error   3.33E-32
!                                         log weighted error  31.48
!                               significant figures required  31.05
!                                    decimal places required  32.27
!
! Series for BM12       on the interval  0.          to  1.56250E-02
!                                        with weighted error   5.01E-32
!                                         log weighted error  31.30
!                               significant figures required  29.99
!                                    decimal places required  32.10
!
! Series for BTH1       on the interval  0.          to  1.56250E-02
!                                        with weighted error   2.82E-32
!                                         log weighted error  31.55
!                               significant figures required  31.12
!                                    decimal places required  32.37
!
!***SEE ALSO  DBESJ1, DBESY1
!***REFERENCES  (NONE)
!***ROUTINES CALLED  D1MACH, DCSEVL, INITDS, XERMSG
!***REVISION HISTORY  (YYMMDD)
!   770701  DATE WRITTEN
!   890531  Changed all specific intrinsics to generic.  (WRB)
!   890531  REVISION DATE from Version 3.2
!   891214  Prologue converted to Version 4.0 format.  (BAB)
!   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
!   900720  Routine changed from user-callable to subsidiary.  (WRB)
!   920618  Removed space from variable name and code restructured to
!           use IF-THEN-ELSE.  (RWC, WRB)
!***END PROLOGUE  D9B1MP
  DOUBLE PRECISION X, AMPL, THETA, BM1CS(37), BT12CS(39), &
    BM12CS(40), BTH1CS(44), XMAX, PI4, Z, D1MACH, DCSEVL
  LOGICAL FIRST
  SAVE BM1CS, BT12CS, BTH1CS, BM12CS, PI4, NBM1, NBT12, &
   NBM12, NBTH1, XMAX, FIRST
  DATA BM1CS(  1) / +.1069845452618063014969985308538D+0      /
  DATA BM1CS(  2) / +.3274915039715964900729055143445D-2      /
  DATA BM1CS(  3) / -.2987783266831698592030445777938D-4      /
  DATA BM1CS(  4) / +.8331237177991974531393222669023D-6      /
  DATA BM1CS(  5) / -.4112665690302007304896381725498D-7      /
  DATA BM1CS(  6) / +.2855344228789215220719757663161D-8      /
  DATA BM1CS(  7) / -.2485408305415623878060026596055D-9      /
  DATA BM1CS(  8) / +.2543393338072582442742484397174D-10     /
  DATA BM1CS(  9) / -.2941045772822967523489750827909D-11     /
  DATA BM1CS( 10) / +.3743392025493903309265056153626D-12     /
  DATA BM1CS( 11) / -.5149118293821167218720548243527D-13     /
  DATA BM1CS( 12) / +.7552535949865143908034040764199D-14     /
  DATA BM1CS( 13) / -.1169409706828846444166290622464D-14     /
  DATA BM1CS( 14) / +.1896562449434791571721824605060D-15     /
  DATA BM1CS( 15) / -.3201955368693286420664775316394D-16     /
  DATA BM1CS( 16) / +.5599548399316204114484169905493D-17     /
  DATA BM1CS( 17) / -.1010215894730432443119390444544D-17     /
  DATA BM1CS( 18) / +.1873844985727562983302042719573D-18     /
  DATA BM1CS( 19) / -.3563537470328580219274301439999D-19     /
  DATA BM1CS( 20) / +.6931283819971238330422763519999D-20     /
  DATA BM1CS( 21) / -.1376059453406500152251408930133D-20     /
  DATA BM1CS( 22) / +.2783430784107080220599779327999D-21     /
  DATA BM1CS( 23) / -.5727595364320561689348669439999D-22     /
  DATA BM1CS( 24) / +.1197361445918892672535756799999D-22     /
  DATA BM1CS( 25) / -.2539928509891871976641440426666D-23     /
  DATA BM1CS( 26) / +.5461378289657295973069619199999D-24     /
  DATA BM1CS( 27) / -.1189211341773320288986289493333D-24     /
  DATA BM1CS( 28) / +.2620150977340081594957824000000D-25     /
  DATA BM1CS( 29) / -.5836810774255685901920938666666D-26     /
  DATA BM1CS( 30) / +.1313743500080595773423615999999D-26     /
  DATA BM1CS( 31) / -.2985814622510380355332778666666D-27     /
  DATA BM1CS( 32) / +.6848390471334604937625599999999D-28     /
  DATA BM1CS( 33) / -.1584401568222476721192960000000D-28     /
  DATA BM1CS( 34) / +.3695641006570938054301013333333D-29     /
  DATA BM1CS( 35) / -.8687115921144668243012266666666D-30     /
  DATA BM1CS( 36) / +.2057080846158763462929066666666D-30     /
  DATA BM1CS( 37) / -.4905225761116225518523733333333D-31     /
  DATA BT12CS(  1) / +.73823860128742974662620839792764D+0     /
  DATA BT12CS(  2) / -.33361113174483906384470147681189D-2     /
  DATA BT12CS(  3) / +.61463454888046964698514899420186D-4     /
  DATA BT12CS(  4) / -.24024585161602374264977635469568D-5     /
  DATA BT12CS(  5) / +.14663555577509746153210591997204D-6     /
  DATA BT12CS(  6) / -.11841917305589180567005147504983D-7     /
  DATA BT12CS(  7) / +.11574198963919197052125466303055D-8     /
  DATA BT12CS(  8) / -.13001161129439187449366007794571D-9     /
  DATA BT12CS(  9) / +.16245391141361731937742166273667D-10    /
  DATA BT12CS( 10) / -.22089636821403188752155441770128D-11    /
  DATA BT12CS( 11) / +.32180304258553177090474358653778D-12    /
  DATA BT12CS( 12) / -.49653147932768480785552021135381D-13    /
  DATA BT12CS( 13) / +.80438900432847825985558882639317D-14    /
  DATA BT12CS( 14) / -.13589121310161291384694712682282D-14    /
  DATA BT12CS( 15) / +.23810504397147214869676529605973D-15    /
  DATA BT12CS( 16) / -.43081466363849106724471241420799D-16    /
  DATA BT12CS( 17) / +.80202544032771002434993512550400D-17    /
  DATA BT12CS( 18) / -.15316310642462311864230027468799D-17    /
  DATA BT12CS( 19) / +.29928606352715568924073040554666D-18    /
  DATA BT12CS( 20) / -.59709964658085443393815636650666D-19    /
  DATA BT12CS( 21) / +.12140289669415185024160852650666D-19    /
  DATA BT12CS( 22) / -.25115114696612948901006977706666D-20    /
  DATA BT12CS( 23) / +.52790567170328744850738380799999D-21    /
  DATA BT12CS( 24) / -.11260509227550498324361161386666D-21    /
  DATA BT12CS( 25) / +.24348277359576326659663462400000D-22    /
  DATA BT12CS( 26) / -.53317261236931800130038442666666D-23    /
  DATA BT12CS( 27) / +.11813615059707121039205990399999D-23    /
  DATA BT12CS( 28) / -.26465368283353523514856789333333D-24    /
  DATA BT12CS( 29) / +.59903394041361503945577813333333D-25    /
  DATA BT12CS( 30) / -.13690854630829503109136383999999D-25    /
  DATA BT12CS( 31) / +.31576790154380228326413653333333D-26    /
  DATA BT12CS( 32) / -.73457915082084356491400533333333D-27    /
  DATA BT12CS( 33) / +.17228081480722747930705920000000D-27    /
  DATA BT12CS( 34) / -.40716907961286507941068800000000D-28    /
  DATA BT12CS( 35) / +.96934745136779622700373333333333D-29    /
  DATA BT12CS( 36) / -.23237636337765716765354666666666D-29    /
  DATA BT12CS( 37) / +.56074510673522029406890666666666D-30    /
  DATA BT12CS( 38) / -.13616465391539005860522666666666D-30    /
  DATA BT12CS( 39) / +.33263109233894654388906666666666D-31    /
  DATA BM12CS(  1) / +.9807979156233050027272093546937D-1      /
  DATA BM12CS(  2) / +.1150961189504685306175483484602D-2      /
  DATA BM12CS(  3) / -.4312482164338205409889358097732D-5      /
  DATA BM12CS(  4) / +.5951839610088816307813029801832D-7      /
  DATA BM12CS(  5) / -.1704844019826909857400701586478D-8      /
  DATA BM12CS(  6) / +.7798265413611109508658173827401D-10     /
  DATA BM12CS(  7) / -.4958986126766415809491754951865D-11     /
  DATA BM12CS(  8) / +.4038432416421141516838202265144D-12     /
  DATA BM12CS(  9) / -.3993046163725175445765483846645D-13     /
  DATA BM12CS( 10) / +.4619886183118966494313342432775D-14     /
  DATA BM12CS( 11) / -.6089208019095383301345472619333D-15     /
  DATA BM12CS( 12) / +.8960930916433876482157048041249D-16     /
  DATA BM12CS( 13) / -.1449629423942023122916518918925D-16     /
  DATA BM12CS( 14) / +.2546463158537776056165149648068D-17     /
  DATA BM12CS( 15) / -.4809472874647836444259263718620D-18     /
  DATA BM12CS( 16) / +.9687684668292599049087275839124D-19     /
  DATA BM12CS( 17) / -.2067213372277966023245038117551D-19     /
  DATA BM12CS( 18) / +.4646651559150384731802767809590D-20     /
  DATA BM12CS( 19) / -.1094966128848334138241351328339D-20     /
  DATA BM12CS( 20) / +.2693892797288682860905707612785D-21     /
  DATA BM12CS( 21) / -.6894992910930374477818970026857D-22     /
  DATA BM12CS( 22) / +.1830268262752062909890668554740D-22     /
  DATA BM12CS( 23) / -.5025064246351916428156113553224D-23     /
  DATA BM12CS( 24) / +.1423545194454806039631693634194D-23     /
  DATA BM12CS( 25) / -.4152191203616450388068886769801D-24     /
  DATA BM12CS( 26) / +.1244609201503979325882330076547D-24     /
  DATA BM12CS( 27) / -.3827336370569304299431918661286D-25     /
  DATA BM12CS( 28) / +.1205591357815617535374723981835D-25     /
  DATA BM12CS( 29) / -.3884536246376488076431859361124D-26     /
  DATA BM12CS( 30) / +.1278689528720409721904895283461D-26     /
  DATA BM12CS( 31) / -.4295146689447946272061936915912D-27     /
  DATA BM12CS( 32) / +.1470689117829070886456802707983D-27     /
  DATA BM12CS( 33) / -.5128315665106073128180374017796D-28     /
  DATA BM12CS( 34) / +.1819509585471169385481437373286D-28     /
  DATA BM12CS( 35) / -.6563031314841980867618635050373D-29     /
  DATA BM12CS( 36) / +.2404898976919960653198914875834D-29     /
  DATA BM12CS( 37) / -.8945966744690612473234958242979D-30     /
  DATA BM12CS( 38) / +.3376085160657231026637148978240D-30     /
  DATA BM12CS( 39) / -.1291791454620656360913099916966D-30     /
  DATA BM12CS( 40) / +.5008634462958810520684951501254D-31     /
  DATA BTH1CS(  1) / +.74749957203587276055443483969695D+0     /
  DATA BTH1CS(  2) / -.12400777144651711252545777541384D-2     /
  DATA BTH1CS(  3) / +.99252442404424527376641497689592D-5     /
  DATA BTH1CS(  4) / -.20303690737159711052419375375608D-6     /
  DATA BTH1CS(  5) / +.75359617705690885712184017583629D-8     /
  DATA BTH1CS(  6) / -.41661612715343550107630023856228D-9     /
  DATA BTH1CS(  7) / +.30701618070834890481245102091216D-10    /
  DATA BTH1CS(  8) / -.28178499637605213992324008883924D-11    /
  DATA BTH1CS(  9) / +.30790696739040295476028146821647D-12    /
  DATA BTH1CS( 10) / -.38803300262803434112787347554781D-13    /
  DATA BTH1CS( 11) / +.55096039608630904934561726208562D-14    /
  DATA BTH1CS( 12) / -.86590060768383779940103398953994D-15    /
  DATA BTH1CS( 13) / +.14856049141536749003423689060683D-15    /
  DATA BTH1CS( 14) / -.27519529815904085805371212125009D-16    /
  DATA BTH1CS( 15) / +.54550796090481089625036223640923D-17    /
  DATA BTH1CS( 16) / -.11486534501983642749543631027177D-17    /
  DATA BTH1CS( 17) / +.25535213377973900223199052533522D-18    /
  DATA BTH1CS( 18) / -.59621490197413450395768287907849D-19    /
  DATA BTH1CS( 19) / +.14556622902372718620288302005833D-19    /
  DATA BTH1CS( 20) / -.37022185422450538201579776019593D-20    /
  DATA BTH1CS( 21) / +.97763074125345357664168434517924D-21    /
  DATA BTH1CS( 22) / -.26726821639668488468723775393052D-21    /
  DATA BTH1CS( 23) / +.75453300384983271794038190655764D-22    /
  DATA BTH1CS( 24) / -.21947899919802744897892383371647D-22    /
  DATA BTH1CS( 25) / +.65648394623955262178906999817493D-23    /
  DATA BTH1CS( 26) / -.20155604298370207570784076869519D-23    /
  DATA BTH1CS( 27) / +.63417768556776143492144667185670D-24    /
  DATA BTH1CS( 28) / -.20419277885337895634813769955591D-24    /
  DATA BTH1CS( 29) / +.67191464220720567486658980018551D-25    /
  DATA BTH1CS( 30) / -.22569079110207573595709003687336D-25    /
  DATA BTH1CS( 31) / +.77297719892989706370926959871929D-26    /
  DATA BTH1CS( 32) / -.26967444512294640913211424080920D-26    /
  DATA BTH1CS( 33) / +.95749344518502698072295521933627D-27    /
  DATA BTH1CS( 34) / -.34569168448890113000175680827627D-27    /
  DATA BTH1CS( 35) / +.12681234817398436504211986238374D-27    /
  DATA BTH1CS( 36) / -.47232536630722639860464993713445D-28    /
  DATA BTH1CS( 37) / +.17850008478186376177858619796417D-28    /
  DATA BTH1CS( 38) / -.68404361004510395406215223566746D-29    /
  DATA BTH1CS( 39) / +.26566028671720419358293422672212D-29    /
  DATA BTH1CS( 40) / -.10450402527914452917714161484670D-29    /
  DATA BTH1CS( 41) / +.41618290825377144306861917197064D-30    /
  DATA BTH1CS( 42) / -.16771639203643714856501347882887D-30    /
  DATA BTH1CS( 43) / +.68361997776664389173535928028528D-31    /
  DATA BTH1CS( 44) / -.28172247861233641166739574622810D-31    /
  DATA PI4 / 0.785398163397448309615660845819876D0 /
  DATA FIRST /.TRUE./
!***FIRST EXECUTABLE STATEMENT  D9B1MP
  if (FIRST) THEN
     ETA = 0.1*REAL(D1MACH(3))
     NBM1 = INITDS (BM1CS, 37, ETA)
     NBT12 = INITDS (BT12CS, 39, ETA)
     NBM12 = INITDS (BM12CS, 40, ETA)
     NBTH1 = INITDS (BTH1CS, 44, ETA)
!
     XMAX = 1.0D0/D1MACH(4)
  end if
  FIRST = .FALSE.
!
  if (X  <  4.0D0) THEN
     call XERMSG ('SLATEC', 'D9B1MP', 'X must be  >=  4', 1, 2)
     AMPL = 0.0D0
     THETA = 0.0D0
  ELSE if (X  <=  8.0D0) THEN
     Z = (128.0D0/(X*X) - 5.0D0)/3.0D0
     AMPL = (0.75D0 + DCSEVL (Z, BM1CS, NBM1))/SQRT(X)
     THETA = X - 3.0D0*PI4 + DCSEVL (Z, BT12CS, NBT12)/X
  ELSE
     if (X  >  XMAX) call XERMSG ('SLATEC', 'D9B1MP', &
        'No precision because X is too big', 2, 2)
!
     Z = 128.0D0/(X*X) - 1.0D0
     AMPL = (0.75D0 + DCSEVL (Z, BM12CS, NBM12))/SQRT(X)
     THETA = X - 3.0D0*PI4 + DCSEVL (Z, BTH1CS, NBTH1)/X
  end if
  return
end

! ============================
! = Single precision Bessels =
! ============================
subroutine BESJ (X, ALPHA, N, Y, NZ)
!
!! BESJ computes an N member sequence of J Bessel functions ...
!  J/SUB(ALPHA+K-1)/(X), K=1,...,N for non-negative ALPHA and X.
!
!***LIBRARY   SLATEC
!***CATEGORY  C10A3
!***TYPE      SINGLE PRECISION (BESJ-S, DBESJ-D)
!***KEYWORDS  J BESSEL FUNCTION, SPECIAL FUNCTIONS
!***AUTHOR  Amos, D. E., (SNLA)
!           Daniel, S. L., (SNLA)
!           Weston, M. K., (SNLA)
!***DESCRIPTION
!
!     Abstract
!         BESJ computes an N member sequence of J Bessel functions
!         J/sub(ALPHA+K-1)/(X), K=1,...,N for non-negative ALPHA and X.
!         A combination of the power series, the asymptotic expansion
!         for X to infinity and the uniform asymptotic expansion for
!         NU to infinity are applied over subdivisions of the (NU,X)
!         plane.  For values of (NU,X) not covered by one of these
!         formulae, the order is incremented or decremented by integer
!         values into a region where one of the formulae apply. Backward
!         recursion is applied to reduce orders by integer values except
!         where the entire sequence lies in the oscillatory region.  In
!         this case forward recursion is stable and values from the
!         asymptotic expansion for X to infinity start the recursion
!         when it is efficient to do so.  Leading terms of the series
!         and uniform expansion are tested for underflow.  If a sequence
!         is requested and the last member would underflow, the result
!         is set to zero and the next lower order tried, etc., until a
!         member comes on scale or all members are set to zero.
!         Overflow cannot occur.
!
!     Description of Arguments
!
!         Input
!           X      - X  >=  0.0E0
!           ALPHA  - order of first member of the sequence,
!                    ALPHA  >=  0.0E0
!           N      - number of members in the sequence, N  >=  1
!
!         Output
!           Y      - a vector whose first  N components contain
!                    values for J/sub(ALPHA+K-1)/(X), K=1,...,N
!           NZ     - number of components of Y set to zero due to
!                    underflow,
!                    NZ=0   , normal return, computation completed
!                    NZ  /=  0, last NZ components of Y set to zero,
!                             Y(K)=0.0E0, K=N-NZ+1,...,N.
!
!     Error Conditions
!         Improper input arguments - a fatal error
!         Underflow  - a non-fatal error (NZ  /=  0)
!
!***REFERENCES  D. E. Amos, S. L. Daniel and M. K. Weston, CDC 6600
!                 subroutines IBESS and JBESS for Bessel functions
!                 I(NU,X) and J(NU,X), X  >=  0, NU  >=  0, ACM
!                 Transactions on Mathematical Software 3, (1977),
!                 pp. 76-92.
!               F. W. J. Olver, Tables of Bessel Functions of Moderate
!                 or Large Orders, NPL Mathematical Tables 6, Her
!                 Majesty's Stationery Office, London, 1962.
!***ROUTINES CALLED  ALNGAM, ASYJY, I1MACH, JAIRY, R1MACH, XERMSG
!***REVISION HISTORY  (YYMMDD)
!   750101  DATE WRITTEN
!   890531  Changed all specific intrinsics to generic.  (WRB)
!   890531  REVISION DATE from Version 3.2
!   891214  Prologue converted to Version 4.0 format.  (BAB)
!   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
!   900326  Removed duplicate information from DESCRIPTION section.
!           (WRB)
!   920501  Reformatted the REFERENCES section.  (WRB)
!***END PROLOGUE  BESJ
  EXTERNAL JAIRY
  INTEGER I,IALP,IDALP,IFLW,IN,INLIM,IS,I1,I2,K,KK,KM,KT,N,NN, &
          NS,NZ
  INTEGER I1MACH
  REAL       AK,AKM,ALPHA,ANS,AP,ARG,COEF,DALPHA,DFN,DTM,EARG, &
             ELIM1,ETX,FIDAL,FLGJY,FN,FNF,FNI,FNP1,FNU,FNULIM, &
             GLN,PDF,PIDT,PP,RDEN,RELB,RTTP,RTWO,RTX,RZDEN, &
             S,SA,SB,SXO2,S1,S2,T,TA,TAU,TB,TEMP,TFN,TM,TOL, &
             TOLLN,TRX,TX,T1,T2,WK,X,XO2,XO2L,Y,RTOL,SLIM
  SAVE RTWO, PDF, RTTP, PIDT, PP, INLIM, FNULIM
  REAL R1MACH, ALNGAM
  DIMENSION Y(*), TEMP(3), FNULIM(2), PP(4), WK(7)
  DATA RTWO,PDF,RTTP,PIDT                    / 1.34839972492648E+00, &
   7.85398163397448E-01, 7.97884560802865E-01, 1.57079632679490E+00/
  DATA  PP(1),  PP(2),  PP(3),  PP(4)        / 8.72909153935547E+00, &
   2.65693932265030E-01, 1.24578576865586E-01, 7.70133747430388E-04/
  DATA INLIM           /      150            /
  DATA FNULIM(1), FNULIM(2) /      100.0E0,     60.0E0     /
!***FIRST EXECUTABLE STATEMENT  BESJ
  NZ = 0
  KT = 1
  NS=0
!     I1MACH(14) REPLACES I1MACH(11) IN A DOUBLE PRECISION CODE
!     I1MACH(15) REPLACES I1MACH(12) IN A DOUBLE PRECISION CODE
  TA = R1MACH(3)
  TOL = MAX(TA,1.0E-15)
  I1 = I1MACH(11) + 1
  I2 = I1MACH(12)
  TB = R1MACH(5)
  ELIM1 = -2.303E0*(I2*TB+3.0E0)
  RTOL=1.0E0/TOL
  SLIM=R1MACH(1)*1.0E+3*RTOL
!     TOLLN = -LN(TOL)
  TOLLN = 2.303E0*TB*I1
  TOLLN = MIN(TOLLN,34.5388E0)
  if (N-1) 720, 10, 20
   10 KT = 2
   20 NN = N
  if (X) 730, 30, 80
   30 if (ALPHA) 710, 40, 50
   40 Y(1) = 1.0E0
  if (N == 1) RETURN
  I1 = 2
  go to 60
   50 I1 = 1
   60 DO 70 I=I1,N
    Y(I) = 0.0E0
   70 CONTINUE
  return
   80 CONTINUE
  if (ALPHA < 0.0E0) go to 710
!
  IALP = INT(ALPHA)
  FNI = IALP + N - 1
  FNF = ALPHA - IALP
  DFN = FNI + FNF
  FNU = DFN
  XO2 = X*0.5E0
  SXO2 = XO2*XO2
!
!     DECISION TREE FOR REGION WHERE SERIES, ASYMPTOTIC EXPANSION FOR X
!     TO INFINITY AND ASYMPTOTIC EXPANSION FOR NU TO INFINITY ARE
!     APPLIED.
!
  if (SXO2 <= (FNU+1.0E0)) go to 90
  TA = MAX(20.0E0,FNU)
  if (X > TA) go to 120
  if (X > 12.0E0) go to 110
  XO2L = LOG(XO2)
  NS = INT(SXO2-FNU) + 1
  go to 100
   90 FN = FNU
  FNP1 = FN + 1.0E0
  XO2L = LOG(XO2)
  IS = KT
  if (X <= 0.50E0) go to 330
  NS = 0
  100 FNI = FNI + NS
  DFN = FNI + FNF
  FN = DFN
  FNP1 = FN + 1.0E0
  IS = KT
  if (N-1+NS > 0) IS = 3
  go to 330
  110 ANS = MAX(36.0E0-FNU,0.0E0)
  NS = INT(ANS)
  FNI = FNI + NS
  DFN = FNI + FNF
  FN = DFN
  IS = KT
  if (N-1+NS > 0) IS = 3
  go to 130
  120 CONTINUE
  RTX = SQRT(X)
  TAU = RTWO*RTX
  TA = TAU + FNULIM(KT)
  if (FNU <= TA) go to 480
  FN = FNU
  IS = KT
!
!     UNIFORM ASYMPTOTIC EXPANSION FOR NU TO INFINITY
!
  130 CONTINUE
  I1 = ABS(3-IS)
  I1 = MAX(I1,1)
  FLGJY = 1.0E0
  call ASYJY(JAIRY,X,FN,FLGJY,I1,TEMP(IS),WK,IFLW)
  if ( IFLW /= 0) go to 380
  go to (320, 450, 620), IS
  310 TEMP(1) = TEMP(3)
  KT = 1
  320 IS = 2
  FNI = FNI - 1.0E0
  DFN = FNI + FNF
  FN = DFN
  if ( I1 == 2) go to 450
  go to 130
!
!     SERIES FOR (X/2)**2 <= NU+1
!
  330 CONTINUE
  GLN = ALNGAM(FNP1)
  ARG = FN*XO2L - GLN
  if (ARG < (-ELIM1)) go to 400
  EARG = EXP(ARG)
  340 CONTINUE
  S = 1.0E0
  if (X < TOL) go to 360
  AK = 3.0E0
  T2 = 1.0E0
  T = 1.0E0
  S1 = FN
  DO 350 K=1,17
    S2 = T2 + S1
    T = -T*SXO2/S2
    S = S + T
    if (ABS(T) < TOL) go to 360
    T2 = T2 + AK
    AK = AK + 2.0E0
    S1 = S1 + FN
  350 CONTINUE
  360 CONTINUE
  TEMP(IS) = S*EARG
  go to (370, 450, 610), IS
  370 EARG = EARG*FN/XO2
  FNI = FNI - 1.0E0
  DFN = FNI + FNF
  FN = DFN
  IS = 2
  go to 340
!
!     SET UNDERFLOW VALUE AND UPDATE PARAMETERS
!     UNDERFLOW CAN ONLY OCCUR FOR NS=0 SINCE THE ORDER MUST BE
!     LARGER THAN 36. THEREFORE, NS NEED NOT BE CONSIDERED.
!
  380 Y(NN) = 0.0E0
  NN = NN - 1
  FNI = FNI - 1.0E0
  DFN = FNI + FNF
  FN = DFN
  if (NN-1) 440, 390, 130
  390 KT = 2
  IS = 2
  go to 130
  400 Y(NN) = 0.0E0
  NN = NN - 1
  FNP1 = FN
  FNI = FNI - 1.0E0
  DFN = FNI + FNF
  FN = DFN
  if (NN-1) 440, 410, 420
  410 KT = 2
  IS = 2
  420 if (SXO2 <= FNP1) go to 430
  go to 130
  430 ARG = ARG - XO2L + LOG(FNP1)
  if (ARG < (-ELIM1)) go to 400
  go to 330
  440 NZ = N - NN
  return
!
!     BACKWARD RECURSION SECTION
!
  450 CONTINUE
  if ( NS /= 0) go to 451
  NZ = N - NN
  if (KT == 2) go to 470
!     BACKWARD RECUR FROM INDEX ALPHA+NN-1 TO ALPHA
  Y(NN) = TEMP(1)
  Y(NN-1) = TEMP(2)
  if (NN == 2) RETURN
  451 CONTINUE
  TRX = 2.0E0/X
  DTM = FNI
  TM = (DTM+FNF)*TRX
  AK=1.0E0
  TA=TEMP(1)
  TB=TEMP(2)
  if ( ABS(TA) > SLIM) go to 455
  TA=TA*RTOL
  TB=TB*RTOL
  AK=TOL
  455 CONTINUE
  KK=2
  IN=NS-1
  if ( IN == 0) go to 690
  if ( NS /= 0) go to 670
  K=NN-2
  DO 460 I=3,NN
    S=TB
    TB=TM*TB-TA
    TA=S
    Y(K)=TB*AK
    K=K-1
    DTM = DTM - 1.0E0
    TM = (DTM+FNF)*TRX
  460 CONTINUE
  return
  470 Y(1) = TEMP(2)
  return
!
!     ASYMPTOTIC EXPANSION FOR X TO INFINITY WITH FORWARD RECURSION IN
!     OSCILLATORY REGION X > MAX(20, NU), PROVIDED THE LAST MEMBER
!     OF THE SEQUENCE IS ALSO IN THE REGION.
!
  480 CONTINUE
  IN = INT(ALPHA-TAU+2.0E0)
  if (IN <= 0) go to 490
  IDALP = IALP - IN - 1
  KT = 1
  go to 500
  490 CONTINUE
  IDALP = IALP
  IN = 0
  500 IS = KT
  FIDAL = IDALP
  DALPHA = FIDAL + FNF
  ARG = X - PIDT*DALPHA - PDF
  SA = SIN(ARG)
  SB = COS(ARG)
  COEF = RTTP/RTX
  ETX = 8.0E0*X
  510 CONTINUE
  DTM = FIDAL + FIDAL
  DTM = DTM*DTM
  TM = 0.0E0
  if (FIDAL == 0.0E0 .AND. ABS(FNF) < TOL) go to 520
  TM = 4.0E0*FNF*(FIDAL+FIDAL+FNF)
  520 CONTINUE
  TRX = DTM - 1.0E0
  T2 = (TRX+TM)/ETX
  S2 = T2
  RELB = TOL*ABS(T2)
  T1 = ETX
  S1 = 1.0E0
  FN = 1.0E0
  AK = 8.0E0
  DO 530 K=1,13
    T1 = T1 + ETX
    FN = FN + AK
    TRX = DTM - FN
    AP = TRX + TM
    T2 = -T2*AP/T1
    S1 = S1 + T2
    T1 = T1 + ETX
    AK = AK + 8.0E0
    FN = FN + AK
    TRX = DTM - FN
    AP = TRX + TM
    T2 = T2*AP/T1
    S2 = S2 + T2
    if (ABS(T2) <= RELB) go to 540
    AK = AK + 8.0E0
  530 CONTINUE
  540 TEMP(IS) = COEF*(S1*SB-S2*SA)
  if ( IS == 2) go to 560
  FIDAL = FIDAL + 1.0E0
  DALPHA = FIDAL + FNF
  IS = 2
  TB = SA
  SA = -SB
  SB = TB
  go to 510
!
!     FORWARD RECURSION SECTION
!
  560 if (KT == 2) go to 470
  S1 = TEMP(1)
  S2 = TEMP(2)
  TX = 2.0E0/X
  TM = DALPHA*TX
  if (IN == 0) go to 580
!
!     FORWARD RECUR TO INDEX ALPHA
!
  DO 570 I=1,IN
    S = S2
    S2 = TM*S2 - S1
    TM = TM + TX
    S1 = S
  570 CONTINUE
  if (NN == 1) go to 600
  S = S2
  S2 = TM*S2 - S1
  TM = TM + TX
  S1 = S
  580 CONTINUE
!
!     FORWARD RECUR FROM INDEX ALPHA TO ALPHA+N-1
!
  Y(1) = S1
  Y(2) = S2
  if (NN == 2) RETURN
  DO 590 I=3,NN
    Y(I) = TM*Y(I-1) - Y(I-2)
    TM = TM + TX
  590 CONTINUE
  return
  600 Y(1) = S2
  return
!
!     BACKWARD RECURSION WITH NORMALIZATION BY
!     ASYMPTOTIC EXPANSION FOR NU TO INFINITY OR POWER SERIES.
!
  610 CONTINUE
!     COMPUTATION OF LAST ORDER FOR SERIES NORMALIZATION
  AKM = MAX(3.0E0-FN,0.0E0)
  KM = INT(AKM)
  TFN = FN + KM
  TA = (GLN+TFN-0.9189385332E0-0.0833333333E0/TFN)/(TFN+0.5E0)
  TA = XO2L - TA
  TB = -(1.0E0-1.5E0/TFN)/TFN
  AKM = TOLLN/(-TA+SQRT(TA*TA-TOLLN*TB)) + 1.5E0
  IN = KM + INT(AKM)
  go to 660
  620 CONTINUE
!     COMPUTATION OF LAST ORDER FOR ASYMPTOTIC EXPANSION NORMALIZATION
  GLN = WK(3) + WK(2)
  if (WK(6) > 30.0E0) go to 640
  RDEN = (PP(4)*WK(6)+PP(3))*WK(6) + 1.0E0
  RZDEN = PP(1) + PP(2)*WK(6)
  TA = RZDEN/RDEN
  if (WK(1) < 0.10E0) go to 630
  TB = GLN/WK(5)
  go to 650
  630 TB=(1.259921049E0+(0.1679894730E0+0.0887944358E0*WK(1))*WK(1)) &
   /WK(7)
  go to 650
  640 CONTINUE
  TA = 0.5E0*TOLLN/WK(4)
  TA=((0.0493827160E0*TA-0.1111111111E0)*TA+0.6666666667E0)*TA*WK(6)
  if (WK(1) < 0.10E0) go to 630
  TB = GLN/WK(5)
  650 IN = INT(TA/TB+1.5E0)
  if (IN > INLIM) go to 310
  660 CONTINUE
  DTM = FNI + IN
  TRX = 2.0E0/X
  TM = (DTM+FNF)*TRX
  TA = 0.0E0
  TB = TOL
  KK = 1
  AK=1.0E0
  670 CONTINUE
!
!     BACKWARD RECUR UNINDEXED AND SCALE WHEN MAGNITUDES ARE CLOSE TO
!     UNDERFLOW LIMITS (LESS THAN SLIM=R1MACH(1)*1.0E+3/TOL)
!
  DO 680 I=1,IN
    S = TB
    TB = TM*TB - TA
    TA = S
    DTM = DTM - 1.0E0
    TM = (DTM+FNF)*TRX
  680 CONTINUE
!     NORMALIZATION
  if (KK /= 1) go to 690
  S=TEMP(3)
  SA=TA/TB
  TA=S
  TB=S
  if ( ABS(S) > SLIM) go to 685
  TA=TA*RTOL
  TB=TB*RTOL
  AK=TOL
  685 CONTINUE
  TA=TA*SA
  KK = 2
  IN = NS
  if (NS /= 0) go to 670
  690 Y(NN) = TB*AK
  NZ = N - NN
  if (NN == 1) RETURN
  K = NN - 1
  S=TB
  TB = TM*TB - TA
  TA=S
  Y(K)=TB*AK
  if (NN == 2) RETURN
  DTM = DTM - 1.0E0
  TM = (DTM+FNF)*TRX
  K=NN-2
!
!     BACKWARD RECUR INDEXED
!
  DO 700 I=3,NN
    S=TB
    TB = TM*TB - TA
    TA=S
    Y(K)=TB*AK
    DTM = DTM - 1.0E0
    TM = (DTM+FNF)*TRX
    K = K - 1
  700 CONTINUE
  return
!
!
!
  710 CONTINUE
  call XERMSG ('SLATEC', 'BESJ', 'ORDER, ALPHA, LESS THAN ZERO.', &
     2, 1)
  return
  720 CONTINUE
  call XERMSG ('SLATEC', 'BESJ', 'N LESS THAN ONE.', 2, 1)
  return
  730 CONTINUE
  call XERMSG ('SLATEC', 'BESJ', 'X LESS THAN ZERO.', 2, 1)
  return
end
function BESJ0 (X)
!
!! BESJ0 computes the Bessel function of the first kind of order zero.
!
!***LIBRARY   SLATEC (FNLIB)
!***CATEGORY  C10A1
!***TYPE      SINGLE PRECISION (BESJ0-S, DBESJ0-D)
!***KEYWORDS  BESSEL FUNCTION, FIRST KIND, FNLIB, ORDER ZERO,
!             SPECIAL FUNCTIONS
!***AUTHOR  Fullerton, W., (LANL)
!***DESCRIPTION
!
! BESJ0(X) calculates the Bessel function of the first kind of
! order zero for real argument X.
!
! Series for BJ0        on the interval  0.          to  1.60000D+01
!                                        with weighted error   7.47E-18
!                                         log weighted error  17.13
!                               significant figures required  16.98
!                                    decimal places required  17.68
!
! Series for BM0        on the interval  0.          to  6.25000D-02
!                                        with weighted error   4.98E-17
!                                         log weighted error  16.30
!                               significant figures required  14.97
!                                    decimal places required  16.96
!
! Series for BTH0       on the interval  0.          to  6.25000D-02
!                                        with weighted error   3.67E-17
!                                         log weighted error  16.44
!                               significant figures required  15.53
!                                    decimal places required  17.13
!
!***REFERENCES  (NONE)
!***ROUTINES CALLED  CSEVL, INITS, R1MACH, XERMSG
!***REVISION HISTORY  (YYMMDD)
!   770401  DATE WRITTEN
!   890210  REVISION DATE from Version 3.2
!   891214  Prologue converted to Version 4.0 format.  (BAB)
!   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
!   900326  Removed duplicate information from DESCRIPTION section.
!           (WRB)
!***END PROLOGUE  BESJ0
  DIMENSION BJ0CS(13), BM0CS(21), BTH0CS(24)
  LOGICAL FIRST
  SAVE BJ0CS, BM0CS, BTH0CS, PI4, NTJ0, NTM0, NTTH0, XSML, XMAX, &
     FIRST
  DATA BJ0CS( 1) /    .100254161968939137E0 /
  DATA BJ0CS( 2) /   -.665223007764405132E0 /
  DATA BJ0CS( 3) /    .248983703498281314E0 /
  DATA BJ0CS( 4) /   -.0332527231700357697E0 /
  DATA BJ0CS( 5) /    .0023114179304694015E0 /
  DATA BJ0CS( 6) /   -.0000991127741995080E0 /
  DATA BJ0CS( 7) /    .0000028916708643998E0 /
  DATA BJ0CS( 8) /   -.0000000612108586630E0 /
  DATA BJ0CS( 9) /    .0000000009838650793E0 /
  DATA BJ0CS(10) /   -.0000000000124235515E0 /
  DATA BJ0CS(11) /    .0000000000001265433E0 /
  DATA BJ0CS(12) /   -.0000000000000010619E0 /
  DATA BJ0CS(13) /    .0000000000000000074E0 /
  DATA BM0CS( 1) /    .09284961637381644E0 /
  DATA BM0CS( 2) /   -.00142987707403484E0 /
  DATA BM0CS( 3) /    .00002830579271257E0 /
  DATA BM0CS( 4) /   -.00000143300611424E0 /
  DATA BM0CS( 5) /    .00000012028628046E0 /
  DATA BM0CS( 6) /   -.00000001397113013E0 /
  DATA BM0CS( 7) /    .00000000204076188E0 /
  DATA BM0CS( 8) /   -.00000000035399669E0 /
  DATA BM0CS( 9) /    .00000000007024759E0 /
  DATA BM0CS(10) /   -.00000000001554107E0 /
  DATA BM0CS(11) /    .00000000000376226E0 /
  DATA BM0CS(12) /   -.00000000000098282E0 /
  DATA BM0CS(13) /    .00000000000027408E0 /
  DATA BM0CS(14) /   -.00000000000008091E0 /
  DATA BM0CS(15) /    .00000000000002511E0 /
  DATA BM0CS(16) /   -.00000000000000814E0 /
  DATA BM0CS(17) /    .00000000000000275E0 /
  DATA BM0CS(18) /   -.00000000000000096E0 /
  DATA BM0CS(19) /    .00000000000000034E0 /
  DATA BM0CS(20) /   -.00000000000000012E0 /
  DATA BM0CS(21) /    .00000000000000004E0 /
  DATA BTH0CS( 1) /   -.24639163774300119E0 /
  DATA BTH0CS( 2) /    .001737098307508963E0 /
  DATA BTH0CS( 3) /   -.000062183633402968E0 /
  DATA BTH0CS( 4) /    .000004368050165742E0 /
  DATA BTH0CS( 5) /   -.000000456093019869E0 /
  DATA BTH0CS( 6) /    .000000062197400101E0 /
  DATA BTH0CS( 7) /   -.000000010300442889E0 /
  DATA BTH0CS( 8) /    .000000001979526776E0 /
  DATA BTH0CS( 9) /   -.000000000428198396E0 /
  DATA BTH0CS(10) /    .000000000102035840E0 /
  DATA BTH0CS(11) /   -.000000000026363898E0 /
  DATA BTH0CS(12) /    .000000000007297935E0 /
  DATA BTH0CS(13) /   -.000000000002144188E0 /
  DATA BTH0CS(14) /    .000000000000663693E0 /
  DATA BTH0CS(15) /   -.000000000000215126E0 /
  DATA BTH0CS(16) /    .000000000000072659E0 /
  DATA BTH0CS(17) /   -.000000000000025465E0 /
  DATA BTH0CS(18) /    .000000000000009229E0 /
  DATA BTH0CS(19) /   -.000000000000003448E0 /
  DATA BTH0CS(20) /    .000000000000001325E0 /
  DATA BTH0CS(21) /   -.000000000000000522E0 /
  DATA BTH0CS(22) /    .000000000000000210E0 /
  DATA BTH0CS(23) /   -.000000000000000087E0 /
  DATA BTH0CS(24) /    .000000000000000036E0 /
  DATA PI4 / 0.78539816339744831E0 /
  DATA FIRST /.TRUE./
!***FIRST EXECUTABLE STATEMENT  BESJ0
  if (FIRST) THEN
     NTJ0 = INITS (BJ0CS, 13, 0.1*R1MACH(3))
     NTM0 = INITS (BM0CS, 21, 0.1*R1MACH(3))
     NTTH0 = INITS (BTH0CS, 24, 0.1*R1MACH(3))
!
     XSML = SQRT (8.0*R1MACH(3))
     XMAX = 1.0/R1MACH(4)
  end if
  FIRST = .FALSE.
!
  Y = ABS(X)
  if (Y > 4.0) go to 20
!
  BESJ0 = 1.0
  if (Y > XSML) BESJ0 = CSEVL (.125*Y*Y-1., BJ0CS, NTJ0)
  return
!
 20   if (Y  >  XMAX) call XERMSG ('SLATEC', 'BESJ0', &
     'NO PRECISION BECAUSE ABS(X) IS TOO BIG', 1, 2)
!
  Z = 32.0/Y**2 - 1.0
  AMPL = (0.75 + CSEVL (Z, BM0CS, NTM0)) / SQRT(Y)
  THETA = Y - PI4 + CSEVL (Z, BTH0CS, NTTH0) / Y
  BESJ0 = AMPL * COS (THETA)
!
  return
end
function BESJ1 (X)
!
!! BESJ1 computes the Bessel function of the first kind of order one.
!
!***LIBRARY   SLATEC (FNLIB)
!***CATEGORY  C10A1
!***TYPE      SINGLE PRECISION (BESJ1-S, DBESJ1-D)
!***KEYWORDS  BESSEL FUNCTION, FIRST KIND, FNLIB, ORDER ONE,
!             SPECIAL FUNCTIONS
!***AUTHOR  Fullerton, W., (LANL)
!***DESCRIPTION
!
! BESJ1(X) calculates the Bessel function of the first kind of
! order one for real argument X.
!
! Series for BJ1        on the interval  0.          to  1.60000D+01
!                                        with weighted error   4.48E-17
!                                         log weighted error  16.35
!                               significant figures required  15.77
!                                    decimal places required  16.89
!
! Series for BM1        on the interval  0.          to  6.25000D-02
!                                        with weighted error   5.61E-17
!                                         log weighted error  16.25
!                               significant figures required  14.97
!                                    decimal places required  16.91
!
! Series for BTH1       on the interval  0.          to  6.25000D-02
!                                        with weighted error   4.10E-17
!                                         log weighted error  16.39
!                               significant figures required  15.96
!                                    decimal places required  17.08
!
!***REFERENCES  (NONE)
!***ROUTINES CALLED  CSEVL, INITS, R1MACH, XERMSG
!***REVISION HISTORY  (YYMMDD)
!   780601  DATE WRITTEN
!   890210  REVISION DATE from Version 3.2
!   891214  Prologue converted to Version 4.0 format.  (BAB)
!   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
!   900326  Removed duplicate information from DESCRIPTION section.
!           (WRB)
!***END PROLOGUE  BESJ1
  DIMENSION BJ1CS(12), BM1CS(21), BTH1CS(24)
  LOGICAL FIRST
  SAVE BJ1CS, BM1CS, BTH1CS, PI4, NTJ1, NTM1, NTTH1, &
   XSML, XMIN, XMAX, FIRST
  DATA BJ1CS( 1) /   -.11726141513332787E0 /
  DATA BJ1CS( 2) /   -.25361521830790640E0 /
  DATA BJ1CS( 3) /    .050127080984469569E0 /
  DATA BJ1CS( 4) /   -.004631514809625081E0 /
  DATA BJ1CS( 5) /    .000247996229415914E0 /
  DATA BJ1CS( 6) /   -.000008678948686278E0 /
  DATA BJ1CS( 7) /    .000000214293917143E0 /
  DATA BJ1CS( 8) /   -.000000003936093079E0 /
  DATA BJ1CS( 9) /    .000000000055911823E0 /
  DATA BJ1CS(10) /   -.000000000000632761E0 /
  DATA BJ1CS(11) /    .000000000000005840E0 /
  DATA BJ1CS(12) /   -.000000000000000044E0 /
  DATA BM1CS( 1) /    .1047362510931285E0 /
  DATA BM1CS( 2) /    .00442443893702345E0 /
  DATA BM1CS( 3) /   -.00005661639504035E0 /
  DATA BM1CS( 4) /    .00000231349417339E0 /
  DATA BM1CS( 5) /   -.00000017377182007E0 /
  DATA BM1CS( 6) /    .00000001893209930E0 /
  DATA BM1CS( 7) /   -.00000000265416023E0 /
  DATA BM1CS( 8) /    .00000000044740209E0 /
  DATA BM1CS( 9) /   -.00000000008691795E0 /
  DATA BM1CS(10) /    .00000000001891492E0 /
  DATA BM1CS(11) /   -.00000000000451884E0 /
  DATA BM1CS(12) /    .00000000000116765E0 /
  DATA BM1CS(13) /   -.00000000000032265E0 /
  DATA BM1CS(14) /    .00000000000009450E0 /
  DATA BM1CS(15) /   -.00000000000002913E0 /
  DATA BM1CS(16) /    .00000000000000939E0 /
  DATA BM1CS(17) /   -.00000000000000315E0 /
  DATA BM1CS(18) /    .00000000000000109E0 /
  DATA BM1CS(19) /   -.00000000000000039E0 /
  DATA BM1CS(20) /    .00000000000000014E0 /
  DATA BM1CS(21) /   -.00000000000000005E0 /
  DATA BTH1CS( 1) /    .74060141026313850E0 /
  DATA BTH1CS( 2) /   -.004571755659637690E0 /
  DATA BTH1CS( 3) /    .000119818510964326E0 /
  DATA BTH1CS( 4) /   -.000006964561891648E0 /
  DATA BTH1CS( 5) /    .000000655495621447E0 /
  DATA BTH1CS( 6) /   -.000000084066228945E0 /
  DATA BTH1CS( 7) /    .000000013376886564E0 /
  DATA BTH1CS( 8) /   -.000000002499565654E0 /
  DATA BTH1CS( 9) /    .000000000529495100E0 /
  DATA BTH1CS(10) /   -.000000000124135944E0 /
  DATA BTH1CS(11) /    .000000000031656485E0 /
  DATA BTH1CS(12) /   -.000000000008668640E0 /
  DATA BTH1CS(13) /    .000000000002523758E0 /
  DATA BTH1CS(14) /   -.000000000000775085E0 /
  DATA BTH1CS(15) /    .000000000000249527E0 /
  DATA BTH1CS(16) /   -.000000000000083773E0 /
  DATA BTH1CS(17) /    .000000000000029205E0 /
  DATA BTH1CS(18) /   -.000000000000010534E0 /
  DATA BTH1CS(19) /    .000000000000003919E0 /
  DATA BTH1CS(20) /   -.000000000000001500E0 /
  DATA BTH1CS(21) /    .000000000000000589E0 /
  DATA BTH1CS(22) /   -.000000000000000237E0 /
  DATA BTH1CS(23) /    .000000000000000097E0 /
  DATA BTH1CS(24) /   -.000000000000000040E0 /
  DATA PI4 / 0.78539816339744831E0 /
  DATA FIRST /.TRUE./
!***FIRST EXECUTABLE STATEMENT  BESJ1
  if (FIRST) THEN
     NTJ1 = INITS (BJ1CS, 12, 0.1*R1MACH(3))
     NTM1 = INITS (BM1CS, 21, 0.1*R1MACH(3))
     NTTH1 = INITS (BTH1CS, 24, 0.1*R1MACH(3))
!
     XSML = SQRT (8.0*R1MACH(3))
     XMIN = 2.0*R1MACH(1)
     XMAX = 1.0/R1MACH(4)
  end if
  FIRST = .FALSE.
!
  Y = ABS(X)
  if (Y > 4.0) go to 20
!
  BESJ1 = 0.
  if (Y == 0.0) RETURN
  if (Y  <=  XMIN) call XERMSG ('SLATEC', 'BESJ1', &
     'ABS(X) SO SMALL J1 UNDERFLOWS', 1, 1)
  if (Y > XMIN) BESJ1 = 0.5*X
  if (Y > XSML) BESJ1 = X * (.25 + CSEVL(.125*Y*Y-1., BJ1CS, NTJ1))
  return
!
 20   if (Y  >  XMAX) call XERMSG ('SLATEC', 'BESJ1', &
     'NO PRECISION BECAUSE ABS(X) IS TOO BIG', 2, 2)
  Z = 32.0/Y**2 - 1.0
  AMPL = (0.75 + CSEVL (Z, BM1CS, NTM1)) / SQRT(Y)
  THETA = Y - 3.0*PI4 + CSEVL (Z, BTH1CS, NTTH1) / Y
  BESJ1 = SIGN (AMPL, X) * COS (THETA)
!
  return
end

subroutine ASYJY (FUNJY, X, FNU, FLGJY, IN, Y, WK, IFLW)
!
!! ASYJY is subsidiary to BESJ and BESY.
!
!***LIBRARY   SLATEC
!***TYPE      SINGLE PRECISION (ASYJY-S, DASYJY-D)
!***AUTHOR  Amos, D. E., (SNLA)
!***DESCRIPTION
!
!                 ASYJY computes Bessel functions J and Y
!               for arguments X > 0.0 and orders FNU >= 35.0
!               on FLGJY = 1 and FLGJY = -1 respectively
!
!                                  INPUT
!
!      FUNJY - external function JAIRY or YAIRY
!          X - argument, X > 0.0E0
!        FNU - order of the first Bessel function
!      FLGJY - selection flag
!              FLGJY =  1.0E0 gives the J function
!              FLGJY = -1.0E0 gives the Y function
!         IN - number of functions desired, IN = 1 or 2
!
!                                  OUTPUT
!
!         Y  - a vector whose first in components contain the sequence
!       IFLW - a flag indicating underflow or overflow
!                    return variables for BESJ only
!      WK(1) = 1 - (X/FNU)**2 = W**2
!      WK(2) = SQRT(ABS(WK(1)))
!      WK(3) = ABS(WK(2) - ATAN(WK(2)))  or
!              ABS(LN((1 + WK(2))/(X/FNU)) - WK(2))
!            = ABS((2/3)*ZETA**(3/2))
!      WK(4) = FNU*WK(3)
!      WK(5) = (1.5*WK(3)*FNU)**(1/3) = SQRT(ZETA)*FNU**(1/3)
!      WK(6) = SIGN(1.,W**2)*WK(5)**2 = SIGN(1.,W**2)*ZETA*FNU**(2/3)
!      WK(7) = FNU**(1/3)
!
!     Abstract
!         ASYJY implements the uniform asymptotic expansion of
!         the J and Y Bessel functions for FNU >= 35 and real
!         X > 0.0E0. The forms are identical except for a change
!         in sign of some of the terms. This change in sign is
!         accomplished by means of the flag FLGJY = 1 or -1. On
!         FLGJY = 1 the AIRY functions AI(X) and DAI(X) are
!         supplied by the external function JAIRY, and on
!         FLGJY = -1 the AIRY functions BI(X) and DBI(X) are
!         supplied by the external function YAIRY.
!
!***SEE ALSO  BESJ, BESY
!***ROUTINES CALLED  I1MACH, R1MACH
!***REVISION HISTORY  (YYMMDD)
!   750101  DATE WRITTEN
!   890531  Changed all specific intrinsics to generic.  (WRB)
!   891009  Removed unreferenced variable.  (WRB)
!   891214  Prologue converted to Version 4.0 format.  (BAB)
!   900328  Added TYPE section.  (WRB)
!   910408  Updated the AUTHOR section.  (WRB)
!***END PROLOGUE  ASYJY
  INTEGER I, IFLW, IN, J, JN,JR,JU,K, KB,KLAST,KMAX,KP1, KS, KSP1, &
   KSTEMP, L, LR, LRP1, ISETA, ISETB
  INTEGER I1MACH
  REAL ABW2, AKM, ALFA, ALFA1, ALFA2, AP, AR, ASUM, AZ, &
   BETA, BETA1, BETA2, BETA3, BR, BSUM, C, CON1, CON2, &
   CON548,CR,CRZ32, DFI,ELIM, DR,FI, FLGJY, FN, FNU, &
   FN2, GAMA, PHI,  RCZ, RDEN, RELB, RFN2,  RTZ, RZDEN, &
   SA, SB, SUMA, SUMB, S1, TA, TAU, TB, TFN, TOL, TOLS, T2, UPOL, &
    WK, X, XX, Y, Z, Z32
  REAL R1MACH
  DIMENSION Y(*), WK(*), C(65)
  DIMENSION ALFA(26,4), BETA(26,5)
  DIMENSION ALFA1(26,2), ALFA2(26,2)
  DIMENSION BETA1(26,2), BETA2(26,2), BETA3(26,1)
  DIMENSION GAMA(26), KMAX(5), AR(8), BR(10), UPOL(10)
  DIMENSION CR(10), DR(10)
  EQUIVALENCE (ALFA(1,1),ALFA1(1,1))
  EQUIVALENCE (ALFA(1,3),ALFA2(1,1))
  EQUIVALENCE (BETA(1,1),BETA1(1,1))
  EQUIVALENCE (BETA(1,3),BETA2(1,1))
  EQUIVALENCE (BETA(1,5),BETA3(1,1))
  SAVE TOLS, CON1, CON2, CON548, AR, BR, C, ALFA1, ALFA2, &
   BETA1, BETA2, BETA3, GAMA
  DATA TOLS            /-6.90775527898214E+00/
  DATA CON1,CON2,CON548/ &
   6.66666666666667E-01, 3.33333333333333E-01, 1.04166666666667E-01/
  DATA  AR(1),  AR(2),  AR(3),  AR(4),  AR(5),  AR(6),  AR(7), &
        AR(8)          / 8.35503472222222E-02, 1.28226574556327E-01, &
   2.91849026464140E-01, 8.81627267443758E-01, 3.32140828186277E+00, &
   1.49957629868626E+01, 7.89230130115865E+01, 4.74451538868264E+02/
  DATA  BR(1), BR(2), BR(3), BR(4), BR(5), BR(6), BR(7), BR(8), &
        BR(9), BR(10)  /-1.45833333333333E-01,-9.87413194444444E-02, &
  -1.43312053915895E-01,-3.17227202678414E-01,-9.42429147957120E-01, &
  -3.51120304082635E+00,-1.57272636203680E+01,-8.22814390971859E+01, &
  -4.92355370523671E+02,-3.31621856854797E+03/
  DATA C(1), C(2), C(3), C(4), C(5), C(6), C(7), C(8), C(9), C(10), &
       C(11), C(12), C(13), C(14), C(15), C(16), C(17), C(18), &
       C(19), C(20), C(21), C(22), C(23), C(24)/ &
         -2.08333333333333E-01,        1.25000000000000E-01, &
          3.34201388888889E-01,       -4.01041666666667E-01, &
          7.03125000000000E-02,       -1.02581259645062E+00, &
          1.84646267361111E+00,       -8.91210937500000E-01, &
          7.32421875000000E-02,        4.66958442342625E+00, &
         -1.12070026162230E+01,        8.78912353515625E+00, &
         -2.36408691406250E+00,        1.12152099609375E-01, &
         -2.82120725582002E+01,        8.46362176746007E+01, &
         -9.18182415432400E+01,        4.25349987453885E+01, &
         -7.36879435947963E+00,        2.27108001708984E-01, &
          2.12570130039217E+02,       -7.65252468141182E+02, &
          1.05999045252800E+03,       -6.99579627376133E+02/
  DATA C(25), C(26), C(27), C(28), C(29), C(30), C(31), C(32), &
       C(33), C(34), C(35), C(36), C(37), C(38), C(39), C(40), &
       C(41), C(42), C(43), C(44), C(45), C(46), C(47), C(48)/ &
          2.18190511744212E+02,       -2.64914304869516E+01, &
          5.72501420974731E-01,       -1.91945766231841E+03, &
          8.06172218173731E+03,       -1.35865500064341E+04, &
          1.16553933368645E+04,       -5.30564697861340E+03, &
          1.20090291321635E+03,       -1.08090919788395E+02, &
          1.72772750258446E+00,        2.02042913309661E+04, &
         -9.69805983886375E+04,        1.92547001232532E+05, &
         -2.03400177280416E+05,        1.22200464983017E+05, &
         -4.11926549688976E+04,        7.10951430248936E+03, &
         -4.93915304773088E+02,        6.07404200127348E+00, &
         -2.42919187900551E+05,        1.31176361466298E+06, &
         -2.99801591853811E+06,        3.76327129765640E+06/
  DATA C(49), C(50), C(51), C(52), C(53), C(54), C(55), C(56), &
       C(57), C(58), C(59), C(60), C(61), C(62), C(63), C(64), &
       C(65)/ &
         -2.81356322658653E+06,        1.26836527332162E+06, &
         -3.31645172484564E+05,        4.52187689813627E+04, &
         -2.49983048181121E+03,        2.43805296995561E+01, &
          3.28446985307204E+06,       -1.97068191184322E+07, &
          5.09526024926646E+07,       -7.41051482115327E+07, &
          6.63445122747290E+07,       -3.75671766607634E+07, &
          1.32887671664218E+07,       -2.78561812808645E+06, &
          3.08186404612662E+05,       -1.38860897537170E+04, &
          1.10017140269247E+02/
  DATA ALFA1(1,1), ALFA1(2,1), ALFA1(3,1), ALFA1(4,1), ALFA1(5,1), &
       ALFA1(6,1), ALFA1(7,1), ALFA1(8,1), ALFA1(9,1), ALFA1(10,1), &
       ALFA1(11,1),ALFA1(12,1),ALFA1(13,1),ALFA1(14,1),ALFA1(15,1), &
       ALFA1(16,1),ALFA1(17,1),ALFA1(18,1),ALFA1(19,1),ALFA1(20,1), &
       ALFA1(21,1),ALFA1(22,1),ALFA1(23,1),ALFA1(24,1),ALFA1(25,1), &
       ALFA1(26,1)     /-4.44444444444444E-03,-9.22077922077922E-04, &
  -8.84892884892885E-05, 1.65927687832450E-04, 2.46691372741793E-04, &
   2.65995589346255E-04, 2.61824297061501E-04, 2.48730437344656E-04, &
   2.32721040083232E-04, 2.16362485712365E-04, 2.00738858762752E-04, &
   1.86267636637545E-04, 1.73060775917876E-04, 1.61091705929016E-04, &
   1.50274774160908E-04, 1.40503497391270E-04, 1.31668816545923E-04, &
   1.23667445598253E-04, 1.16405271474738E-04, 1.09798298372713E-04, &
   1.03772410422993E-04, 9.82626078369363E-05, 9.32120517249503E-05, &
   8.85710852478712E-05, 8.42963105715700E-05, 8.03497548407791E-05/
  DATA ALFA1(1,2), ALFA1(2,2), ALFA1(3,2), ALFA1(4,2), ALFA1(5,2), &
       ALFA1(6,2), ALFA1(7,2), ALFA1(8,2), ALFA1(9,2), ALFA1(10,2), &
       ALFA1(11,2),ALFA1(12,2),ALFA1(13,2),ALFA1(14,2),ALFA1(15,2), &
       ALFA1(16,2),ALFA1(17,2),ALFA1(18,2),ALFA1(19,2),ALFA1(20,2), &
       ALFA1(21,2),ALFA1(22,2),ALFA1(23,2),ALFA1(24,2),ALFA1(25,2), &
       ALFA1(26,2)     / 6.93735541354589E-04, 2.32241745182922E-04, &
  -1.41986273556691E-05,-1.16444931672049E-04,-1.50803558053049E-04, &
  -1.55121924918096E-04,-1.46809756646466E-04,-1.33815503867491E-04, &
  -1.19744975684254E-04,-1.06184319207974E-04,-9.37699549891194E-05, &
  -8.26923045588193E-05,-7.29374348155221E-05,-6.44042357721016E-05, &
  -5.69611566009369E-05,-5.04731044303562E-05,-4.48134868008883E-05, &
  -3.98688727717599E-05,-3.55400532972042E-05,-3.17414256609022E-05, &
  -2.83996793904175E-05,-2.54522720634871E-05,-2.28459297164725E-05, &
  -2.05352753106481E-05,-1.84816217627666E-05,-1.66519330021394E-05/
  DATA ALFA2(1,1), ALFA2(2,1), ALFA2(3,1), ALFA2(4,1), ALFA2(5,1), &
       ALFA2(6,1), ALFA2(7,1), ALFA2(8,1), ALFA2(9,1), ALFA2(10,1), &
       ALFA2(11,1),ALFA2(12,1),ALFA2(13,1),ALFA2(14,1),ALFA2(15,1), &
       ALFA2(16,1),ALFA2(17,1),ALFA2(18,1),ALFA2(19,1),ALFA2(20,1), &
       ALFA2(21,1),ALFA2(22,1),ALFA2(23,1),ALFA2(24,1),ALFA2(25,1), &
       ALFA2(26,1)     /-3.54211971457744E-04,-1.56161263945159E-04, &
   3.04465503594936E-05, 1.30198655773243E-04, 1.67471106699712E-04, &
   1.70222587683593E-04, 1.56501427608595E-04, 1.36339170977445E-04, &
   1.14886692029825E-04, 9.45869093034688E-05, 7.64498419250898E-05, &
   6.07570334965197E-05, 4.74394299290509E-05, 3.62757512005344E-05, &
   2.69939714979225E-05, 1.93210938247939E-05, 1.30056674793963E-05, &
   7.82620866744497E-06, 3.59257485819352E-06, 1.44040049814252E-07, &
  -2.65396769697939E-06,-4.91346867098486E-06,-6.72739296091248E-06, &
  -8.17269379678658E-06,-9.31304715093561E-06,-1.02011418798016E-05/
  DATA ALFA2(1,2), ALFA2(2,2), ALFA2(3,2), ALFA2(4,2), ALFA2(5,2), &
       ALFA2(6,2), ALFA2(7,2), ALFA2(8,2), ALFA2(9,2), ALFA2(10,2), &
       ALFA2(11,2),ALFA2(12,2),ALFA2(13,2),ALFA2(14,2),ALFA2(15,2), &
       ALFA2(16,2),ALFA2(17,2),ALFA2(18,2),ALFA2(19,2),ALFA2(20,2), &
       ALFA2(21,2),ALFA2(22,2),ALFA2(23,2),ALFA2(24,2),ALFA2(25,2), &
       ALFA2(26,2)     / 3.78194199201773E-04, 2.02471952761816E-04, &
  -6.37938506318862E-05,-2.38598230603006E-04,-3.10916256027362E-04, &
  -3.13680115247576E-04,-2.78950273791323E-04,-2.28564082619141E-04, &
  -1.75245280340847E-04,-1.25544063060690E-04,-8.22982872820208E-05, &
  -4.62860730588116E-05,-1.72334302366962E-05, 5.60690482304602E-06, &
   2.31395443148287E-05, 3.62642745856794E-05, 4.58006124490189E-05, &
   5.24595294959114E-05, 5.68396208545815E-05, 5.94349820393104E-05, &
   6.06478527578422E-05, 6.08023907788436E-05, 6.01577894539460E-05, &
   5.89199657344698E-05, 5.72515823777593E-05, 5.52804375585853E-05/
  DATA BETA1(1,1), BETA1(2,1), BETA1(3,1), BETA1(4,1), BETA1(5,1), &
       BETA1(6,1), BETA1(7,1), BETA1(8,1), BETA1(9,1), BETA1(10,1), &
       BETA1(11,1),BETA1(12,1),BETA1(13,1),BETA1(14,1),BETA1(15,1), &
       BETA1(16,1),BETA1(17,1),BETA1(18,1),BETA1(19,1),BETA1(20,1), &
       BETA1(21,1),BETA1(22,1),BETA1(23,1),BETA1(24,1),BETA1(25,1), &
       BETA1(26,1)     / 1.79988721413553E-02, 5.59964911064388E-03, &
   2.88501402231133E-03, 1.80096606761054E-03, 1.24753110589199E-03, &
   9.22878876572938E-04, 7.14430421727287E-04, 5.71787281789705E-04, &
   4.69431007606482E-04, 3.93232835462917E-04, 3.34818889318298E-04, &
   2.88952148495752E-04, 2.52211615549573E-04, 2.22280580798883E-04, &
   1.97541838033063E-04, 1.76836855019718E-04, 1.59316899661821E-04, &
   1.44347930197334E-04, 1.31448068119965E-04, 1.20245444949303E-04, &
   1.10449144504599E-04, 1.01828770740567E-04, 9.41998224204238E-05, &
   8.74130545753834E-05, 8.13466262162801E-05, 7.59002269646219E-05/
  DATA BETA1(1,2), BETA1(2,2), BETA1(3,2), BETA1(4,2), BETA1(5,2), &
       BETA1(6,2), BETA1(7,2), BETA1(8,2), BETA1(9,2), BETA1(10,2), &
       BETA1(11,2),BETA1(12,2),BETA1(13,2),BETA1(14,2),BETA1(15,2), &
       BETA1(16,2),BETA1(17,2),BETA1(18,2),BETA1(19,2),BETA1(20,2), &
       BETA1(21,2),BETA1(22,2),BETA1(23,2),BETA1(24,2),BETA1(25,2), &
       BETA1(26,2)     /-1.49282953213429E-03,-8.78204709546389E-04, &
  -5.02916549572035E-04,-2.94822138512746E-04,-1.75463996970783E-04, &
  -1.04008550460816E-04,-5.96141953046458E-05,-3.12038929076098E-05, &
  -1.26089735980230E-05,-2.42892608575730E-07, 8.05996165414274E-06, &
   1.36507009262147E-05, 1.73964125472926E-05, 1.98672978842134E-05, &
   2.14463263790823E-05, 2.23954659232457E-05, 2.28967783814713E-05, &
   2.30785389811178E-05, 2.30321976080909E-05, 2.28236073720349E-05, &
   2.25005881105292E-05, 2.20981015361991E-05, 2.16418427448104E-05, &
   2.11507649256221E-05, 2.06388749782171E-05, 2.01165241997082E-05/
  DATA BETA2(1,1), BETA2(2,1), BETA2(3,1), BETA2(4,1), BETA2(5,1), &
       BETA2(6,1), BETA2(7,1), BETA2(8,1), BETA2(9,1), BETA2(10,1), &
       BETA2(11,1),BETA2(12,1),BETA2(13,1),BETA2(14,1),BETA2(15,1), &
       BETA2(16,1),BETA2(17,1),BETA2(18,1),BETA2(19,1),BETA2(20,1), &
       BETA2(21,1),BETA2(22,1),BETA2(23,1),BETA2(24,1),BETA2(25,1), &
       BETA2(26,1)     / 5.52213076721293E-04, 4.47932581552385E-04, &
   2.79520653992021E-04, 1.52468156198447E-04, 6.93271105657044E-05, &
   1.76258683069991E-05,-1.35744996343269E-05,-3.17972413350427E-05, &
  -4.18861861696693E-05,-4.69004889379141E-05,-4.87665447413787E-05, &
  -4.87010031186735E-05,-4.74755620890087E-05,-4.55813058138628E-05, &
  -4.33309644511266E-05,-4.09230193157750E-05,-3.84822638603221E-05, &
  -3.60857167535411E-05,-3.37793306123367E-05,-3.15888560772110E-05, &
  -2.95269561750807E-05,-2.75978914828336E-05,-2.58006174666884E-05, &
  -2.41308356761280E-05,-2.25823509518346E-05,-2.11479656768913E-05/
  DATA BETA2(1,2), BETA2(2,2), BETA2(3,2), BETA2(4,2), BETA2(5,2), &
       BETA2(6,2), BETA2(7,2), BETA2(8,2), BETA2(9,2), BETA2(10,2), &
       BETA2(11,2),BETA2(12,2),BETA2(13,2),BETA2(14,2),BETA2(15,2), &
       BETA2(16,2),BETA2(17,2),BETA2(18,2),BETA2(19,2),BETA2(20,2), &
       BETA2(21,2),BETA2(22,2),BETA2(23,2),BETA2(24,2),BETA2(25,2), &
       BETA2(26,2)     /-4.74617796559960E-04,-4.77864567147321E-04, &
  -3.20390228067038E-04,-1.61105016119962E-04,-4.25778101285435E-05, &
   3.44571294294968E-05, 7.97092684075675E-05, 1.03138236708272E-04, &
   1.12466775262204E-04, 1.13103642108481E-04, 1.08651634848774E-04, &
   1.01437951597662E-04, 9.29298396593364E-05, 8.40293133016090E-05, &
   7.52727991349134E-05, 6.69632521975731E-05, 5.92564547323195E-05, &
   5.22169308826976E-05, 4.58539485165361E-05, 4.01445513891487E-05, &
   3.50481730031328E-05, 3.05157995034347E-05, 2.64956119950516E-05, &
   2.29363633690998E-05, 1.97893056664022E-05, 1.70091984636413E-05/
  DATA BETA3(1,1), BETA3(2,1), BETA3(3,1), BETA3(4,1), BETA3(5,1), &
       BETA3(6,1), BETA3(7,1), BETA3(8,1), BETA3(9,1), BETA3(10,1), &
       BETA3(11,1),BETA3(12,1),BETA3(13,1),BETA3(14,1),BETA3(15,1), &
       BETA3(16,1),BETA3(17,1),BETA3(18,1),BETA3(19,1),BETA3(20,1), &
       BETA3(21,1),BETA3(22,1),BETA3(23,1),BETA3(24,1),BETA3(25,1), &
       BETA3(26,1)     / 7.36465810572578E-04, 8.72790805146194E-04, &
   6.22614862573135E-04, 2.85998154194304E-04, 3.84737672879366E-06, &
  -1.87906003636972E-04,-2.97603646594555E-04,-3.45998126832656E-04, &
  -3.53382470916038E-04,-3.35715635775049E-04,-3.04321124789040E-04, &
  -2.66722723047613E-04,-2.27654214122820E-04,-1.89922611854562E-04, &
  -1.55058918599094E-04,-1.23778240761874E-04,-9.62926147717644E-05, &
  -7.25178327714425E-05,-5.22070028895634E-05,-3.50347750511901E-05, &
  -2.06489761035552E-05,-8.70106096849767E-06, 1.13698686675100E-06, &
   9.16426474122779E-06, 1.56477785428873E-05, 2.08223629482467E-05/
  DATA GAMA(1),   GAMA(2),   GAMA(3),   GAMA(4),   GAMA(5), &
       GAMA(6),   GAMA(7),   GAMA(8),   GAMA(9),   GAMA(10), &
       GAMA(11),  GAMA(12),  GAMA(13),  GAMA(14),  GAMA(15), &
       GAMA(16),  GAMA(17),  GAMA(18),  GAMA(19),  GAMA(20), &
       GAMA(21),  GAMA(22),  GAMA(23),  GAMA(24),  GAMA(25), &
       GAMA(26)        / 6.29960524947437E-01, 2.51984209978975E-01, &
   1.54790300415656E-01, 1.10713062416159E-01, 8.57309395527395E-02, &
   6.97161316958684E-02, 5.86085671893714E-02, 5.04698873536311E-02, &
   4.42600580689155E-02, 3.93720661543510E-02, 3.54283195924455E-02, &
   3.21818857502098E-02, 2.94646240791158E-02, 2.71581677112934E-02, &
   2.51768272973862E-02, 2.34570755306079E-02, 2.19508390134907E-02, &
   2.06210828235646E-02, 1.94388240897881E-02, 1.83810633800683E-02, &
   1.74293213231963E-02, 1.65685837786612E-02, 1.57865285987918E-02, &
   1.50729501494096E-02, 1.44193250839955E-02, 1.38184805735342E-02/
!***FIRST EXECUTABLE STATEMENT  ASYJY
  TA = R1MACH(3)
  TOL = MAX(TA,1.0E-15)
  TB = R1MACH(5)
  JU = I1MACH(12)
  if ( FLGJY == 1.0E0) go to 6
  JR = I1MACH(11)
  ELIM = -2.303E0*TB*(JU+JR)
  go to 7
    6 CONTINUE
  ELIM = -2.303E0*(TB*JU+3.0E0)
    7 CONTINUE
  FN = FNU
  IFLW = 0
  DO 170 JN=1,IN
    XX = X/FN
    WK(1) = 1.0E0 - XX*XX
    ABW2 = ABS(WK(1))
    WK(2) = SQRT(ABW2)
    WK(7) = FN**CON2
    if (ABW2 > 0.27750E0) go to 80
!
!     ASYMPTOTIC EXPANSION
!     CASES NEAR X=FN, ABS(1.-(X/FN)**2) <= 0.2775
!     COEFFICIENTS OF ASYMPTOTIC EXPANSION BY SERIES
!
!     ZETA AND TRUNCATION FOR A(ZETA) AND B(ZETA) SERIES
!
!     KMAX IS TRUNCATION INDEX FOR A(ZETA) AND B(ZETA) SERIES=MAX(2,SA)
!
    SA = 0.0E0
    if (ABW2 == 0.0E0) go to 10
    SA = TOLS/LOG(ABW2)
   10   SB = SA
    DO 20 I=1,5
      AKM = MAX(SA,2.0E0)
      KMAX(I) = INT(AKM)
      SA = SA + SB
   20   CONTINUE
    KB = KMAX(5)
    KLAST = KB - 1
    SA = GAMA(KB)
    DO 30 K=1,KLAST
      KB = KB - 1
      SA = SA*WK(1) + GAMA(KB)
   30   CONTINUE
    Z = WK(1)*SA
    AZ = ABS(Z)
    RTZ = SQRT(AZ)
    WK(3) = CON1*AZ*RTZ
    WK(4) = WK(3)*FN
    WK(5) = RTZ*WK(7)
    WK(6) = -WK(5)*WK(5)
    if ( Z <= 0.0E0) go to 35
    if ( WK(4) > ELIM) go to 75
    WK(6) = -WK(6)
   35   CONTINUE
    PHI = SQRT(SQRT(SA+SA+SA+SA))
!
!     B(ZETA) FOR S=0
!
    KB = KMAX(5)
    KLAST = KB - 1
    SB = BETA(KB,1)
    DO 40 K=1,KLAST
      KB = KB - 1
      SB = SB*WK(1) + BETA(KB,1)
   40   CONTINUE
    KSP1 = 1
    FN2 = FN*FN
    RFN2 = 1.0E0/FN2
    RDEN = 1.0E0
    ASUM = 1.0E0
    RELB = TOL*ABS(SB)
    BSUM = SB
    DO 60 KS=1,4
      KSP1 = KSP1 + 1
      RDEN = RDEN*RFN2
!
!     A(ZETA) AND B(ZETA) FOR S=1,2,3,4
!
      KSTEMP = 5 - KS
      KB = KMAX(KSTEMP)
      KLAST = KB - 1
      SA = ALFA(KB,KS)
      SB = BETA(KB,KSP1)
      DO 50 K=1,KLAST
        KB = KB - 1
        SA = SA*WK(1) + ALFA(KB,KS)
        SB = SB*WK(1) + BETA(KB,KSP1)
   50     CONTINUE
      TA = SA*RDEN
      TB = SB*RDEN
      ASUM = ASUM + TA
      BSUM = BSUM + TB
      if (ABS(TA) <= TOL .AND. ABS(TB) <= RELB) go to 70
   60   CONTINUE
   70   CONTINUE
    BSUM = BSUM/(FN*WK(7))
    go to 160
!
   75   CONTINUE
    IFLW = 1
    return
!
   80   CONTINUE
    UPOL(1) = 1.0E0
    TAU = 1.0E0/WK(2)
    T2 = 1.0E0/WK(1)
    if (WK(1) >= 0.0E0) go to 90
!
!     CASES FOR (X/FN) > SQRT(1.2775)
!
    WK(3) = ABS(WK(2)-ATAN(WK(2)))
    WK(4) = WK(3)*FN
    RCZ = -CON1/WK(4)
    Z32 = 1.5E0*WK(3)
    RTZ = Z32**CON2
    WK(5) = RTZ*WK(7)
    WK(6) = -WK(5)*WK(5)
    go to 100
   90   CONTINUE
!
!     CASES FOR (X/FN) < SQRT(0.7225)
!
    WK(3) = ABS(LOG((1.0E0+WK(2))/XX)-WK(2))
    WK(4) = WK(3)*FN
    RCZ = CON1/WK(4)
    if ( WK(4) > ELIM) go to 75
    Z32 = 1.5E0*WK(3)
    RTZ = Z32**CON2
    WK(7) = FN**CON2
    WK(5) = RTZ*WK(7)
    WK(6) = WK(5)*WK(5)
  100   CONTINUE
    PHI = SQRT((RTZ+RTZ)*TAU)
    TB = 1.0E0
    ASUM = 1.0E0
    TFN = TAU/FN
    RDEN=1.0E0/FN
    RFN2=RDEN*RDEN
    RDEN=1.0E0
    UPOL(2) = (C(1)*T2+C(2))*TFN
    CRZ32 = CON548*RCZ
    BSUM = UPOL(2) + CRZ32
    RELB = TOL*ABS(BSUM)
    AP = TFN
    KS = 0
    KP1 = 2
    RZDEN = RCZ
    L = 2
    ISETA=0
    ISETB=0
    DO 140 LR=2,8,2
!
!     COMPUTE TWO U POLYNOMIALS FOR NEXT A(ZETA) AND B(ZETA)
!
      LRP1 = LR + 1
      DO 120 K=LR,LRP1
        KS = KS + 1
        KP1 = KP1 + 1
        L = L + 1
        S1 = C(L)
        DO 110 J=2,KP1
          L = L + 1
          S1 = S1*T2 + C(L)
  110       CONTINUE
        AP = AP*TFN
        UPOL(KP1) = AP*S1
        CR(KS) = BR(KS)*RZDEN
        RZDEN = RZDEN*RCZ
        DR(KS) = AR(KS)*RZDEN
  120     CONTINUE
      SUMA = UPOL(LRP1)
      SUMB = UPOL(LR+2) + UPOL(LRP1)*CRZ32
      JU = LRP1
      DO 130 JR=1,LR
        JU = JU - 1
        SUMA = SUMA + CR(JR)*UPOL(JU)
        SUMB = SUMB + DR(JR)*UPOL(JU)
  130     CONTINUE
      RDEN=RDEN*RFN2
      TB = -TB
      if (WK(1) > 0.0E0) TB = ABS(TB)
      if (RDEN < TOL) go to 131
      ASUM = ASUM + SUMA*TB
      BSUM = BSUM + SUMB*TB
      go to 140
  131     if ( ISETA == 1) go to 132
      if ( ABS(SUMA) < TOL) ISETA=1
      ASUM=ASUM+SUMA*TB
  132     if ( ISETB == 1) go to 133
      if ( ABS(SUMB) < RELB) ISETB=1
      BSUM=BSUM+SUMB*TB
  133     if ( ISETA == 1 .AND. ISETB == 1) go to 150
  140   CONTINUE
  150   TB = WK(5)
    if (WK(1) > 0.0E0) TB = -TB
    BSUM = BSUM/TB
!
  160   CONTINUE
    call FUNJY(WK(6), WK(5), WK(4), FI, DFI)
    TA=1.0E0/TOL
    TB=R1MACH(1)*TA*1.0E+3
    if ( ABS(FI) > TB) go to 165
    FI=FI*TA
    DFI=DFI*TA
    PHI=PHI*TOL
  165   CONTINUE
    Y(JN) = FLGJY*PHI*(FI*ASUM+DFI*BSUM)/WK(7)
    FN = FN - FLGJY
  170 CONTINUE
  return
end

function INITS (OS, NOS, ETA)
!
!! INITS determines the number of terms needed in an orthogonal ...
!            polynomial series so that it meets a specified accuracy.
!
!***LIBRARY   SLATEC (FNLIB)
!***CATEGORY  C3A2
!***TYPE      SINGLE PRECISION (INITS-S, INITDS-D)
!***KEYWORDS  CHEBYSHEV, FNLIB, INITIALIZE, ORTHOGONAL POLYNOMIAL,
!             ORTHOGONAL SERIES, SPECIAL FUNCTIONS
!***AUTHOR  Fullerton, W., (LANL)
!***DESCRIPTION
!
!  Initialize the orthogonal series, represented by the array OS, so
!  that INITS is the number of terms needed to insure the error is no
!  larger than ETA.  Ordinarily, ETA will be chosen to be one-tenth
!  machine precision.
!
!             Input Arguments --
!   OS     single precision array of NOS coefficients in an orthogonal
!          series.
!   NOS    number of coefficients in OS.
!   ETA    single precision scalar containing requested accuracy of
!          series.
!
!***REFERENCES  (NONE)
!***ROUTINES CALLED  XERMSG
!***REVISION HISTORY  (YYMMDD)
!   770401  DATE WRITTEN
!   890831  Modified array declarations.  (WRB)
!   891115  Modified error message.  (WRB)
!   891115  REVISION DATE from Version 3.2
!   891214  Prologue converted to Version 4.0 format.  (BAB)
!   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
!***END PROLOGUE  INITS
  REAL OS(*)
!***FIRST EXECUTABLE STATEMENT  INITS
  if (NOS  <  1) call XERMSG ('SLATEC', 'INITS', &
     'Number of coefficients is less than 1', 2, 1)
!
  ERR = 0.
  DO 10 II = 1,NOS
    I = NOS + 1 - II
    ERR = ERR + ABS(OS(I))
    if (ERR > ETA) go to 20
   10 CONTINUE
!
   20 if (I  ==  NOS) call XERMSG ('SLATEC', 'INITS', &
     'Chebyshev series too short for specified accuracy', 1, 1)
  INITS = I
!
  return
end

subroutine JAIRY (X, RX, C, AI, DAI)
!
!! JAIRY is subsidiary to BESJ and BESY.
!
!***LIBRARY   SLATEC
!***TYPE      SINGLE PRECISION (JAIRY-S, DJAIRY-D)
!***AUTHOR  Amos, D. E., (SNLA)
!           Daniel, S. L., (SNLA)
!           Weston, M. K., (SNLA)
!***DESCRIPTION
!
!                  JAIRY computes the Airy function AI(X)
!                   and its derivative DAI(X) for ASYJY
!
!                                   INPUT
!
!         X - Argument, computed by ASYJY, X unrestricted
!        RX - RX=SQRT(ABS(X)), computed by ASYJY
!         C - C=2.*(ABS(X)**1.5)/3., computed by ASYJY
!
!                                  OUTPUT
!
!        AI - Value of function AI(X)
!       DAI - Value of the derivative DAI(X)
!
!***SEE ALSO  BESJ, BESY
!***ROUTINES CALLED  (NONE)
!***REVISION HISTORY  (YYMMDD)
!   750101  DATE WRITTEN
!   891009  Removed unreferenced variable.  (WRB)
!   891214  Prologue converted to Version 4.0 format.  (BAB)
!   900328  Added TYPE section.  (WRB)
!   910408  Updated the AUTHOR section.  (WRB)
!***END PROLOGUE  JAIRY
!
  INTEGER I, J, M1, M1D, M2, M2D, M3, M3D, M4, M4D, N1, N1D, N2, &
   N2D, N3, N3D, N4, N4D
  REAL A, AI, AJN, AJP, AK1, AK2, AK3, B, C, CCV, CON2, CON3, &
   CON4, CON5, CV, DA, DAI, DAJN, DAJP, DAK1, DAK2, DAK3, DB, EC, &
   E1, E2, FPI12, F1, F2, RTRX, RX, SCV, T, TEMP1, TEMP2, TT, X
  DIMENSION AJP(19), AJN(19), A(15), B(15)
  DIMENSION AK1(14), AK2(23), AK3(14)
  DIMENSION DAJP(19), DAJN(19), DA(15), DB(15)
  DIMENSION DAK1(14), DAK2(24), DAK3(14)
  SAVE N1, N2, N3, N4, M1, M2, M3, M4, FPI12, CON2, &
   CON3, CON4, CON5,AK1, AK2, AK3, AJP, AJN, A, B, &
   N1D, N2D, N3D, N4D, M1D, M2D, M3D, M4D, &
   DAK1, DAK2, DAK3, DAJP, DAJN, DA, DB
  DATA N1,N2,N3,N4/14,23,19,15/
  DATA M1,M2,M3,M4/12,21,17,13/
  DATA FPI12,CON2,CON3,CON4,CON5/ &
   1.30899693899575E+00, 5.03154716196777E+00, 3.80004589867293E-01, &
   8.33333333333333E-01, 8.66025403784439E-01/
  DATA AK1(1), AK1(2), AK1(3), AK1(4), AK1(5), AK1(6), AK1(7), &
       AK1(8), AK1(9), AK1(10),AK1(11),AK1(12),AK1(13), &
       AK1(14)         / 2.20423090987793E-01,-1.25290242787700E-01, &
   1.03881163359194E-02, 8.22844152006343E-04,-2.34614345891226E-04, &
   1.63824280172116E-05, 3.06902589573189E-07,-1.29621999359332E-07, &
   8.22908158823668E-09, 1.53963968623298E-11,-3.39165465615682E-11, &
   2.03253257423626E-12,-1.10679546097884E-14,-5.16169497785080E-15/
  DATA AK2(1), AK2(2), AK2(3), AK2(4), AK2(5), AK2(6), AK2(7), &
       AK2(8), AK2(9), AK2(10),AK2(11),AK2(12),AK2(13),AK2(14), &
       AK2(15),AK2(16),AK2(17),AK2(18),AK2(19),AK2(20),AK2(21), &
       AK2(22),AK2(23) / 2.74366150869598E-01, 5.39790969736903E-03, &
  -1.57339220621190E-03, 4.27427528248750E-04,-1.12124917399925E-04, &
   2.88763171318904E-05,-7.36804225370554E-06, 1.87290209741024E-06, &
  -4.75892793962291E-07, 1.21130416955909E-07,-3.09245374270614E-08, &
   7.92454705282654E-09,-2.03902447167914E-09, 5.26863056595742E-10, &
  -1.36704767639569E-10, 3.56141039013708E-11,-9.31388296548430E-12, &
   2.44464450473635E-12,-6.43840261990955E-13, 1.70106030559349E-13, &
  -4.50760104503281E-14, 1.19774799164811E-14,-3.19077040865066E-15/
  DATA AK3(1), AK3(2), AK3(3), AK3(4), AK3(5), AK3(6), AK3(7), &
       AK3(8), AK3(9), AK3(10),AK3(11),AK3(12),AK3(13), &
       AK3(14)         / 2.80271447340791E-01,-1.78127042844379E-03, &
   4.03422579628999E-05,-1.63249965269003E-06, 9.21181482476768E-08, &
  -6.52294330229155E-09, 5.47138404576546E-10,-5.24408251800260E-11, &
   5.60477904117209E-12,-6.56375244639313E-13, 8.31285761966247E-14, &
  -1.12705134691063E-14, 1.62267976598129E-15,-2.46480324312426E-16/
  DATA AJP(1), AJP(2), AJP(3), AJP(4), AJP(5), AJP(6), AJP(7), &
       AJP(8), AJP(9), AJP(10),AJP(11),AJP(12),AJP(13),AJP(14), &
       AJP(15),AJP(16),AJP(17),AJP(18), &
       AJP(19)         / 7.78952966437581E-02,-1.84356363456801E-01, &
   3.01412605216174E-02, 3.05342724277608E-02,-4.95424702513079E-03, &
  -1.72749552563952E-03, 2.43137637839190E-04, 5.04564777517082E-05, &
  -6.16316582695208E-06,-9.03986745510768E-07, 9.70243778355884E-08, &
   1.09639453305205E-08,-1.04716330588766E-09,-9.60359441344646E-11, &
   8.25358789454134E-12, 6.36123439018768E-13,-4.96629614116015E-14, &
  -3.29810288929615E-15, 2.35798252031104E-16/
  DATA AJN(1), AJN(2), AJN(3), AJN(4), AJN(5), AJN(6), AJN(7), &
       AJN(8), AJN(9), AJN(10),AJN(11),AJN(12),AJN(13),AJN(14), &
       AJN(15),AJN(16),AJN(17),AJN(18), &
       AJN(19)         / 3.80497887617242E-02,-2.45319541845546E-01, &
   1.65820623702696E-01, 7.49330045818789E-02,-2.63476288106641E-02, &
  -5.92535597304981E-03, 1.44744409589804E-03, 2.18311831322215E-04, &
  -4.10662077680304E-05,-4.66874994171766E-06, 7.15218807277160E-07, &
   6.52964770854633E-08,-8.44284027565946E-09,-6.44186158976978E-10, &
   7.20802286505285E-11, 4.72465431717846E-12,-4.66022632547045E-13, &
  -2.67762710389189E-14, 2.36161316570019E-15/
  DATA A(1),   A(2),   A(3),   A(4),   A(5),   A(6),   A(7), &
       A(8),   A(9),   A(10),  A(11),  A(12),  A(13),  A(14), &
       A(15)           / 4.90275424742791E-01, 1.57647277946204E-03, &
  -9.66195963140306E-05, 1.35916080268815E-07, 2.98157342654859E-07, &
  -1.86824767559979E-08,-1.03685737667141E-09, 3.28660818434328E-10, &
  -2.57091410632780E-11,-2.32357655300677E-12, 9.57523279048255E-13, &
  -1.20340828049719E-13,-2.90907716770715E-15, 4.55656454580149E-15, &
  -9.99003874810259E-16/
  DATA B(1),   B(2),   B(3),   B(4),   B(5),   B(6),   B(7), &
       B(8),   B(9),   B(10),  B(11),  B(12),  B(13),  B(14), &
       B(15)           / 2.78593552803079E-01,-3.52915691882584E-03, &
  -2.31149677384994E-05, 4.71317842263560E-06,-1.12415907931333E-07, &
  -2.00100301184339E-08, 2.60948075302193E-09,-3.55098136101216E-11, &
  -3.50849978423875E-11, 5.83007187954202E-12,-2.04644828753326E-13, &
  -1.10529179476742E-13, 2.87724778038775E-14,-2.88205111009939E-15, &
  -3.32656311696166E-16/
  DATA N1D,N2D,N3D,N4D/14,24,19,15/
  DATA M1D,M2D,M3D,M4D/12,22,17,13/
  DATA DAK1(1), DAK1(2), DAK1(3), DAK1(4), DAK1(5), DAK1(6), &
       DAK1(7), DAK1(8), DAK1(9), DAK1(10),DAK1(11),DAK1(12), &
      DAK1(13),DAK1(14)/ 2.04567842307887E-01,-6.61322739905664E-02, &
  -8.49845800989287E-03, 3.12183491556289E-03,-2.70016489829432E-04, &
  -6.35636298679387E-06, 3.02397712409509E-06,-2.18311195330088E-07, &
  -5.36194289332826E-10, 1.13098035622310E-09,-7.43023834629073E-11, &
   4.28804170826891E-13, 2.23810925754539E-13,-1.39140135641182E-14/
  DATA DAK2(1), DAK2(2), DAK2(3), DAK2(4), DAK2(5), DAK2(6), &
       DAK2(7), DAK2(8), DAK2(9), DAK2(10),DAK2(11),DAK2(12), &
       DAK2(13),DAK2(14),DAK2(15),DAK2(16),DAK2(17),DAK2(18), &
       DAK2(19),DAK2(20),DAK2(21),DAK2(22),DAK2(23), &
       DAK2(24)        / 2.93332343883230E-01,-8.06196784743112E-03, &
   2.42540172333140E-03,-6.82297548850235E-04, 1.85786427751181E-04, &
  -4.97457447684059E-05, 1.32090681239497E-05,-3.49528240444943E-06, &
   9.24362451078835E-07,-2.44732671521867E-07, 6.49307837648910E-08, &
  -1.72717621501538E-08, 4.60725763604656E-09,-1.23249055291550E-09, &
   3.30620409488102E-10,-8.89252099772401E-11, 2.39773319878298E-11, &
  -6.48013921153450E-12, 1.75510132023731E-12,-4.76303829833637E-13, &
   1.29498241100810E-13,-3.52679622210430E-14, 9.62005151585923E-15, &
  -2.62786914342292E-15/
  DATA DAK3(1), DAK3(2), DAK3(3), DAK3(4), DAK3(5), DAK3(6), &
       DAK3(7), DAK3(8), DAK3(9), DAK3(10),DAK3(11),DAK3(12), &
      DAK3(13),DAK3(14)/ 2.84675828811349E-01, 2.53073072619080E-03, &
  -4.83481130337976E-05, 1.84907283946343E-06,-1.01418491178576E-07, &
   7.05925634457153E-09,-5.85325291400382E-10, 5.56357688831339E-11, &
  -5.90889094779500E-12, 6.88574353784436E-13,-8.68588256452194E-14, &
   1.17374762617213E-14,-1.68523146510923E-15, 2.55374773097056E-16/
  DATA DAJP(1), DAJP(2), DAJP(3), DAJP(4), DAJP(5), DAJP(6), &
       DAJP(7), DAJP(8), DAJP(9), DAJP(10),DAJP(11),DAJP(12), &
       DAJP(13),DAJP(14),DAJP(15),DAJP(16),DAJP(17),DAJP(18), &
       DAJP(19)        / 6.53219131311457E-02,-1.20262933688823E-01, &
   9.78010236263823E-03, 1.67948429230505E-02,-1.97146140182132E-03, &
  -8.45560295098867E-04, 9.42889620701976E-05, 2.25827860945475E-05, &
  -2.29067870915987E-06,-3.76343991136919E-07, 3.45663933559565E-08, &
   4.29611332003007E-09,-3.58673691214989E-10,-3.57245881361895E-11, &
   2.72696091066336E-12, 2.26120653095771E-13,-1.58763205238303E-14, &
  -1.12604374485125E-15, 7.31327529515367E-17/
  DATA DAJN(1), DAJN(2), DAJN(3), DAJN(4), DAJN(5), DAJN(6), &
       DAJN(7), DAJN(8), DAJN(9), DAJN(10),DAJN(11),DAJN(12), &
       DAJN(13),DAJN(14),DAJN(15),DAJN(16),DAJN(17),DAJN(18), &
       DAJN(19)        / 1.08594539632967E-02, 8.53313194857091E-02, &
  -3.15277068113058E-01,-8.78420725294257E-02, 5.53251906976048E-02, &
   9.41674060503241E-03,-3.32187026018996E-03,-4.11157343156826E-04, &
   1.01297326891346E-04, 9.87633682208396E-06,-1.87312969812393E-06, &
  -1.50798500131468E-07, 2.32687669525394E-08, 1.59599917419225E-09, &
  -2.07665922668385E-10,-1.24103350500302E-11, 1.39631765331043E-12, &
   7.39400971155740E-14,-7.32887475627500E-15/
  DATA DA(1),  DA(2),  DA(3),  DA(4),  DA(5),  DA(6),  DA(7), &
       DA(8),  DA(9),  DA(10), DA(11), DA(12), DA(13), DA(14), &
       DA(15)          / 4.91627321104601E-01, 3.11164930427489E-03, &
   8.23140762854081E-05,-4.61769776172142E-06,-6.13158880534626E-08, &
   2.87295804656520E-08,-1.81959715372117E-09,-1.44752826642035E-10, &
   4.53724043420422E-11,-3.99655065847223E-12,-3.24089119830323E-13, &
   1.62098952568741E-13,-2.40765247974057E-14, 1.69384811284491E-16, &
   8.17900786477396E-16/
  DATA DB(1),  DB(2),  DB(3),  DB(4),  DB(5),  DB(6),  DB(7), &
       DB(8),  DB(9),  DB(10), DB(11), DB(12), DB(13), DB(14), &
       DB(15)          /-2.77571356944231E-01, 4.44212833419920E-03, &
  -8.42328522190089E-05,-2.58040318418710E-06, 3.42389720217621E-07, &
  -6.24286894709776E-09,-2.36377836844577E-09, 3.16991042656673E-10, &
  -4.40995691658191E-12,-5.18674221093575E-12, 9.64874015137022E-13, &
  -4.90190576608710E-14,-1.77253430678112E-14, 5.55950610442662E-15, &
  -7.11793337579530E-16/
!***FIRST EXECUTABLE STATEMENT  JAIRY
  if (X < 0.0E0) go to 90
  if (C > 5.0E0) go to 60
  if (X > 1.20E0) go to 30
  T = (X+X-1.2E0)*CON4
  TT = T + T
  J = N1
  F1 = AK1(J)
  F2 = 0.0E0
  DO 10 I=1,M1
    J = J - 1
    TEMP1 = F1
    F1 = TT*F1 - F2 + AK1(J)
    F2 = TEMP1
   10 CONTINUE
  AI = T*F1 - F2 + AK1(1)
!
  J = N1D
  F1 = DAK1(J)
  F2 = 0.0E0
  DO 20 I=1,M1D
    J = J - 1
    TEMP1 = F1
    F1 = TT*F1 - F2 + DAK1(J)
    F2 = TEMP1
   20 CONTINUE
  DAI = -(T*F1-F2+DAK1(1))
  return
!
   30 CONTINUE
  T = (X+X-CON2)*CON3
  TT = T + T
  J = N2
  F1 = AK2(J)
  F2 = 0.0E0
  DO 40 I=1,M2
    J = J - 1
    TEMP1 = F1
    F1 = TT*F1 - F2 + AK2(J)
    F2 = TEMP1
   40 CONTINUE
  RTRX = SQRT(RX)
  EC = EXP(-C)
  AI = EC*(T*F1-F2+AK2(1))/RTRX
  J = N2D
  F1 = DAK2(J)
  F2 = 0.0E0
  DO 50 I=1,M2D
    J = J - 1
    TEMP1 = F1
    F1 = TT*F1 - F2 + DAK2(J)
    F2 = TEMP1
   50 CONTINUE
  DAI = -EC*(T*F1-F2+DAK2(1))*RTRX
  return
!
   60 CONTINUE
  T = 10.0E0/C - 1.0E0
  TT = T + T
  J = N1
  F1 = AK3(J)
  F2 = 0.0E0
  DO 70 I=1,M1
    J = J - 1
    TEMP1 = F1
    F1 = TT*F1 - F2 + AK3(J)
    F2 = TEMP1
   70 CONTINUE
  RTRX = SQRT(RX)
  EC = EXP(-C)
  AI = EC*(T*F1-F2+AK3(1))/RTRX
  J = N1D
  F1 = DAK3(J)
  F2 = 0.0E0
  DO 80 I=1,M1D
    J = J - 1
    TEMP1 = F1
    F1 = TT*F1 - F2 + DAK3(J)
    F2 = TEMP1
   80 CONTINUE
  DAI = -RTRX*EC*(T*F1-F2+DAK3(1))
  return
!
   90 CONTINUE
  if (C > 5.0E0) go to 120
  T = 0.4E0*C - 1.0E0
  TT = T + T
  J = N3
  F1 = AJP(J)
  E1 = AJN(J)
  F2 = 0.0E0
  E2 = 0.0E0
  DO 100 I=1,M3
    J = J - 1
    TEMP1 = F1
    TEMP2 = E1
    F1 = TT*F1 - F2 + AJP(J)
    E1 = TT*E1 - E2 + AJN(J)
    F2 = TEMP1
    E2 = TEMP2
  100 CONTINUE
  AI = (T*E1-E2+AJN(1)) - X*(T*F1-F2+AJP(1))
  J = N3D
  F1 = DAJP(J)
  E1 = DAJN(J)
  F2 = 0.0E0
  E2 = 0.0E0
  DO 110 I=1,M3D
    J = J - 1
    TEMP1 = F1
    TEMP2 = E1
    F1 = TT*F1 - F2 + DAJP(J)
    E1 = TT*E1 - E2 + DAJN(J)
    F2 = TEMP1
    E2 = TEMP2
  110 CONTINUE
  DAI = X*X*(T*F1-F2+DAJP(1)) + (T*E1-E2+DAJN(1))
  return
!
  120 CONTINUE
  T = 10.0E0/C - 1.0E0
  TT = T + T
  J = N4
  F1 = A(J)
  E1 = B(J)
  F2 = 0.0E0
  E2 = 0.0E0
  DO 130 I=1,M4
    J = J - 1
    TEMP1 = F1
    TEMP2 = E1
    F1 = TT*F1 - F2 + A(J)
    E1 = TT*E1 - E2 + B(J)
    F2 = TEMP1
    E2 = TEMP2
  130 CONTINUE
  TEMP1 = T*F1 - F2 + A(1)
  TEMP2 = T*E1 - E2 + B(1)
  RTRX = SQRT(RX)
  CV = C - FPI12
  CCV = COS(CV)
  SCV = SIN(CV)
  AI = (TEMP1*CCV-TEMP2*SCV)/RTRX
  J = N4D
  F1 = DA(J)
  E1 = DB(J)
  F2 = 0.0E0
  E2 = 0.0E0
  DO 140 I=1,M4D
    J = J - 1
    TEMP1 = F1
    TEMP2 = E1
    F1 = TT*F1 - F2 + DA(J)
    E1 = TT*E1 - E2 + DB(J)
    F2 = TEMP1
    E2 = TEMP2
  140 CONTINUE
  TEMP1 = T*F1 - F2 + DA(1)
  TEMP2 = T*E1 - E2 + DB(1)
  E1 = CCV*CON5 + 0.5E0*SCV
  E2 = SCV*CON5 - 0.5E0*CCV
  DAI = (TEMP1*E1-TEMP2*E2)*RTRX
  return
end
subroutine GAMLIM (XMIN, XMAX)
!
!! GAMLIM computes minimum and maximum argument bounds for the Gamma function.
!
!***LIBRARY   SLATEC (FNLIB)
!***CATEGORY  C7A, R2
!***TYPE      SINGLE PRECISION (GAMLIM-S, DGAMLM-D)
!***KEYWORDS  COMPLETE GAMMA FUNCTION, FNLIB, LIMITS, SPECIAL FUNCTIONS
!***AUTHOR  Fullerton, W., (LANL)
!***DESCRIPTION
!
! Calculate the minimum and maximum legal bounds for X in GAMMA(X).
! XMIN and XMAX are not the only bounds, but they are the only non-
! trivial ones to calculate.
!
!             Output Arguments --
! XMIN   minimum legal value of X in GAMMA(X).  Any smaller value of
!        X might result in underflow.
! XMAX   maximum legal value of X in GAMMA(X).  Any larger value will
!        cause overflow.
!
!***REFERENCES  (NONE)
!***ROUTINES CALLED  R1MACH, XERMSG
!***REVISION HISTORY  (YYMMDD)
!   770401  DATE WRITTEN
!   890531  Changed all specific intrinsics to generic.  (WRB)
!   890531  REVISION DATE from Version 3.2
!   891214  Prologue converted to Version 4.0 format.  (BAB)
!   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
!***END PROLOGUE  GAMLIM
!***FIRST EXECUTABLE STATEMENT  GAMLIM
  ALNSML = LOG(R1MACH(1))
  XMIN = -ALNSML
  DO 10 I=1,10
    XOLD = XMIN
    XLN = LOG(XMIN)
    XMIN = XMIN - XMIN*((XMIN+0.5)*XLN - XMIN - 0.2258 + ALNSML) &
      / (XMIN*XLN + 0.5)
    if (ABS(XMIN-XOLD) < 0.005) go to 20
 10   CONTINUE
  call XERMSG ('SLATEC', 'GAMLIM', 'UNABLE TO FIND XMIN', 1, 2)
!
 20   XMIN = -XMIN + 0.01
!
  ALNBIG = LOG(R1MACH(2))
  XMAX = ALNBIG
  DO 30 I=1,10
    XOLD = XMAX
    XLN = LOG(XMAX)
    XMAX = XMAX - XMAX*((XMAX-0.5)*XLN - XMAX + 0.9189 - ALNBIG) &
      / (XMAX*XLN - 0.5)
    if (ABS(XMAX-XOLD) < 0.005) go to 40
 30   CONTINUE
  call XERMSG ('SLATEC', 'GAMLIM', 'UNABLE TO FIND XMAX', 2, 2)
!
 40   XMAX = XMAX - 0.01
  XMIN = MAX (XMIN, -XMAX+1.)
!
  return
end

function CSEVL (X, CS, N)
!
!! CSEVL evaluates a Chebyshev series.
!
!***LIBRARY   SLATEC (FNLIB)
!***CATEGORY  C3A2
!***TYPE      SINGLE PRECISION (CSEVL-S, DCSEVL-D)
!***KEYWORDS  CHEBYSHEV SERIES, FNLIB, SPECIAL FUNCTIONS
!***AUTHOR  Fullerton, W., (LANL)
!***DESCRIPTION
!
!  Evaluate the N-term Chebyshev series CS at X.  Adapted from
!  a method presented in the paper by Broucke referenced below.
!
!       Input Arguments --
!  X    value at which the series is to be evaluated.
!  CS   array of N terms of a Chebyshev series.  In evaluating
!       CS, only half the first coefficient is summed.
!  N    number of terms in array CS.
!
!***REFERENCES  R. Broucke, Ten subroutines for the manipulation of
!                 Chebyshev series, Algorithm 446, Communications of
!                 the A.C.M. 16, (1973) pp. 254-256.
!               L. Fox and I. B. Parker, Chebyshev Polynomials in
!                 Numerical Analysis, Oxford University Press, 1968,
!                 page 56.
!***ROUTINES CALLED  R1MACH, XERMSG
!***REVISION HISTORY  (YYMMDD)
!   770401  DATE WRITTEN
!   890831  Modified array declarations.  (WRB)
!   890831  REVISION DATE from Version 3.2
!   891214  Prologue converted to Version 4.0 format.  (BAB)
!   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
!   900329  Prologued revised extensively and code rewritten to allow
!           X to be slightly outside interval (-1,+1).  (WRB)
!   920501  Reformatted the REFERENCES section.  (WRB)
!***END PROLOGUE  CSEVL
  REAL B0, B1, B2, CS(*), ONEPL, TWOX, X
  LOGICAL FIRST
  SAVE FIRST, ONEPL
  DATA FIRST /.TRUE./
!***FIRST EXECUTABLE STATEMENT  CSEVL
  if (FIRST) ONEPL = 1.0E0 + R1MACH(4)
  FIRST = .FALSE.
  if (N  <  1) call XERMSG ('SLATEC', 'CSEVL', &
     'NUMBER OF TERMS  <=  0', 2, 2)
  if (N  >  1000) call XERMSG ('SLATEC', 'CSEVL', &
     'NUMBER OF TERMS  >  1000', 3, 2)
  if (ABS(X)  >  ONEPL) call XERMSG ('SLATEC', 'CSEVL', &
     'X OUTSIDE THE INTERVAL (-1,+1)', 1, 1)
!
  B1 = 0.0E0
  B0 = 0.0E0
  TWOX = 2.0*X
  DO 10 I = 1,N
     B2 = B1
     B1 = B0
     NI = N + 1 - I
     B0 = TWOX*B1 - B2 + CS(NI)
   10 CONTINUE
!
  CSEVL = 0.5E0*(B0-B2)
!
  return
end

function ALNGAM (X)
!
!! ALNGAM computes the logarithm of the absolute value of the Gamma function.
!
!***LIBRARY   SLATEC (FNLIB)
!***CATEGORY  C7A
!***TYPE      SINGLE PRECISION (ALNGAM-S, DLNGAM-D, CLNGAM-C)
!***KEYWORDS  ABSOLUTE VALUE, COMPLETE GAMMA FUNCTION, FNLIB, LOGARITHM,
!             SPECIAL FUNCTIONS
!***AUTHOR  Fullerton, W., (LANL)
!***DESCRIPTION
!
! ALNGAM(X) computes the logarithm of the absolute value of the
! gamma function at X.
!
!***REFERENCES  (NONE)
!***ROUTINES CALLED  GAMMA, R1MACH, R9LGMC, XERMSG
!***REVISION HISTORY  (YYMMDD)
!   770601  DATE WRITTEN
!   890531  Changed all specific intrinsics to generic.  (WRB)
!   890531  REVISION DATE from Version 3.2
!   891214  Prologue converted to Version 4.0 format.  (BAB)
!   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
!   900326  Removed duplicate information from DESCRIPTION section.
!           (WRB)
!   900727  Added EXTERNAL statement.  (WRB)
!***END PROLOGUE  ALNGAM
  LOGICAL FIRST
  EXTERNAL GAMMA
  SAVE SQ2PIL, SQPI2L, PI, XMAX, DXREL, FIRST
  DATA SQ2PIL / 0.91893853320467274E0/
  DATA SQPI2L / 0.22579135264472743E0/
  DATA PI     / 3.14159265358979324E0/
  DATA FIRST  /.TRUE./
!***FIRST EXECUTABLE STATEMENT  ALNGAM
  if (FIRST) THEN
     XMAX = R1MACH(2)/LOG(R1MACH(2))
     DXREL = SQRT (R1MACH(4))
  end if
  FIRST = .FALSE.
!
  Y = ABS(X)
  if (Y > 10.0) go to 20
!
! LOG (ABS (GAMMA(X))) FOR  ABS(X)  <=  10.0
!
  ALNGAM = LOG (ABS (GAMMA(X)))
  return
!
! LOG (ABS (GAMMA(X))) FOR ABS(X)  >  10.0
!
 20   if (Y  >  XMAX) call XERMSG ('SLATEC', 'ALNGAM', &
     'ABS(X) SO BIG ALNGAM OVERFLOWS', 2, 2)
!
  if (X > 0.) ALNGAM = SQ2PIL + (X-0.5)*LOG(X) - X + R9LGMC(Y)
  if (X > 0.) RETURN
!
  SINPIY = ABS (SIN(PI*Y))
  if (SINPIY  ==  0.) call XERMSG ('SLATEC', 'ALNGAM', &
     'X IS A NEGATIVE INTEGER', 3, 2)
!
  if (ABS((X-AINT(X-0.5))/X)  <  DXREL) call XERMSG ('SLATEC', &
     'ALNGAM', 'ANSWER LT HALF PRECISION BECAUSE X TOO NEAR ' // &
     'NEGATIVE INTEGER', 1, 1)
!
  ALNGAM = SQPI2L + (X-0.5)*LOG(Y) - X - LOG(SINPIY) - R9LGMC(Y)
  return
!
end

function GAMMA (X)
!
!! GAMMA computes the complete Gamma function.
!
!***LIBRARY   SLATEC (FNLIB)
!***CATEGORY  C7A
!***TYPE      SINGLE PRECISION (GAMMA-S, DGAMMA-D, CGAMMA-C)
!***KEYWORDS  COMPLETE GAMMA FUNCTION, FNLIB, SPECIAL FUNCTIONS
!***AUTHOR  Fullerton, W., (LANL)
!***DESCRIPTION
!
! GAMMA computes the gamma function at X, where X is not 0, -1, -2, ....
! GAMMA and X are single precision.
!
!***REFERENCES  (NONE)
!***ROUTINES CALLED  CSEVL, GAMLIM, INITS, R1MACH, R9LGMC, XERMSG
!***REVISION HISTORY  (YYMMDD)
!   770601  DATE WRITTEN
!   890531  Changed all specific intrinsics to generic.  (WRB)
!   890531  REVISION DATE from Version 3.2
!   891214  Prologue converted to Version 4.0 format.  (BAB)
!   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
!***END PROLOGUE  GAMMA
  DIMENSION GCS(23)
  LOGICAL FIRST
  SAVE GCS, PI, SQ2PIL, NGCS, XMIN, XMAX, DXREL, FIRST
  DATA GCS   ( 1) / .008571195590989331E0/
  DATA GCS   ( 2) / .004415381324841007E0/
  DATA GCS   ( 3) / .05685043681599363E0/
  DATA GCS   ( 4) /-.004219835396418561E0/
  DATA GCS   ( 5) / .001326808181212460E0/
  DATA GCS   ( 6) /-.0001893024529798880E0/
  DATA GCS   ( 7) / .0000360692532744124E0/
  DATA GCS   ( 8) /-.0000060567619044608E0/
  DATA GCS   ( 9) / .0000010558295463022E0/
  DATA GCS   (10) /-.0000001811967365542E0/
  DATA GCS   (11) / .0000000311772496471E0/
  DATA GCS   (12) /-.0000000053542196390E0/
  DATA GCS   (13) / .0000000009193275519E0/
  DATA GCS   (14) /-.0000000001577941280E0/
  DATA GCS   (15) / .0000000000270798062E0/
  DATA GCS   (16) /-.0000000000046468186E0/
  DATA GCS   (17) / .0000000000007973350E0/
  DATA GCS   (18) /-.0000000000001368078E0/
  DATA GCS   (19) / .0000000000000234731E0/
  DATA GCS   (20) /-.0000000000000040274E0/
  DATA GCS   (21) / .0000000000000006910E0/
  DATA GCS   (22) /-.0000000000000001185E0/
  DATA GCS   (23) / .0000000000000000203E0/
  DATA PI /3.14159265358979324E0/
! SQ2PIL IS LOG (SQRT (2.*PI) )
  DATA SQ2PIL /0.91893853320467274E0/
  DATA FIRST /.TRUE./
!
! LANL DEPENDENT CODE REMOVED 81.02.04
!
!***FIRST EXECUTABLE STATEMENT  GAMMA
  if (FIRST) THEN
!
! ---------------------------------------------------------------------
! INITIALIZE.  FIND LEGAL BOUNDS FOR X, AND DETERMINE THE NUMBER OF
! TERMS IN THE SERIES REQUIRED TO ATTAIN AN ACCURACY TEN TIMES BETTER
! THAN MACHINE PRECISION.
!
     NGCS = INITS (GCS, 23, 0.1*R1MACH(3))
!
     call GAMLIM (XMIN, XMAX)
     DXREL = SQRT (R1MACH(4))
!
! ---------------------------------------------------------------------
! FINISH INITIALIZATION.  START EVALUATING GAMMA(X).
!
  end if
  FIRST = .FALSE.
!
  Y = ABS(X)
  if (Y > 10.0) go to 50
!
! COMPUTE GAMMA(X) FOR ABS(X)  <=  10.0.  REDUCE INTERVAL AND
! FIND GAMMA(1+Y) FOR 0.  <=  Y  <  1. FIRST OF ALL.
!
  N = X
  if (X < 0.) N = N - 1
  Y = X - N
  N = N - 1
  GAMMA = 0.9375 + CSEVL(2.*Y-1., GCS, NGCS)
  if (N == 0) RETURN
!
  if (N > 0) go to 30
!
! COMPUTE GAMMA(X) FOR X  <  1.
!
  N = -N
  if (X  ==  0.) call XERMSG ('SLATEC', 'GAMMA', 'X IS 0', 4, 2)
  if (X  <  0. .AND. X+N-2  ==  0.) call XERMSG ('SLATEC', 'GAMMA' &
  , 'X IS A NEGATIVE INTEGER', 4, 2)
  if (X  <  (-0.5) .AND. ABS((X-AINT(X-0.5))/X)  <  DXREL) call &
  XERMSG ( 'SLATEC', 'GAMMA', &
  'ANSWER LT HALF PRECISION BECAUSE X TOO NEAR NEGATIVE INTEGER' &
  , 1, 1)
!
  DO 20 I=1,N
    GAMMA = GAMMA / (X+I-1)
 20   CONTINUE
  return
!
! GAMMA(X) FOR X  >=  2.
!
 30   DO 40 I=1,N
    GAMMA = (Y+I)*GAMMA
 40   CONTINUE
  return
!
! COMPUTE GAMMA(X) FOR ABS(X)  >  10.0.  RECALL Y = ABS(X).
!
 50   if (X  >  XMAX) call XERMSG ('SLATEC', 'GAMMA', &
     'X SO BIG GAMMA OVERFLOWS', 3, 2)
!
  GAMMA = 0.
  if (X  <  XMIN) call XERMSG ('SLATEC', 'GAMMA', &
     'X SO SMALL GAMMA UNDERFLOWS', 2, 1)
  if (X < XMIN) RETURN
!
  GAMMA = EXP((Y-0.5)*LOG(Y) - Y + SQ2PIL + R9LGMC(Y) )
  if (X > 0.) RETURN
!
  if (ABS((X-AINT(X-0.5))/X)  <  DXREL) call XERMSG ('SLATEC', &
     'GAMMA', &
     'ANSWER LT HALF PRECISION, X TOO NEAR NEGATIVE INTEGER', 1, 1)
!
  SINPIY = SIN (PI*Y)
  if (SINPIY  ==  0.) call XERMSG ('SLATEC', 'GAMMA', &
     'X IS A NEGATIVE INTEGER', 4, 2)
!
  GAMMA = -PI / (Y*SINPIY*GAMMA)
!
  return
end

function R9LGMC (X)
!
!! R9LGMC computes the log Gamma correction factor so that ...
!  LOG(GAMMA(X)) = LOG(SQRT(2*PI)) + (X-.5)*LOG(X) - X + R9LGMC(X).
!
!***LIBRARY   SLATEC (FNLIB)
!***CATEGORY  C7E
!***TYPE      SINGLE PRECISION (R9LGMC-S, D9LGMC-D, C9LGMC-C)
!***KEYWORDS  COMPLETE GAMMA FUNCTION, CORRECTION TERM, FNLIB,
!             LOG GAMMA, LOGARITHM, SPECIAL FUNCTIONS
!***AUTHOR  Fullerton, W., (LANL)
!***DESCRIPTION
!
! Compute the log gamma correction factor for X  >=  10.0 so that
!  LOG (GAMMA(X)) = LOG(SQRT(2*PI)) + (X-.5)*LOG(X) - X + R9LGMC(X)
!
! Series for ALGM       on the interval  0.          to  1.00000D-02
!                                        with weighted error   3.40E-16
!                                         log weighted error  15.47
!                               significant figures required  14.39
!                                    decimal places required  15.86
!
!***REFERENCES  (NONE)
!***ROUTINES CALLED  CSEVL, INITS, R1MACH, XERMSG
!***REVISION HISTORY  (YYMMDD)
!   770801  DATE WRITTEN
!   890531  Changed all specific intrinsics to generic.  (WRB)
!   890531  REVISION DATE from Version 3.2
!   891214  Prologue converted to Version 4.0 format.  (BAB)
!   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
!   900720  Routine changed from user-callable to subsidiary.  (WRB)
!***END PROLOGUE  R9LGMC
  DIMENSION ALGMCS(6)
  LOGICAL FIRST
  SAVE ALGMCS, NALGM, XBIG, XMAX, FIRST
  DATA ALGMCS( 1) /    .166638948045186E0 /
  DATA ALGMCS( 2) /   -.0000138494817606E0 /
  DATA ALGMCS( 3) /    .0000000098108256E0 /
  DATA ALGMCS( 4) /   -.0000000000180912E0 /
  DATA ALGMCS( 5) /    .0000000000000622E0 /
  DATA ALGMCS( 6) /   -.0000000000000003E0 /
  DATA FIRST /.TRUE./
!***FIRST EXECUTABLE STATEMENT  R9LGMC
  if (FIRST) THEN
     NALGM = INITS (ALGMCS, 6, R1MACH(3))
     XBIG = 1.0/SQRT(R1MACH(3))
     XMAX = EXP (MIN(LOG(R1MACH(2)/12.0), -LOG(12.0*R1MACH(1))) )
  end if
  FIRST = .FALSE.
!
  if (X  <  10.0) call XERMSG ('SLATEC', 'R9LGMC', &
     'X MUST BE GE 10', 1, 2)
  if (X >= XMAX) go to 20
!
  R9LGMC = 1.0/(12.0*X)
  if (X < XBIG) R9LGMC = CSEVL (2.0*(10./X)**2-1., ALGMCS, NALGM)/X
  return
!
 20   R9LGMC = 0.0
  call XERMSG ('SLATEC', 'R9LGMC', 'X SO BIG R9LGMC UNDERFLOWS', 2, &
     1)
  return
!
end