function algdiv ( a, b )

!*****************************************************************************80
!
!! algdiv() computes ln ( Gamma ( B ) / Gamma ( A + B ) ) when 8 <= B.
!
!  Discussion:
!
!    In this algorithm, DEL(X) is the function defined by
!
!      ln ( Gamma(X) ) = ( X - 0.5 ) * ln ( X ) - X + 0.5 * ln ( 2 * PI )
!                      + DEL(X).
!
!  Licensing:
!
!    This code is distributed under the MIT license.
!
!  Modified:
!
!    15 February 2021
!
!  Author:
!
!    Armido DiDinato, Alfred Morris
!
!  Reference:
!
!    Armido DiDinato, Alfred Morris,
!    Algorithm 708:
!    Significant Digit Computation of the Incomplete Beta Function Ratios,
!    ACM Transactions on Mathematical Software,
!    Volume 18, 1993, pages 360-373.
!
!  Input:
!
!    real ( kind = rk ) A, B, define the arguments.
!
!  Output:
!
!    real ( kind = rk ) ALGDIV, the value of ln(Gamma(B)/Gamma(A+B)).
!
  implicit none

  integer, parameter :: rk = kind ( 1.0D+00 )

  real ( kind = rk ) a
  real ( kind = rk ) algdiv
  real ( kind = rk ) alnrel
  real ( kind = rk ) b
  real ( kind = rk ) c
  real ( kind = rk ), parameter :: c0 =  0.833333333333333D-01
  real ( kind = rk ), parameter :: c1 = -0.277777777760991D-02
  real ( kind = rk ), parameter :: c2 =  0.793650666825390D-03
  real ( kind = rk ), parameter :: c3 = -0.595202931351870D-03
  real ( kind = rk ), parameter :: c4 =  0.837308034031215D-03
  real ( kind = rk ), parameter :: c5 = -0.165322962780713D-02
  real ( kind = rk ) d
  real ( kind = rk ) h
  real ( kind = rk ) s11
  real ( kind = rk ) s3
  real ( kind = rk ) s5
  real ( kind = rk ) s7
  real ( kind = rk ) s9
  real ( kind = rk ) t
  real ( kind = rk ) u
  real ( kind = rk ) v
  real ( kind = rk ) w
  real ( kind = rk ) x
  real ( kind = rk ) x2

  if ( b < a ) then
    h = b / a
    c = 1.0D+00 / ( 1.0D+00 + h )
    x = h / ( 1.0D+00 + h )
    d = a + ( b - 0.5D+00 )
  else
    h = a / b
    c = h / ( 1.0D+00 + h )
    x = 1.0D+00 / ( 1.0D+00 + h )
    d = b + ( a - 0.5D+00 )
  end if
!
!  Set SN = (1 - X^N)/(1 - X).
!
  x2 = x * x
  s3 = 1.0D+00 + ( x + x2 )
  s5 = 1.0D+00 + ( x + x2 * s3 )
  s7 = 1.0D+00 + ( x + x2 * s5 )
  s9 = 1.0D+00 + ( x + x2 * s7 )
  s11 = 1.0D+00 + ( x + x2 * s9 )
!
!  Set W = DEL(B) - DEL(A + B).
!
  t = ( 1.0D+00 / b )**2
  w = (((( &
          c5 * s11  * t &
        + c4 * s9 ) * t &
        + c3 * s7 ) * t &
        + c2 * s5 ) * t &
        + c1 * s3 ) * t &
        + c0

  w = w * ( c / b )
!
!  Combine the results.
!
  u = d * alnrel ( a / b )
  v = a * ( log ( b ) - 1.0D+00 )

  if ( v < u ) then
    algdiv = ( w - v ) - u
  else
    algdiv = ( w - u ) - v
  end if

  return
end
function alnrel ( a )

!*****************************************************************************80
!
!! alnrel() evaluates the function ln ( 1 + A ).
!
!  Licensing:
!
!    This code is distributed under the MIT license.
!
!  Modified:
!
!    15 February 2021
!
!  Author:
!
!    Armido DiDinato, Alfred Morris
!
!  Reference:
!
!    Armido DiDinato, Alfred Morris,
!    Algorithm 708:
!    Significant Digit Computation of the Incomplete Beta Function Ratios,
!    ACM Transactions on Mathematical Software,
!    Volume 18, 1993, pages 360-373.
!
!  Input:
!
!    real ( kind = rk ) A, the argument.
!
!  Output:
!
!   real ( kind = rk ) ALNREL, the value of ln ( 1 + A ).
!
  implicit none

  integer, parameter :: rk = kind ( 1.0D+00 )

  real ( kind = rk ) a
  real ( kind = rk ) alnrel
  real ( kind = rk ), parameter :: p1 = -0.129418923021993D+01
  real ( kind = rk ), parameter :: p2 =  0.405303492862024D+00
  real ( kind = rk ), parameter :: p3 = -0.178874546012214D-01
  real ( kind = rk ), parameter :: q1 = -0.162752256355323D+01
  real ( kind = rk ), parameter :: q2 =  0.747811014037616D+00
  real ( kind = rk ), parameter :: q3 = -0.845104217945565D-01
  real ( kind = rk ) t
  real ( kind = rk ) t2
  real ( kind = rk ) w
  real ( kind = rk ) x

  if ( abs ( a ) <= 0.375D+00 ) then

    t = a / ( a +  2.0D+00  )
    t2 = t * t

    w = ((( p3 * t2 + p2 ) * t2 + p1 ) * t2 + 1.0D+00 ) &
      / ((( q3 * t2 + q2 ) * t2 + q1 ) * t2 + 1.0D+00 )

    alnrel =  2.0D+00  * t * w

  else

    x = 1.0D+00 + real ( a, kind = rk )
    alnrel = log ( x )

  end if

  return
end
function apser ( a, b, x, eps )

!*****************************************************************************80
!
!! apser() computes the incomplete beta ratio I(SUB(1-X))(B,A).
!
!  Discussion:
!
!    APSER is used only for cases where
!
!      A <= min ( EPS, EPS * B ),
!      B * X <= 1, and
!      X <= 0.5.
!
!  Licensing:
!
!    This code is distributed under the MIT license.
!
!  Modified:
!
!    15 February 2021
!
!  Author:
!
!    Armido DiDinato, Alfred Morris
!
!  Reference:
!
!    Armido DiDinato, Alfred Morris,
!    Algorithm 708:
!    Significant Digit Computation of the Incomplete Beta Function Ratios,
!    ACM Transactions on Mathematical Software,
!    Volume 18, 1993, pages 360-373.
!
!  Input:
!
!    real ( kind = rk ) A, B, X, the parameters of the
!    incomplete beta ratio.
!
!    real ( kind = rk ) EPS, a tolerance.
!
!  Output:
!
!    real ( kind = rk ) APSER, the incomplete beta ratio.
!
  implicit none

  integer, parameter :: rk = kind ( 1.0D+00 )

  real ( kind = rk ) a
  real ( kind = rk ) aj
  real ( kind = rk ) apser
  real ( kind = rk ) b
  real ( kind = rk ) bx
  real ( kind = rk ) c
  real ( kind = rk ) eps
  real ( kind = rk ), parameter :: g = 0.577215664901533D+00
  real ( kind = rk ) j
  real ( kind = rk ) psi
  real ( kind = rk ) s
  real ( kind = rk ) t
  real ( kind = rk ) tol
  real ( kind = rk ) x

  bx = b * x
  t = x - bx

  if ( b * eps <= 0.02D+00 ) then
    c = log ( x ) + psi ( b ) + g + t
  else
    c = log ( bx ) + g + t
  end if

  tol = 5.0D+00 * eps * abs ( c )
  j = 1.0D+00
  s = 0.0D+00

  do

    j = j + 1.0D+00
    t = t * ( x - bx / j )
    aj = t / j
    s = s + aj

    if ( abs ( aj ) <= tol ) then
      exit
    end if

  end do

  apser = -a * ( c + s )

  return
end
function bcorr ( a0, b0 )

!*****************************************************************************80
!
!! bcorr() evaluates DEL(A0) + DEL(B0) - DEL(A0 + B0).
!
!  Discussion:
!
!    The function DEL(A) is a remainder term that is used in the expression:
!
!      ln ( Gamma ( A ) ) = ( A - 0.5 ) * ln ( A )
!        - A + 0.5 * ln ( 2 * PI ) + DEL ( A ),
!
!    or, in other words, DEL ( A ) is defined as:
!
!      DEL ( A ) = ln ( Gamma ( A ) ) - ( A - 0.5 ) * ln ( A )
!        + A + 0.5 * ln ( 2 * PI ).
!
!  Licensing:
!
!    This code is distributed under the MIT license.
!
!  Modified:
!
!    15 February 2021
!
!  Author:
!
!    Armido DiDinato, Alfred Morris
!
!  Reference:
!
!    Armido DiDinato, Alfred Morris,
!    Algorithm 708:
!    Significant Digit Computation of the Incomplete Beta Function Ratios,
!    ACM Transactions on Mathematical Software,
!    Volume 18, 1993, pages 360-373.
!
!  Input:
!
!    real ( kind = rk ) A0, B0, the arguments.
!    It is assumed that 8 <= A0 and 8 <= B0.
!
!  Output:
!
!    real ( kind = rk ) BCORR, the value of the function.
!
  implicit none

  integer, parameter :: rk = kind ( 1.0D+00 )

  real ( kind = rk ) a
  real ( kind = rk ) a0
  real ( kind = rk ) b
  real ( kind = rk ) b0
  real ( kind = rk ) bcorr
  real ( kind = rk ) c
  real ( kind = rk ), parameter :: c0 =  0.833333333333333D-01
  real ( kind = rk ), parameter :: c1 = -0.277777777760991D-02
  real ( kind = rk ), parameter :: c2 =  0.793650666825390D-03
  real ( kind = rk ), parameter :: c3 = -0.595202931351870D-03
  real ( kind = rk ), parameter :: c4 =  0.837308034031215D-03
  real ( kind = rk ), parameter :: c5 = -0.165322962780713D-02
  real ( kind = rk ) h
  real ( kind = rk ) s11
  real ( kind = rk ) s3
  real ( kind = rk ) s5
  real ( kind = rk ) s7
  real ( kind = rk ) s9
  real ( kind = rk ) t
  real ( kind = rk ) w
  real ( kind = rk ) x
  real ( kind = rk ) x2

  a = min ( a0, b0 )
  b = max ( a0, b0 )

  h = a / b
  c = h / ( 1.0D+00 + h )
  x = 1.0D+00 / ( 1.0D+00 + h )
  x2 = x * x
!
!  Set SN = (1 - X^N)/(1 - X)
!
  s3 = 1.0D+00 + ( x + x2 )
  s5 = 1.0D+00 + ( x + x2 * s3 )
  s7 = 1.0D+00 + ( x + x2 * s5 )
  s9 = 1.0D+00 + ( x + x2 * s7 )
  s11 = 1.0D+00 + ( x + x2 * s9 )
!
!  Set W = DEL(B) - DEL(A + B)
!
  t = ( 1.0D+00 / b )**2

  w = (((( &
       c5 * s11  * t &
     + c4 * s9 ) * t &
     + c3 * s7 ) * t &
     + c2 * s5 ) * t &
     + c1 * s3 ) * t &
     + c0

  w = w * ( c / b )
!
!  Compute  DEL(A) + W.
!
  t = ( 1.0D+00 / a )**2

  bcorr = ((((( &
         c5   * t &
       + c4 ) * t &
       + c3 ) * t &
       + c2 ) * t &
       + c1 ) * t &
       + c0 ) / a + w

  return
end
function beta ( a, b )

!*****************************************************************************80
!
!! beta() evaluates the beta function.
!
!  Licensing:
!
!    This code is distributed under the MIT license.
!
!  Modified:
!
!    15 February 2021
!
!  Author:
!
!    John Burkardt
!
!  Input:
!
!    real ( kind = rk ) A, B, the arguments of the beta function.
!
!  Output:
!
!    real ( kind = rk ) BETA, the value of the beta function.
!
  implicit none

  integer, parameter :: rk = kind ( 1.0D+00 )

  real ( kind = rk ) a
  real ( kind = rk ) b
  real ( kind = rk ) beta
  real ( kind = rk ) beta_log

  beta = exp ( beta_log ( a, b ) )

  return
end
function beta_asym ( a, b, lambda, eps )

!*****************************************************************************80
!
!! beta_asym() computes an asymptotic expansion for IX(A,B), for large A and B.
!
!  Licensing:
!
!    This code is distributed under the MIT license.
!
!  Modified:
!
!    15 February 2021
!
!  Author:
!
!    Armido DiDinato, Alfred Morris
!
!  Reference:
!
!    Armido DiDinato, Alfred Morris,
!    Algorithm 708:
!    Significant Digit Computation of the Incomplete Beta Function Ratios,
!    ACM Transactions on Mathematical Software,
!    Volume 18, 1993, pages 360-373.
!
!  Input:
!
!    real ( kind = rk ) A, B, the parameters of the function.
!    A and B should be nonnegative.  It is assumed that both A and B
!    are greater than or equal to 15.
!
!    real ( kind = rk ) LAMBDA, the value of ( A + B ) * Y - B.
!    It is assumed that 0 <= LAMBDA.
!
!    real ( kind = rk ) EPS, the tolerance.
!
!  Output:
!
!    real ( kind = rk ) BETA_ASYM, the estimate for IX(A,B).
!
  implicit none

  integer, parameter :: rk = kind ( 1.0D+00 )

  integer, parameter :: num = 20

  real ( kind = rk ) a
  real ( kind = rk ) a0(num+1)
  real ( kind = rk ) b
  real ( kind = rk ) b0(num+1)
  real ( kind = rk ) bcorr
  real ( kind = rk ) beta_asym
  real ( kind = rk ) bsum
  real ( kind = rk ) c(num+1)
  real ( kind = rk ) d(num+1)
  real ( kind = rk ) dsum
  real ( kind = rk ), parameter :: e0 = 1.12837916709551D+00
  real ( kind = rk ), parameter :: e1 = 0.353553390593274D+00
  real ( kind = rk ) eps
  real ( kind = rk ) error_fc
  real ( kind = rk ) f
  real ( kind = rk ) h
  real ( kind = rk ) h2
  real ( kind = rk ) hn
  integer i
  integer j
  real ( kind = rk ) j0
  real ( kind = rk ) j1
  real ( kind = rk ) lambda
  integer m
  integer mm1
  integer mmj
  integer n
  integer np1
  real ( kind = rk ) r
  real ( kind = rk ) r0
  real ( kind = rk ) r1
  real ( kind = rk ) rlog1
  real ( kind = rk ) s
  real ( kind = rk ) sum1
  real ( kind = rk ) t
  real ( kind = rk ) t0
  real ( kind = rk ) t1
  real ( kind = rk ) u
  real ( kind = rk ) w
  real ( kind = rk ) w0
  real ( kind = rk ) z
  real ( kind = rk ) z0
  real ( kind = rk ) z2
  real ( kind = rk ) zn
  real ( kind = rk ) znm1

  beta_asym = 0.0D+00

  if ( a < b ) then
    h = a / b
    r0 = 1.0D+00 / ( 1.0D+00 + h )
    r1 = ( b - a ) / b
    w0 = 1.0D+00 / sqrt ( a * ( 1.0D+00 + h ))
  else
    h = b / a
    r0 = 1.0D+00 / ( 1.0D+00 + h )
    r1 = ( b - a ) / a
    w0 = 1.0D+00 / sqrt ( b * ( 1.0D+00 + h ))
  end if

  f = a * rlog1 ( - lambda / a ) + b * rlog1 ( lambda / b )
  t = exp ( - f )
  if ( t == 0.0D+00 ) then
    return
  end if

  z0 = sqrt ( f )
  z = 0.5D+00 * ( z0 / e1 )
  z2 = f + f

  a0(1) = ( 2.0D+00 / 3.0D+00 ) * r1
  c(1) = -0.5D+00 * a0(1)
  d(1) = -c(1)
  j0 = ( 0.5D+00 / e0 ) * error_fc ( 1, z0 )
  j1 = e1
  sum1 = j0 + d(1) * w0 * j1

  s = 1.0D+00
  h2 = h * h
  hn = 1.0D+00
  w = w0
  znm1 = z
  zn = z2

  do n = 2, num, 2

    hn = h2 * hn
    a0(n) = 2.0D+00 * r0 * ( 1.0D+00 + h * hn ) &
      / ( n + 2.0D+00 )
    np1 = n + 1
    s = s + hn
    a0(np1) = 2.0D+00 * r1 * s / ( n + 3.0D+00 )

    do i = n, np1

      r = -0.5D+00 * ( i + 1.0D+00 )
      b0(1) = r * a0(1)
      do m = 2, i
        bsum = 0.0D+00
        mm1 = m - 1
        do j = 1, mm1
          mmj = m - j
          bsum = bsum + ( j * r - mmj ) * a0(j) * b0(mmj)
        end do
        b0(m) = r * a0(m) + bsum / m
      end do

      c(i) = b0(i) / ( i + 1.0D+00 )

      dsum = 0.0
      do j = 1, i-1
        dsum = dsum + d(i-j) * c(j)
      end do
      d(i) = - ( dsum + c(i) )

    end do

    j0 = e1 * znm1 + ( n - 1.0D+00 ) * j0
    j1 = e1 * zn + n * j1
    znm1 = z2 * znm1
    zn = z2 * zn
    w = w0 * w
    t0 = d(n) * w * j0
    w = w0 * w
    t1 = d(np1) * w * j1
    sum1 = sum1 + ( t0 + t1 )

    if ( ( abs ( t0 ) + abs ( t1 )) <= eps * sum1 ) then
      u = exp ( - bcorr ( a, b ) )
      beta_asym = e0 * t * u * sum1
      return
    end if

  end do

  u = exp ( - bcorr ( a, b ) )
  beta_asym = e0 * t * u * sum1

  return
end
function beta_frac ( a, b, x, y, lambda, eps )

!*****************************************************************************80
!
!! beta_frac() evaluates a continued fraction expansion for IX(A,B).
!
!  Licensing:
!
!    This code is distributed under the MIT license.
!
!  Modified:
!
!    15 February 2021
!
!  Author:
!
!    Armido DiDinato, Alfred Morris
!
!  Reference:
!
!    Armido DiDinato, Alfred Morris,
!    Algorithm 708:
!    Significant Digit Computation of the Incomplete Beta Function Ratios,
!    ACM Transactions on Mathematical Software,
!    Volume 18, 1993, pages 360-373.
!
!  Input:
!
!    real ( kind = rk ) A, B, the parameters of the function.
!    A and B should be nonnegative.  It is assumed that both A and
!    B are greater than 1.
!
!    real ( kind = rk ) X, Y.  X is the argument of the
!    function, and should satisy 0 <= X <= 1.  Y should equal 1 - X.
!
!    real ( kind = rk ) LAMBDA, the value of ( A + B ) * Y - B.
!
!    real ( kind = rk ) EPS, a tolerance.
!
!  Output:
!
!    real ( kind = rk ) BETA_FRAC, the value of the continued
!    fraction approximation for IX(A,B).
!
  implicit none

  integer, parameter :: rk = kind ( 1.0D+00 )

  real ( kind = rk ) a
  real ( kind = rk ) alpha
  real ( kind = rk ) an
  real ( kind = rk ) anp1
  real ( kind = rk ) b
  real ( kind = rk ) beta
  real ( kind = rk ) beta_frac
  real ( kind = rk ) beta_rcomp
  real ( kind = rk ) bn
  real ( kind = rk ) bnp1
  real ( kind = rk ) c
  real ( kind = rk ) c0
  real ( kind = rk ) c1
  real ( kind = rk ) e
  real ( kind = rk ) eps
  real ( kind = rk ) lambda
  real ( kind = rk ) n
  real ( kind = rk ) p
  real ( kind = rk ) r
  real ( kind = rk ) r0
  real ( kind = rk ) s
  real ( kind = rk ) t
  real ( kind = rk ) w
  real ( kind = rk ) x
  real ( kind = rk ) y
  real ( kind = rk ) yp1

  beta_frac = beta_rcomp ( a, b, x, y )

  if ( beta_frac == 0.0D+00 ) then
    return
  end if

  c = 1.0D+00 + lambda
  c0 = b / a
  c1 = 1.0D+00 + 1.0D+00 / a
  yp1 = y + 1.0D+00

  n = 0.0D+00
  p = 1.0D+00
  s = a + 1.0D+00
  an = 0.0D+00
  bn = 1.0D+00
  anp1 = 1.0D+00
  bnp1 = c / c1
  r = c1 / c
!
!  Continued fraction calculation.
!
  do

    n = n + 1.0D+00
    t = n / a
    w = n * ( b - n ) * x
    e = a / s
    alpha = ( p * ( p + c0 ) * e * e ) * ( w * x )
    e = ( 1.0D+00 + t ) / ( c1 + t + t )
    beta = n + w / s + e * ( c + n * yp1 )
    p = 1.0D+00 + t
    s = s +  2.0D+00
!
!  Update AN, BN, ANP1, and BNP1.
!
    t = alpha * an + beta * anp1
    an = anp1
    anp1 = t
    t = alpha * bn + beta * bnp1
    bn = bnp1
    bnp1 = t

    r0 = r
    r = anp1 / bnp1

    if ( abs ( r - r0 ) <= eps * r ) then
      beta_frac = beta_frac * r
      exit
    end if
!
!  Rescale AN, BN, ANP1, and BNP1.
!
    an = an / bnp1
    bn = bn / bnp1
    anp1 = r
    bnp1 = 1.0D+00

  end do

  return
end
subroutine beta_grat ( a, b, x, y, w, eps, ierr )

!*****************************************************************************80
!
!! beta_grat() evaluates an asymptotic expansion for IX(A,B).
!
!  Licensing:
!
!    This code is distributed under the MIT license.
!
!  Modified:
!
!    15 February 2021
!
!  Author:
!
!    Armido DiDinato, Alfred Morris
!
!  Reference:
!
!    Armido DiDinato, Alfred Morris,
!    Algorithm 708:
!    Significant Digit Computation of the Incomplete Beta Function Ratios,
!    ACM Transactions on Mathematical Software,
!    Volume 18, 1993, pages 360-373.
!
!  Parameters:
!
!    Input, real ( kind = rk ) A, B, the parameters of the function.
!    A and B should be nonnegative.  It is assumed that 15 <= A
!    and B <= 1, and that B is less than A.
!
!    Input, real ( kind = rk ) X, Y.  X is the argument of the
!    function, and should satisy 0 <= X <= 1.  Y should equal 1 - X.
!
!    Input/output, real ( kind = rk ) W, a quantity to which the
!    result of the computation is to be added on output.
!
!    Input, real ( kind = rk ) EPS, a tolerance.
!
!    Output, integer IERR, an error flag, which is 0 if no error
!    was detected.
!
  implicit none

  integer, parameter :: rk = kind ( 1.0D+00 )

  real ( kind = rk ) a
  real ( kind = rk ) algdiv
  real ( kind = rk ) alnrel
  real ( kind = rk ) b
  real ( kind = rk ) bm1
  real ( kind = rk ) bp2n
  real ( kind = rk ) c(30)
  real ( kind = rk ) cn
  real ( kind = rk ) coef
  real ( kind = rk ) d(30)
  real ( kind = rk ) dj
  real ( kind = rk ) eps
  real ( kind = rk ) gam1
  integer i
  integer ierr
  real ( kind = rk ) j
  real ( kind = rk ) l
  real ( kind = rk ) lnx
  integer n
  real ( kind = rk ) n2
  real ( kind = rk ) nu
  real ( kind = rk ) p
  real ( kind = rk ) q
  real ( kind = rk ) r
  real ( kind = rk ) s
  real ( kind = rk ) sum1
  real ( kind = rk ) t
  real ( kind = rk ) t2
  real ( kind = rk ) u
  real ( kind = rk ) v
  real ( kind = rk ) w
  real ( kind = rk ) x
  real ( kind = rk ) y
  real ( kind = rk ) z

  bm1 = ( b - 0.5D+00 ) - 0.5D+00
  nu = a + 0.5D+00 * bm1

  if ( y <= 0.375D+00 ) then
    lnx = alnrel ( - y )
  else
    lnx = log ( x )
  end if

  z = -nu * lnx

  if ( b * z == 0.0D+00 ) then
    ierr = 1
    return
  end if
!
!  Computation of the expansion.
!
!  Set R = EXP(-Z)*Z^B/GAMMA(B)
!
  r = b * ( 1.0D+00 + gam1 ( b ) ) * exp ( b * log ( z ))
  r = r * exp ( a * lnx ) * exp ( 0.5D+00 * bm1 * lnx )
  u = algdiv ( b, a ) + b * log ( nu )
  u = r * exp ( - u )

  if ( u == 0.0D+00 ) then
    ierr = 1
    return
  end if

  call gamma_rat1 ( b, z, r, p, q, eps )

  v = 0.25D+00 * ( 1.0D+00 / nu )**2
  t2 = 0.25D+00 * lnx * lnx
  l = w / u
  j = q / r
  sum1 = j
  t = 1.0D+00
  cn = 1.0D+00
  n2 = 0.0D+00

  do n = 1, 30

    bp2n = b + n2
    j = ( bp2n * ( bp2n + 1.0D+00 ) * j &
      + ( z + bp2n + 1.0D+00 ) * t ) * v
    n2 = n2 +  2.0D+00
    t = t * t2
    cn = cn / ( n2 * ( n2 + 1.0D+00 ))
    c(n) = cn
    s = 0.0D+00

    coef = b - n
    do i = 1, n-1
      s = s + coef * c(i) * d(n-i)
      coef = coef + b
    end do

    d(n) = bm1 * cn + s / n
    dj = d(n) * j
    sum1 = sum1 + dj

    if ( sum1 <= 0.0D+00 ) then
      ierr = 1
      return
    end if

    if ( abs ( dj ) <= eps * ( sum1 + l ) ) then
      ierr = 0
      w = w + u * sum1
      return
    end if

  end do

  ierr = 0
  w = w + u * sum1

  return
end
subroutine beta_inc ( a, b, x, y, w, w1, ierr )

!*****************************************************************************80
!
!! beta_inc() evaluates the incomplete beta function IX(A,B).
!
!  Licensing:
!
!    This code is distributed under the MIT license.
!
!  Modified:
!
!    15 February 2021
!
!  Author:
!
!    Alfred Morris
!
!  Reference:
!
!    Armido DiDinato, Alfred Morris,
!    Algorithm 708:
!    Significant Digit Computation of the Incomplete Beta Function Ratios,
!    ACM Transactions on Mathematical Software,
!    Volume 18, 1993, pages 360-373.
!
!  Input:
!
!    real ( kind = rk ) A, B, the parameters of the function.
!    A and B should be nonnegative.
!
!    real ( kind = rk ) X, Y.  X is the argument of the
!    function, and should satisy 0 <= X <= 1.  Y should equal 1 - X.
!
!  Output:
!
!    real ( kind = rk ) W, W1, the values of IX(A,B) and 1-IX(A,B).
!
!    integer IERR, the error flag.
!    0, no error was detected.
!    1, A or B is negative;
!    2, A = B = 0;
!    3, X < 0 or 1 < X;
!    4, Y < 0 or 1 < Y;
!    5, X + Y /= 1;
!    6, X = A = 0;
!    7, Y = B = 0.
!
  implicit none

  integer, parameter :: rk = kind ( 1.0D+00 )

  real ( kind = rk ) a
  real ( kind = rk ) a0
  real ( kind = rk ) apser
  real ( kind = rk ) b
  real ( kind = rk ) b0
  real ( kind = rk ) beta_asym
  real ( kind = rk ) beta_frac
  real ( kind = rk ) beta_pser
  real ( kind = rk ) beta_up
  real ( kind = rk ) eps
  real ( kind = rk ) fpser
  integer ierr
  integer ierr1
  integer ind
  real ( kind = rk ) lambda
  integer n
  real ( kind = rk ) t
  real ( kind = rk ) w
  real ( kind = rk ) w1
  real ( kind = rk ) x
  real ( kind = rk ) x0
  real ( kind = rk ) y
  real ( kind = rk ) y0
  real ( kind = rk ) z

  eps = epsilon ( eps )
  w = 0.0D+00
  w1 = 0.0D+00

  if ( a < 0.0D+00 .or. b < 0.0D+00 ) then
    ierr = 1
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'BETA_INC - Fatal error!'
    write ( *, '(a,i8)' ) '  IERR = ', ierr
    return
  end if

  if ( a == 0.0D+00 .and. b == 0.0D+00 ) then
    ierr = 2
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'BETA_INC - Fatal error!'
    write ( *, '(a,i8)' ) '  IERR = ', ierr
    return
  end if

  if ( x < 0.0D+00 .or. 1.0D+00 < x ) then
    ierr = 3
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'BETA_INC - Fatal error!'
    write ( *, '(a,i8)' ) '  IERR = ', ierr
    return
  end if

  if ( y < 0.0D+00 .or. 1.0D+00 < y ) then
    ierr = 4
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'BETA_INC - Fatal error!'
    write ( *, '(a,i8)' ) '  IERR = ', ierr
    return
  end if

  z = ( ( x + y ) - 0.5D+00 ) - 0.5D+00

  if ( 3.0D+00 * eps < abs ( z ) ) then
    ierr = 5
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'BETA_INC - Fatal error!'
    write ( *, '(a,i8)' ) '  IERR = ', ierr
    return
  end if

  ierr = 0

  if ( x == 0.0D+00 ) then
    w = 0.0D+00
    w1 = 1.0D+00
    if ( a == 0.0D+00 ) then
      ierr = 6
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'BETA_INC - Fatal error!'
      write ( *, '(a,i8)' ) '  IERR = ', ierr
    end if
    return
  end if

  if ( y == 0.0D+00 ) then
    if ( b == 0.0D+00 ) then
      ierr = 7
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'BETA_INC - Fatal error!'
      write ( *, '(a,i8)' ) '  IERR = ', ierr
      return
    end if
    w = 1.0D+00
    w1 = 0.0D+00
    return
  end if

  if ( a == 0.0D+00 ) then
    w = 1.0D+00
    w1 = 0.0D+00
    return
  end if

  if ( b == 0.0D+00 ) then
    w = 0.0D+00
    w1 = 1.0D+00
    return
  end if

  eps = max ( eps, 1.0D-15 )

  if ( max ( a, b ) < 0.001D+00 * eps ) then
    go to 260
  end if

  ind = 0
  a0 = a
  b0 = b
  x0 = x
  y0 = y

  if ( 1.0D+00 < min ( a0, b0 ) ) then
    go to 40
  end if
!
!  Procedure for A0 <= 1 or B0 <= 1
!
  if ( 0.5D+00 < x ) then
    ind = 1
    a0 = b
    b0 = a
    x0 = y
    y0 = x
  end if

  if ( b0 < min ( eps, eps * a0 ) ) then
    go to 90
  end if

  if ( a0 < min ( eps, eps * b0 ) .and. b0 * x0 <= 1.0D+00 ) then
    go to 100
  end if

  if ( 1.0D+00 < max ( a0, b0 ) ) then
    go to 20
  end if

  if ( min ( 0.2D+00, b0 ) <= a0 ) then
    go to 110
  end if

  if ( x0**a0 <= 0.9D+00 ) then
    go to 110
  end if

  if ( 0.3D+00 <= x0 ) then
    go to 120
  end if

  n = 20
  go to 140

20 continue

  if ( b0 <= 1.0D+00 ) then
    go to 110
  end if

  if ( 0.3D+00 <= x0 ) then
    go to 120
  end if

  if ( 0.1D+00 <= x0 ) then
    go to 30
  end if

  if ( ( x0 * b0 )**a0 <= 0.7D+00 ) then
    go to 110
  end if

30 continue

  if ( 15.0D+00 < b0 ) then
    go to 150
  end if

  n = 20
  go to 140
!
!  PROCEDURE for 1 < A0 and 1 < B0.
!
40 continue

  if ( a <= b ) then
    lambda = a - ( a + b ) * x
  else
    lambda = ( a + b ) * y - b
  end if

  if ( lambda < 0.0D+00 ) then
    ind = 1
    a0 = b
    b0 = a
    x0 = y
    y0 = x
    lambda = abs ( lambda )
  end if

!70 continue

  if ( b0 < 40.0D+00 .and. b0 * x0 <= 0.7D+00 ) then
    go to 110
  end if

  if ( b0 < 40.0D+00 ) then
    go to 160
  end if

  if ( b0 < a0 ) then
    go to 80
  end if

  if ( a0 <= 100.0D+00 ) then
    go to 130
  end if

  if ( 0.03D+00 * a0 < lambda ) then
    go to 130
  end if

  go to 200

80 continue

  if ( b0 <= 100.0D+00 ) then
    go to 130
  end if

  if ( 0.03D+00 * b0 < lambda ) then
    go to 130
  end if

  go to 200
!
!  Evaluation of the appropriate algorithm.
!
90 continue

  w = fpser ( a0, b0, x0, eps )
  w1 = 0.5D+00 + ( 0.5D+00 - w )
  go to 250

100 continue

  w1 = apser ( a0, b0, x0, eps )
  w = 0.5D+00 + ( 0.5D+00 - w1 )
  go to 250

110 continue

  w = beta_pser ( a0, b0, x0, eps )
  w1 = 0.5D+00 + ( 0.5D+00 - w )
  go to 250

120 continue

  w1 = beta_pser ( b0, a0, y0, eps )
  w = 0.5D+00 + ( 0.5D+00 - w1 )
  go to 250

130 continue

  w = beta_frac ( a0, b0, x0, y0, lambda, 15.0D+00 * eps )
  w1 = 0.5D+00 + ( 0.5D+00 - w )
  go to 250

140 continue

  w1 = beta_up ( b0, a0, y0, x0, n, eps )
  b0 = b0 + n

150 continue

  call beta_grat ( b0, a0, y0, x0, w1, 15.0D+00 * eps, ierr1 )
  w = 0.5D+00 + ( 0.5D+00 - w1 )
  go to 250

160 continue

  n = int ( b0 )
  b0 = b0 - n

  if ( b0 == 0.0D+00 ) then
    n = n - 1
    b0 = 1.0D+00
  end if

!170 continue

  w = beta_up ( b0, a0, y0, x0, n, eps )

  if ( x0 <= 0.7D+00 ) then
    w = w + beta_pser ( a0, b0, x0, eps )
    w1 = 0.5D+00 + ( 0.5D+00 - w )
    go to 250
  end if

  if ( a0 <= 15.0D+00 ) then
    n = 20
    w = w + beta_up ( a0, b0, x0, y0, n, eps )
    a0 = a0 + n
  end if

!190 continue

  call beta_grat ( a0, b0, x0, y0, w, 15.0D+00 * eps, ierr1 )
  w1 = 0.5D+00 + ( 0.5D+00 - w )
  go to 250

200 continue

  w = beta_asym ( a0, b0, lambda, 100.0D+00 * eps )
  w1 = 0.5D+00 + ( 0.5D+00 - w )
  go to 250
!
!  Termination of the procedure.
!
250 continue

  if ( ind /= 0 ) then
    t = w
    w = w1
    w1 = t
  end if

  return
!
!  Procedure for A and B < 0.001 * EPS
!
260 continue

  w = b / ( a + b )
  w1 = a / ( a + b )

  return
end
subroutine beta_inc_values ( n_data, a, b, x, fx )

!*****************************************************************************80
!
!! beta_inc_values() returns some values of the incomplete Beta function.
!
!  Discussion:
!
!    The incomplete Beta function may be written
!
!      BETA_INC(A,B,X) = Integral (0 to X) T^(A-1) * (1-T)^(B-1) dT
!                      / Integral (0 to 1) T^(A-1) * (1-T)^(B-1) dT
!
!    Thus,
!
!      BETA_INC(A,B,0.0) = 0.0
!      BETA_INC(A,B,1.0) = 1.0
!
!    Note that in Mathematica, the expressions:
!
!      BETA[A,B]   = Integral (0 to 1) T^(A-1) * (1-T)^(B-1) dT
!      BETA[X,A,B] = Integral (0 to X) T^(A-1) * (1-T)^(B-1) dT
!
!    and thus, to evaluate the incomplete Beta function requires:
!
!      BETA_INC(A,B,X) = BETA[X,A,B] / BETA[A,B]
!
!  Licensing:
!
!    This code is distributed under the MIT license.
!
!  Modified:
!
!    15 February 2021
!
!  Author:
!
!    John Burkardt
!
!  Reference:
!
!    Milton Abramowitz, Irene Stegun,
!    Handbook of Mathematical Functions,
!    US Department of Commerce, 1964.
!
!    Karl Pearson,
!    Tables of the Incomplete Beta Function,
!    Cambridge University Press, 1968.
!
!  Parameters:
!
!    Input/output, integer N_DATA.  The user sets N_DATA to 0
!    before the first call.  On each call, the routine increments N_DATA by 1,
!    and returns the corresponding data; when there is no more data, the
!    output value of N_DATA will be 0 again.
!
!    Output, real ( kind = rk ) A, B, X, the arguments of the function.
!
!    Output, real ( kind = rk ) FX, the value of the function.
!
  implicit none

  integer, parameter :: rk = kind ( 1.0D+00 )

  integer, parameter :: n_max = 30

  real ( kind = rk ) a
  real ( kind = rk ), save, dimension ( n_max ) :: a_vec = (/ &
     0.5D+00,  0.5D+00,  0.5D+00,  1.0D+00, &
     1.0D+00,  1.0D+00,  1.0D+00,  1.0D+00, &
     2.0D+00,  2.0D+00,  2.0D+00,  2.0D+00, &
     2.0D+00,  2.0D+00,  2.0D+00,  2.0D+00, &
     2.0D+00,  5.5D+00, 10.0D+00, 10.0D+00, &
    10.0D+00, 10.0D+00, 20.0D+00, 20.0D+00, &
    20.0D+00, 20.0D+00, 20.0D+00, 30.0D+00, &
    30.0D+00, 40.0D+00 /)
  real ( kind = rk ) b
  real ( kind = rk ), save, dimension ( n_max ) :: b_vec = (/ &
     0.5D+00,  0.5D+00,  0.5D+00,  0.5D+00, &
     0.5D+00,  0.5D+00,  0.5D+00,  1.0D+00, &
     2.0D+00,  2.0D+00,  2.0D+00,  2.0D+00, &
     2.0D+00,  2.0D+00,  2.0D+00,  2.0D+00, &
     2.0D+00,  5.0D+00,  0.5D+00,  5.0D+00, &
     5.0D+00, 10.0D+00,  5.0D+00, 10.0D+00, &
    10.0D+00, 20.0D+00, 20.0D+00, 10.0D+00, &
    10.0D+00, 20.0D+00 /)
  real ( kind = rk ) fx
  real ( kind = rk ), save, dimension ( n_max ) :: fx_vec = (/ &
    0.0637686D+00, 0.2048328D+00, 1.0000000D+00, 0.0D+00,       &
    0.0050126D+00, 0.0513167D+00, 0.2928932D+00, 0.5000000D+00, &
    0.028D+00,     0.104D+00,     0.216D+00,     0.352D+00,     &
    0.500D+00,     0.648D+00,     0.784D+00,     0.896D+00,     &
    0.972D+00,     0.4361909D+00, 0.1516409D+00, 0.0897827D+00, &
    1.0000000D+00, 0.5000000D+00, 0.4598773D+00, 0.2146816D+00, &
    0.9507365D+00, 0.5000000D+00, 0.8979414D+00, 0.2241297D+00, &
    0.7586405D+00, 0.7001783D+00 /)
  integer n_data
  real ( kind = rk ) x
  real ( kind = rk ), save, dimension ( n_max ) :: x_vec = (/ &
    0.01D+00, 0.10D+00, 1.00D+00, 0.0D+00,  &
    0.01D+00, 0.10D+00, 0.50D+00, 0.50D+00, &
    0.1D+00,  0.2D+00,  0.3D+00,  0.4D+00,  &
    0.5D+00,  0.6D+00,  0.7D+00,  0.8D+00,  &
    0.9D+00,  0.50D+00, 0.90D+00, 0.50D+00, &
    1.00D+00, 0.50D+00, 0.80D+00, 0.60D+00, &
    0.80D+00, 0.50D+00, 0.60D+00, 0.70D+00, &
    0.80D+00, 0.70D+00 /)

  if ( n_data < 0 ) then
    n_data = 0
  end if

  n_data = n_data + 1

  if ( n_max < n_data ) then
    n_data = 0
    a = 0.0D+00
    b = 0.0D+00
    x = 0.0D+00
    fx = 0.0D+00
  else
    a = a_vec(n_data)
    b = b_vec(n_data)
    x = x_vec(n_data)
    fx = fx_vec(n_data)
  end if

  return
end
function beta_log ( a0, b0 )

!*****************************************************************************80
!
!! beta_log() evaluates the logarithm of the beta function.
!
!  Licensing:
!
!    This code is distributed under the MIT license.
!
!  Modified:
!
!    15 February 2021
!
!  Author:
!
!    Armido DiDinato, Alfred Morris
!
!  Reference:
!
!    Armido DiDinato, Alfred Morris,
!    Algorithm 708:
!    Significant Digit Computation of the Incomplete Beta Function Ratios,
!    ACM Transactions on Mathematical Software,
!    Volume 18, 1993, pages 360-373.
!
!  Input:
!
!    real ( kind = rk ) A0, B0, the parameters of the function.
!    A0 and B0 should be nonnegative.
!
!  Output:
!
!    real ( kind = rk ) BETA_LOG, the value of the logarithm
!    of the Beta function.
!
  implicit none

  integer, parameter :: rk = kind ( 1.0D+00 )

  real ( kind = rk ) a
  real ( kind = rk ) a0
  real ( kind = rk ) algdiv
  real ( kind = rk ) alnrel
  real ( kind = rk ) b
  real ( kind = rk ) b0
  real ( kind = rk ) bcorr
  real ( kind = rk ) beta_log
  real ( kind = rk ) c
  real ( kind = rk ), parameter :: e = 0.918938533204673D+00
  real ( kind = rk ) gamma_log
  real ( kind = rk ) gsumln
  real ( kind = rk ) h
  integer i
  integer n
  real ( kind = rk ) u
  real ( kind = rk ) v
  real ( kind = rk ) w
  real ( kind = rk ) z

  a = min ( a0, b0 )
  b = max ( a0, b0 )
!
!  8 < A.
!
  if ( 8.0D+00 <= a ) then

    w = bcorr ( a, b )
    h = a / b
    c = h / ( 1.0D+00 + h )
    u = - ( a - 0.5D+00 ) * log ( c )
    v = b * alnrel ( h )

    if ( v < u ) then
      beta_log = ((( -0.5D+00 * log ( b ) + e ) + w ) - v ) - u
    else
      beta_log = ((( -0.5D+00 * log ( b ) + e ) + w ) - u ) - v
    end if

    return
  end if
!
!  Procedure when A < 1
!
  if ( a < 1.0D+00 ) then

    if ( b < 8.0D+00 ) then
      beta_log = gamma_log ( a ) + ( gamma_log ( b ) - gamma_log ( a + b ) )
    else
      beta_log = gamma_log ( a ) + algdiv ( a, b )
    end if

    return

  end if
!
!  Procedure when 1 <= A < 8
!
  if ( 2.0D+00 < a ) then
    go to 40
  end if

  if ( b <= 2.0D+00 ) then
    beta_log = gamma_log ( a ) + gamma_log ( b ) - gsumln ( a, b )
    return
  end if

  w = 0.0D+00

  if ( b < 8.0D+00 ) then
    go to 60
  end if

  beta_log = gamma_log ( a ) + algdiv ( a, b )
  return

40 continue
!
!  Reduction of A when 1000 < B.
!
  if ( 1000.0D+00 < b ) then

    n = int ( a - 1.0D+00 )
    w = 1.0D+00
    do i = 1, n
      a = a - 1.0D+00
      w = w * ( a / ( 1.0D+00 + a / b ))
    end do

    beta_log = ( log ( w ) - n * log ( b ) ) &
      + ( gamma_log ( a ) + algdiv ( a, b ) )

    return
  end if

  n = int ( a - 1.0D+00 )
  w = 1.0D+00
  do i = 1, n
    a = a - 1.0D+00
    h = a / b
    w = w * ( h / ( 1.0D+00 + h ) )
  end do
  w = log ( w )

  if ( 8.0D+00 <= b ) then
    beta_log = w + gamma_log ( a ) + algdiv ( a, b )
    return
  end if
!
!  Reduction of B when B < 8.
!
60 continue

  n = int ( b - 1.0D+00 )
  z = 1.0D+00
  do i = 1, n
    b = b - 1.0D+00
    z = z * ( b / ( a + b ))
  end do

  beta_log = w + log ( z ) + ( gamma_log ( a ) + ( gamma_log ( b ) &
    - gsumln ( a, b ) ) )

  return
end
function beta_pser ( a, b, x, eps )

!*****************************************************************************80
!
!! beta_pser() uses a power series expansion to evaluate IX(A,B)(X).
!
!  Discussion:
!
!    BETA_PSER is used when B <= 1 or B*X <= 0.7.
!
!  Licensing:
!
!    This code is distributed under the MIT license.
!
!  Modified:
!
!    15 February 2021
!
!  Author:
!
!    Armido DiDinato, Alfred Morris
!
!  Reference:
!
!    Armido DiDinato, Alfred Morris,
!    Algorithm 708:
!    Significant Digit Computation of the Incomplete Beta Function Ratios,
!    ACM Transactions on Mathematical Software,
!    Volume 18, 1993, pages 360-373.
!
!  Input:
!
!    real ( kind = rk ) A, B, the parameters.
!
!    real ( kind = rk ) X, the point where the function
!    is to be evaluated.
!
!    real ( kind = rk ) EPS, the tolerance.
!
!  Output:
!
!    real ( kind = rk ) BETA_PSER, the approximate value of IX(A,B)(X).
!
  implicit none

  integer, parameter :: rk = kind ( 1.0D+00 )

  real ( kind = rk ) a
  real ( kind = rk ) a0
  real ( kind = rk ) algdiv
  real ( kind = rk ) apb
  real ( kind = rk ) b
  real ( kind = rk ) b0
  real ( kind = rk ) beta_log
  real ( kind = rk ) beta_pser
  real ( kind = rk ) c
  real ( kind = rk ) eps
  real ( kind = rk ) gam1
  real ( kind = rk ) gamma_ln1
  integer i
  integer m
  real ( kind = rk ) n
  real ( kind = rk ) sum1
  real ( kind = rk ) t
  real ( kind = rk ) tol
  real ( kind = rk ) u
  real ( kind = rk ) w
  real ( kind = rk ) x
  real ( kind = rk ) z

  beta_pser = 0.0D+00

  if ( x == 0.0D+00 ) then
    return
  end if
!
!  Compute the factor X^A/(A*BETA(A,B))
!
  a0 = min ( a, b )

  if ( 1.0D+00 <= a0 ) then

    z = a * log ( x ) - beta_log ( a, b )
    beta_pser = exp ( z ) / a

  else

    b0 = max ( a, b )

    if ( b0 <= 1.0D+00 ) then

      beta_pser = x ** a
      if ( beta_pser == 0.0D+00 ) then
        return
      end if

      apb = a + b

      if ( apb <= 1.0D+00 ) then
        z = 1.0D+00 + gam1 ( apb )
      else
        u = a + b - 1.0D+00
        z = ( 1.0D+00 + gam1 ( u ) ) / apb
      end if

      c = ( 1.0D+00 + gam1 ( a ) ) &
        * ( 1.0D+00 + gam1 ( b ) ) / z
      beta_pser = beta_pser * c * ( b / apb )

    else if ( b0 < 8.0D+00 ) then

      u = gamma_ln1 ( a0 )
      m = int ( b0 - 1.0D+00 )

      c = 1.0D+00
      do i = 1, m
        b0 = b0 - 1.0D+00
        c = c * ( b0 / ( a0 + b0 ))
      end do

      u = log ( c ) + u
      z = a * log ( x ) - u
      b0 = b0 - 1.0D+00
      apb = a0 + b0

      if ( apb <= 1.0D+00 ) then
        t = 1.0D+00 + gam1 ( apb )
      else
        u = a0 + b0 - 1.0D+00
        t = ( 1.0D+00 + gam1 ( u ) ) / apb
      end if

      beta_pser = exp ( z ) * ( a0 / a ) &
        * ( 1.0D+00 + gam1 ( b0 )) / t

    else if ( 8.0D+00 <= b0 ) then

      u = gamma_ln1 ( a0 ) + algdiv ( a0, b0 )
      z = a * log ( x ) - u
      beta_pser = ( a0 / a ) * exp ( z )

    end if

  end if

  if ( beta_pser == 0.0D+00 .or. a <= 0.1D+00 * eps ) then
    return
  end if
!
!  Compute the series.
!
  sum1 = 0.0D+00
  n = 0.0D+00
  c = 1.0D+00
  tol = eps / a

  do

    n = n + 1.0D+00
    c = c * ( 0.5D+00 + ( 0.5D+00 - b / n ) ) * x
    w = c / ( a + n )
    sum1 = sum1 + w

    if ( abs ( w ) <= tol ) then
      exit
    end if

  end do

  beta_pser = beta_pser * ( 1.0D+00 + a * sum1 )

  return
end
function beta_rcomp ( a, b, x, y )

!*****************************************************************************80
!
!! beta_rcomp() evaluates X^A * Y^B / Beta(A,B).
!
!  Licensing:
!
!    This code is distributed under the MIT license.
!
!  Modified:
!
!    15 February 2021
!
!  Author:
!
!    Armido DiDinato, Alfred Morris
!
!  Reference:
!
!    Armido DiDinato, Alfred Morris,
!    Algorithm 708:
!    Significant Digit Computation of the Incomplete Beta Function Ratios,
!    ACM Transactions on Mathematical Software,
!    Volume 18, 1993, pages 360-373.
!
!  Input:
!
!    real ( kind = rk ) A, B, the parameters of the Beta function.
!    A and B should be nonnegative.
!
!    real ( kind = rk ) X, Y, define the numerator of the fraction.
!
!  Output:
!
!    real ( kind = rk ) BETA_RCOMP, the value of X^A * Y^B / Beta(A,B).
!
  implicit none

  integer, parameter :: rk = kind ( 1.0D+00 )

  real ( kind = rk ) a
  real ( kind = rk ) a0
  real ( kind = rk ) algdiv
  real ( kind = rk ) alnrel
  real ( kind = rk ) apb
  real ( kind = rk ) b
  real ( kind = rk ) b0
  real ( kind = rk ) bcorr
  real ( kind = rk ) beta_log
  real ( kind = rk ) beta_rcomp
  real ( kind = rk ) c
  real ( kind = rk ), parameter :: const = 0.398942280401433D+00
  real ( kind = rk ) e
  real ( kind = rk ) gam1
  real ( kind = rk ) gamma_ln1
  real ( kind = rk ) h
  integer i
  real ( kind = rk ) lambda
  real ( kind = rk ) lnx
  real ( kind = rk ) lny
  integer n
  real ( kind = rk ) rlog1
  real ( kind = rk ) t
  real ( kind = rk ) u
  real ( kind = rk ) v
  real ( kind = rk ) x
  real ( kind = rk ) x0
  real ( kind = rk ) y
  real ( kind = rk ) y0
  real ( kind = rk ) z

  beta_rcomp = 0.0D+00
  if ( x == 0.0D+00 .or. y == 0.0D+00 ) then
    return
  end if

  a0 = min ( a, b )

  if ( a0 < 8.0D+00 ) then

    if ( x <= 0.375D+00 ) then
      lnx = log ( x )
      lny = alnrel ( - x )
    else if ( y <= 0.375D+00 ) then
      lnx = alnrel ( - y )
      lny = log ( y )
    else
      lnx = log ( x )
      lny = log ( y )
    end if

    z = a * lnx + b * lny

    if ( 1.0D+00 <= a0 ) then
      z = z - beta_log ( a, b )
      beta_rcomp = exp ( z )
      return
    end if
!
!  Procedure for A < 1 or B < 1
!
    b0 = max ( a, b )

    if ( b0 <= 1.0D+00 ) then

      beta_rcomp = exp ( z )
      if ( beta_rcomp == 0.0D+00 ) then
        return
      end if

      apb = a + b

      if ( apb <= 1.0D+00 ) then
        z = 1.0D+00 + gam1 ( apb )
      else
        u = a + b - 1.0D+00
        z = ( 1.0D+00 + gam1 ( u ) ) / apb
      end if

      c = ( 1.0D+00 + gam1 ( a ) ) &
        * ( 1.0D+00 + gam1 ( b ) ) / z
      beta_rcomp = beta_rcomp * ( a0 * c ) &
        / ( 1.0D+00 + a0 / b0 )

    else if ( b0 < 8.0D+00 ) then

      u = gamma_ln1 ( a0 )
      n = int ( b0 - 1.0D+00 )

      c = 1.0D+00
      do i = 1, n
        b0 = b0 - 1.0D+00
        c = c * ( b0 / ( a0 + b0 ))
      end do
      u = log ( c ) + u

      z = z - u
      b0 = b0 - 1.0D+00
      apb = a0 + b0

      if ( apb <= 1.0D+00 ) then
        t = 1.0D+00 + gam1 ( apb )
      else
        u = a0 + b0 - 1.0D+00
        t = ( 1.0D+00 + gam1 ( u ) ) / apb
      end if

      beta_rcomp = a0 * exp ( z ) * ( 1.0D+00 + gam1 ( b0 ) ) / t

    else if ( 8.0D+00 <= b0 ) then

      u = gamma_ln1 ( a0 ) + algdiv ( a0, b0 )
      beta_rcomp = a0 * exp ( z - u )

    end if

  else

    if ( a <= b ) then
      h = a / b
      x0 = h / ( 1.0D+00 + h )
      y0 = 1.0D+00 / (  1.0D+00 + h )
      lambda = a - ( a + b ) * x
    else
      h = b / a
      x0 = 1.0D+00 / ( 1.0D+00 + h )
      y0 = h / ( 1.0D+00 + h )
      lambda = ( a + b ) * y - b
    end if

    e = -lambda / a

    if ( abs ( e ) <= 0.6D+00 ) then
      u = rlog1 ( e )
    else
      u = e - log ( x / x0 )
    end if

    e = lambda / b

    if ( abs ( e ) <= 0.6D+00 ) then
      v = rlog1 ( e )
    else
      v = e - log ( y / y0 )
    end if

    z = exp ( - ( a * u + b * v ) )
    beta_rcomp = const * sqrt ( b * x0 ) * z * exp ( - bcorr ( a, b ))

  end if

  return
end
function beta_rcomp1 ( mu, a, b, x, y )

!*****************************************************************************80
!
!! beta_rcomp1() evaluates exp(MU) * X^A * Y^B / Beta(A,B).
!
!  Licensing:
!
!    This code is distributed under the MIT license.
!
!  Modified:
!
!    15 February 2021
!
!  Author:
!
!    Armido DiDinato, Alfred Morris
!
!  Reference:
!
!    Armido DiDinato, Alfred Morris,
!    Algorithm 708:
!    Significant Digit Computation of the Incomplete Beta Function Ratios,
!    ACM Transactions on Mathematical Software,
!    Volume 18, 1993, pages 360-373.
!
!  Input:
!
!    integer MU, ?
!
!    real ( kind = rk ) A, B, the parameters of the Beta function.
!    A and B should be nonnegative.
!
!    real ( kind = rk ) X, Y, quantities whose powers form part of
!    the expression.
!
!  Output:
!
!    real ( kind = rk ) BETA_RCOMP1, the value of
!    exp(MU) * X^A * Y^B / Beta(A,B).
!
  implicit none

  integer, parameter :: rk = kind ( 1.0D+00 )

  real ( kind = rk ) a
  real ( kind = rk ) a0
  real ( kind = rk ) algdiv
  real ( kind = rk ) alnrel
  real ( kind = rk ) apb
  real ( kind = rk ) b
  real ( kind = rk ) b0
  real ( kind = rk ) bcorr
  real ( kind = rk ) beta_log
  real ( kind = rk ) beta_rcomp1
  real ( kind = rk ) c
  real ( kind = rk ), parameter :: const = 0.398942280401433D+00
  real ( kind = rk ) e
  real ( kind = rk ) esum
  real ( kind = rk ) gam1
  real ( kind = rk ) gamma_ln1
  real ( kind = rk ) h
  integer i
  real ( kind = rk ) lambda
  real ( kind = rk ) lnx
  real ( kind = rk ) lny
  integer mu
  integer n
  real ( kind = rk ) rlog1
  real ( kind = rk ) t
  real ( kind = rk ) u
  real ( kind = rk ) v
  real ( kind = rk ) x
  real ( kind = rk ) x0
  real ( kind = rk ) y
  real ( kind = rk ) y0
  real ( kind = rk ) z

  a0 = min ( a, b )
!
!  Procedure for 8 <= A and 8 <= B.
!
  if ( 8.0D+00 <= a0 ) then

    if ( a <= b ) then
      h = a / b
      x0 = h / ( 1.0D+00 + h )
      y0 = 1.0D+00 / ( 1.0D+00 + h )
      lambda = a - ( a + b ) * x
    else
      h = b / a
      x0 = 1.0D+00 / ( 1.0D+00 + h )
      y0 = h / ( 1.0D+00 + h )
      lambda = ( a + b ) * y - b
    end if

    e = -lambda / a

    if ( abs ( e ) <= 0.6D+00 ) then
      u = rlog1 ( e )
    else
      u = e - log ( x / x0 )
    end if

    e = lambda / b

    if ( abs ( e ) <= 0.6D+00 ) then
      v = rlog1 ( e )
    else
      v = e - log ( y / y0 )
    end if

    z = esum ( mu, - ( a * u + b * v ))
    beta_rcomp1 = const * sqrt ( b * x0 ) * z * exp ( - bcorr ( a, b ) )
!
!  Procedure for A < 8 or B < 8.
!
  else

    if ( x <= 0.375D+00 ) then
      lnx = log ( x )
      lny = alnrel ( - x )
    else if ( y <= 0.375D+00 ) then
      lnx = alnrel ( - y )
      lny = log ( y )
    else
      lnx = log ( x )
      lny = log ( y )
    end if

    z = a * lnx + b * lny

    if ( 1.0D+00 <= a0 ) then
      z = z - beta_log ( a, b )
      beta_rcomp1 = esum ( mu, z )
      return
    end if
!
!  Procedure for A < 1 or B < 1.
!
    b0 = max ( a, b )

    if ( 8.0D+00 <= b0 ) then
      u = gamma_ln1 ( a0 ) + algdiv ( a0, b0 )
      beta_rcomp1 = a0 * esum ( mu, z-u )
      return
    end if

    if ( 1.0D+00 < b0 ) then
!
!  Algorithm for 1 < B0 < 8
!
      u = gamma_ln1 ( a0 )
      n = int ( b0 - 1.0D+00 )

      c = 1.0D+00
      do i = 1, n
        b0 = b0 - 1.0D+00
        c = c * ( b0 / ( a0 + b0 ) )
      end do
      u = log ( c ) + u

      z = z - u
      b0 = b0 - 1.0D+00
      apb = a0 + b0

      if ( apb <= 1.0D+00 ) then
        t = 1.0D+00 + gam1 ( apb )
      else
        u = a0 + b0 - 1.0D+00
        t = ( 1.0D+00 + gam1 ( u ) ) / apb
      end if

      beta_rcomp1 = a0 * esum ( mu, z ) &
        * ( 1.0D+00 + gam1 ( b0 ) ) / t
!
!  Algorithm for B0 <= 1
!
    else

      beta_rcomp1 = esum ( mu, z )
      if ( beta_rcomp1 == 0.0D+00 ) then
        return
      end if

      apb = a + b

      if ( apb <= 1.0D+00 ) then
        z = 1.0D+00 + gam1 ( apb )
      else
        u = real ( a, kind = rk ) + real ( b, kind = rk ) - 1.0D+00
        z = ( 1.0D+00 + gam1 ( u )) / apb
      end if

      c = ( 1.0D+00 + gam1 ( a ) ) &
        * ( 1.0D+00 + gam1 ( b ) ) / z
      beta_rcomp1 = beta_rcomp1 * ( a0 * c ) / ( 1.0D+00 + a0 / b0 )

    end if

  end if

  return
end
function beta_up ( a, b, x, y, n, eps )

!*****************************************************************************80
!
!! beta_up() evaluates IX(A,B) - IX(A+N,B) where N is a positive integer.
!
!  Licensing:
!
!    This code is distributed under the MIT license.
!
!  Modified:
!
!    15 February 2021
!
!  Author:
!
!    Armido DiDinato, Alfred Morris
!
!  Reference:
!
!    Armido DiDinato, Alfred Morris,
!    Algorithm 708:
!    Significant Digit Computation of the Incomplete Beta Function Ratios,
!    ACM Transactions on Mathematical Software,
!    Volume 18, 1993, pages 360-373.
!
!  Input:
!
!    real ( kind = rk ) A, B, the parameters of the function.
!    A and B should be nonnegative.
!
!    real ( kind = rk ) X, Y, ?
!
!    integer N, the increment to the first argument of IX.
!
!    real ( kind = rk ) EPS, the tolerance.
!
!  Output:
!
!    real ( kind = rk ) BETA_UP, the value of IX(A,B) - IX(A+N,B).
!
  implicit none

  integer, parameter :: rk = kind ( 1.0D+00 )

  real ( kind = rk ) a
  real ( kind = rk ) ap1
  real ( kind = rk ) apb
  real ( kind = rk ) b
  real ( kind = rk ) beta_rcomp1
  real ( kind = rk ) beta_up
  real ( kind = rk ) d
  real ( kind = rk ) eps
  real ( kind = rk ) exparg
  integer i
  integer k
  real ( kind = rk ) l
  integer mu
  integer n
  real ( kind = rk ) r
  real ( kind = rk ) t
  real ( kind = rk ) w
  real ( kind = rk ) x
  real ( kind = rk ) y
!
!  Obtain the scaling factor EXP(-MU) AND
!  EXP(MU) * ( X^A * Y^B / BETA(A,B) ) / A
!
  apb = a + b
  ap1 = a + 1.0D+00
  mu = 0
  d = 1.0D+00

  if ( n /= 1 ) then

    if ( 1.0D+00 <= a ) then

      if ( 1.1D+00 * ap1 <= apb ) then
        mu = int ( abs ( exparg ( 1 ) ) )
        k = int ( exparg ( 0 ) )
        if ( k < mu ) then
          mu = k
        end if
        t = mu
        d = exp ( - t )
      end if

    end if

  end if

  beta_up = beta_rcomp1 ( mu, a, b, x, y ) / a

  if ( n == 1 .or. beta_up == 0.0D+00 ) then
    return
  end if

  w = d
!
!  Let K be the index of the maximum term.
!
  k = 0

  if ( 1.0D+00 < b ) then

    if ( y <= 0.0001D+00 ) then

      k = n - 1

    else

      r = ( b - 1.0D+00 ) * x / y - a

      if ( 1.0D+00 <= r ) then
        k = n - 1
        t = n - 1
        if ( r < t ) then
          k = int ( r )
        end if
      end if

    end if
!
!  Add the increasing terms of the series.
!
    do i = 1, k
      l = i - 1
      d = ( ( apb + l ) / ( ap1 + l ) ) * x * d
      w = w + d
    end do

  end if
!
!  Add the remaining terms of the series.
!
  do i = k+1, n-1
    l = i - 1
    d = ( ( apb + l ) / ( ap1 + l ) ) * x * d
    w = w + d
    if ( d <= eps * w ) then
      beta_up = beta_up * w
      return
    end if
  end do

  beta_up = beta_up * w

  return
end
subroutine binomial_cdf_values ( n_data, a, b, x, fx )

!*****************************************************************************80
!
!! binomial_cdf_values() returns some values of the binomial CDF.
!
!  Discussion:
!
!    CDF(X)(A,B) is the probability of at most X successes in A trials,
!    given that the probability of success on a single trial is B.
!
!  Licensing:
!
!    This code is distributed under the MIT license.
!
!  Modified:
!
!    27 May 2001
!
!  Author:
!
!    John Burkardt
!
!  Reference:
!
!    Milton Abramowitz, Irene Stegun,
!    Handbook of Mathematical Functions,
!    US Department of Commerce, 1964.
!
!    Daniel Zwillinger,
!    CRC Standard Mathematical Tables and Formulae,
!    30th Edition, CRC Press, 1996, pages 651-652.
!
!  Parameters:
!
!    Input/output, integer N_DATA.  The user sets N_DATA to 0
!    before the first call.  On each call, the routine increments N_DATA by 1,
!    and returns the corresponding data; when there is no more data, the
!    output value of N_DATA will be 0 again.
!
!    Output, integer A, real ( kind = rk ) B, integer X, the
!    arguments of the function.
!
!    Output, real ( kind = rk ) FX, the value of the function.
!
  implicit none

  integer, parameter :: rk = kind ( 1.0D+00 )

  integer, parameter :: n_max = 17

  integer a
  integer, save, dimension ( n_max ) :: a_vec = (/ &
     2,  2,  2,  2, &
     2,  4,  4,  4, &
     4, 10, 10, 10, &
    10, 10, 10, 10, &
    10 /)
  real ( kind = rk ) b
  real ( kind = rk ), save, dimension ( n_max ) :: b_vec = (/ &
    0.05D+00, 0.05D+00, 0.05D+00, 0.50D+00, &
    0.50D+00, 0.25D+00, 0.25D+00, 0.25D+00, &
    0.25D+00, 0.05D+00, 0.10D+00, 0.15D+00, &
    0.20D+00, 0.25D+00, 0.30D+00, 0.40D+00, &
    0.50D+00 /)
  real ( kind = rk ) fx
  real ( kind = rk ), save, dimension ( n_max ) :: fx_vec = (/ &
    0.9025D+00, 0.9975D+00, 1.0000D+00, 0.2500D+00, &
    0.7500D+00, 0.3164D+00, 0.7383D+00, 0.9492D+00, &
    0.9961D+00, 0.9999D+00, 0.9984D+00, 0.9901D+00, &
    0.9672D+00, 0.9219D+00, 0.8497D+00, 0.6331D+00, &
    0.3770D+00 /)
  integer n_data
  integer x
  integer, save, dimension ( n_max ) :: x_vec = (/ &
     0, 1, 2, 0, &
     1, 0, 1, 2, &
     3, 4, 4, 4, &
     4, 4, 4, 4, &
     4 /)

  if ( n_data < 0 ) then
    n_data = 0
  end if

  n_data = n_data + 1

  if ( n_max < n_data ) then
    n_data = 0
    a = 0
    b = 0.0D+00
    x = 0
    fx = 0.0D+00
  else
    a = a_vec(n_data)
    b = b_vec(n_data)
    x = x_vec(n_data)
    fx = fx_vec(n_data)
  end if

  return
end
subroutine cdfbet ( which, p, q, x, y, a, b, status, bound )

!*****************************************************************************80
!
!! cdfbet() evaluates the CDF of the Beta Distribution.
!
!  Discussion:
!
!    This routine calculates any one parameter of the beta distribution
!    given the others.
!
!    The value P of the cumulative distribution function is calculated
!    directly by code associated with the reference.
!
!    Computation of the other parameters involves a seach for a value that
!    produces the desired value of P.  The search relies on the
!    monotonicity of P with respect to the other parameters.
!
!    The beta density is proportional to t^(A-1) * (1-t)^(B-1).
!
!  Licensing:
!
!    This code is distributed under the MIT license.
!
!  Modified:
!
!    15 February 2021
!
!  Author:
!
!    Barry Brown, James Lovato, Kathy Russell
!
!  Reference:
!
!    Armido DiDinato, Alfred Morris,
!    Algorithm 708:
!    Significant Digit Computation of the Incomplete Beta Function Ratios,
!    ACM Transactions on Mathematical Software,
!    Volume 18, 1993, pages 360-373.
!
!  Parameters:
!
!    Input, integer WHICH, indicates which of the next four 
!    argument values is to be calculated from the others.
!    1: Calculate P and Q from X, Y, A and B;
!    2: Calculate X and Y from P, Q, A and B;
!    3: Calculate A from P, Q, X, Y and B;
!    4: Calculate B from P, Q, X, Y and A.
!
!    Input/output, real ( kind = rk ) P, the integral from 0 to X of the
!    chi-square distribution.  Input range: [0, 1].
!
!    Input/output, real ( kind = rk ) Q, equals 1-P.  Input range: [0, 1].
!
!    Input/output, real ( kind = rk ) X, the upper limit of integration
!    of the beta density.  If it is an input value, it should lie in
!    the range [0,1].  If it is an output value, it will be searched for
!    in the range [0,1].
!
!    Input/output, real ( kind = rk ) Y, equal to 1-X.  If it is an input
!    value, it should lie in the range [0,1].  If it is an output value,
!    it will be searched for in the range [0,1].
!
!    Input/output, real ( kind = rk ) A, the first parameter of the beta
!    density.  If it is an input value, it should lie in the range
!    (0, +infinity).  If it is an output value, it will be searched
!    for in the range [1D-300,1D300].
!
!    Input/output, real ( kind = rk ) B, the second parameter of the beta
!    density.  If it is an input value, it should lie in the range
!    (0, +infinity).  If it is an output value, it will be searched
!    for in the range [1D-300,1D300].
!
!    Output, integer STATUS, reports the status of the computation.
!     0, if the calculation completed correctly;
!    -I, if the input parameter number I is out of range;
!    +1, if the answer appears to be lower than lowest search bound;
!    +2, if the answer appears to be higher than greatest search bound;
!    +3, if P + Q /= 1;
!    +4, if X + Y /= 1.
!
!    Output, real ( kind = rk ) BOUND, is only defined if STATUS is nonzero.
!    If STATUS is negative, then this is the value exceeded by parameter I.
!    if STATUS is 1 or 2, this is the search bound that was exceeded.
!
  implicit none

  integer, parameter :: rk = kind ( 1.0D+00 )

  real ( kind = rk ) a
  real ( kind = rk ), parameter :: atol = 1.0D-10
  real ( kind = rk ) b
  real ( kind = rk ) bound
  real ( kind = rk ) ccum
  real ( kind = rk ) cum
  real ( kind = rk ) fx
  real ( kind = rk ), parameter :: inf = 1.0D+300
  real ( kind = rk ) p
  real ( kind = rk ) q
  logical qhi
  logical qleft
  integer status
  real ( kind = rk ), parameter :: tol = 1.0D-08
  integer which
  real ( kind = rk ) x
  real ( kind = rk ) xhi
  real ( kind = rk ) xlo
  real ( kind = rk ) y

  status = 0
  bound = 0.0D+00

  if ( which < 1 ) then
    bound = 1.0D+00
    status = -1
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'CDFBET - Fatal error!'
    write ( *, '(a)' ) '  The input parameter WHICH is out of range.'
    write ( *, '(a)' ) '  Legal values are between 1 and 4.'
    return
  end if

  if ( 4 < which ) then
    bound = 4.0D+00
    status = -1
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'CDFBET - Fatal error!'
    write ( *, '(a)' ) '  The input parameter WHICH is out of range.'
    write ( *, '(a)' ) '  Legal values are between 1 and 4.'
    return
  end if
!
!  Unless P is to be computed, make sure it is legal.
!
  if ( which /= 1 ) then
    if ( p < 0.0D+00 ) then
      bound = 0.0D+00
      status = -2
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'CDFBET - Fatal error!'
      write ( *, '(a)' ) '  Input parameter P is out of range.'
      return
    else if ( 1.0D+00 < p ) then
      bound = 1.0D+00
      status = -2
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'CDFBET - Fatal error!'
      write ( *, '(a)' ) '  Input parameter P is out of range.'
      return
    end if
  end if
!
!  Unless Q is to be computed, make sure it is legal.
!
  if ( which /= 1 ) then
    if ( q < 0.0D+00 ) then
      bound = 0.0D+00
      status = -3
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'CDFBET - Fatal error!'
      write ( *, '(a)' ) '  Input parameter Q is out of range.'
      return
    else if ( 1.0D+00 < q ) then
      bound = 1.0D+00
      status = -3
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'CDFBET - Fatal error!'
      write ( *, '(a)' ) '  Input parameter Q is out of range.'
      return
    end if
  end if
!
!  Unless X is to be computed, make sure it is legal.
!
  if ( which /= 2 ) then
    if ( x < 0.0D+00 ) then
      bound = 0.0D+00
      status = -4
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'CDFBET - Fatal error!'
      write ( *, '(a)' ) '  Input parameter X is out of range.'
      return
    else if ( 1.0D+00 < x ) then
      bound = 1.0D+00
      status = -4
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'CDFBET - Fatal error!'
      write ( *, '(a)' ) '  Input parameter X is out of range.'
      return
    end if
  end if
!
!  Unless Y is to be computed, make sure it is legal.
!
  if ( which /= 2 ) then
    if ( y < 0.0D+00 ) then
      bound = 0.0D+00
      status = -5
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'CDFBET - Fatal error!'
      write ( *, '(a)' ) '  Input parameter Y is out of range.'
      return
    else if ( 1.0D+00 < y ) then
      bound = 1.0D+00
      status = -5
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'CDFBET - Fatal error!'
      write ( *, '(a)' ) '  Input parameter Y is out of range.'
      return
    end if
  end if
!
!  Unless A is to be computed, make sure it is legal.
!
  if ( which /= 3 ) then
    if ( a <= 0.0D+00 ) then
      bound = 0.0D+00
      status = -6
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'CDFBET - Fatal error!'
      write ( *, '(a)' ) '  Input parameter A is out of range.'
      return
    end if
  end if
!
!  Unless B is to be computed, make sure it is legal.
!
  if ( which /= 4 ) then
    if ( b <= 0.0D+00 ) then
      bound = 0.0D+00
      status = -7
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'CDFBET - Fatal error!'
      write ( *, '(a)' ) '  Input parameter B is out of range.'
      return
    end if
  end if
!
!  Check that P + Q = 1.
!
  if ( which /= 1 ) then
    if ( 3.0D+00 * epsilon ( p ) < abs ( ( p + q ) - 1.0D+00 ) ) then
      status = 3
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'CDFBET - Fatal error!'
      write ( *, '(a)' ) '  P + Q /= 1.'
      return
    end if
  end if
!
!  Check that X + Y = 1.
!
  if ( which /= 2 ) then
    if ( 3.0D+00 * epsilon ( x ) < abs ( ( x + y ) - 1.0D+00 ) ) then
      status = 4
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'CDFBET - Fatal error!'
      write ( *, '(a)' ) '  X + Y /= 1.'
      return
    end if
  end if
!
!  Compute P and Q.
!
  if ( which == 1 ) then

    call cumbet ( x, y, a, b, p, q )
    status = 0
!
!  Compute X and Y.
!
  else if ( which == 2 ) then

    call dstzr ( 0.0D+00, 1.0D+00, atol, tol )

    if ( p <= q ) then

      status = 0
      fx = 0.0D+00
      call dzror ( status, x, fx, xlo, xhi, qleft, qhi )
      y = 1.0D+00 - x

      do while ( status == 1 )

        call cumbet ( x, y, a, b, cum, ccum )
        fx = cum - p
        call dzror ( status, x, fx, xlo, xhi, qleft, qhi )
        y = 1.0D+00 - x

      end do

    else

      status = 0
      fx = 0.0D+00
      call dzror ( status, y, fx, xlo, xhi, qleft, qhi )
      x = 1.0D+00 - y

      do while ( status == 1 )

        call cumbet ( x, y, a, b, cum, ccum )
        fx = ccum - q
        call dzror ( status, y, fx, xlo, xhi, qleft, qhi )
        x = 1.0D+00 - y

      end do

    end if

    if ( status == -1 ) then
      if ( qleft ) then
        status = 1
        bound = 0.0D+00
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'CDFBET - Warning!'
        write ( *, '(a)' ) '  The desired answer appears to be lower than'
        write ( *, '(a,g14.6)' ) '  the search bound of ', bound
      else
        status = 2
        bound = 1.0D+00
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'CDFBET - Warning!'
        write ( *, '(a)' ) '  The desired answer appears to be higher than'
        write ( *, '(a,g14.6)' ) '  the search bound of ', bound
      end if
    end if
!
!  Compute A.
!
  else if ( which == 3 ) then

    call dstinv ( 0.0D+00, inf, 0.5D+00, 0.5D+00, 5.0D+00, atol, tol )

    status = 0
    a = 5.0D+00
    fx = 0.0D+00

    call dinvr ( status, a, fx, qleft, qhi )

    do while ( status == 1 )

      call cumbet ( x, y, a, b, cum, ccum )

      if ( p <= q ) then
        fx = cum - p
      else
        fx = ccum - q
      end if

      call dinvr ( status, a, fx, qleft, qhi )

    end do

    if ( status == -1 ) then

      if ( qleft ) then
        status = 1
        bound = 0.0D+00
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'CDFBET - Warning!'
        write ( *, '(a)' ) '  The desired answer appears to be lower than'
        write ( *, '(a,g14.6)' ) '  the search bound of ', bound
      else
        status = 2
        bound = inf
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'CDFBET - Warning!'
        write ( *, '(a)' ) '  The desired answer appears to be higher than'
        write ( *, '(a,g14.6)' ) '  the search bound of ', bound
      end if

    end if
!
!  Compute B.
!
  else if ( which == 4 ) then

    call dstinv ( 0.0D+00, inf, 0.5D+00, 0.5D+00, 5.0D+00, atol, tol )

    status = 0
    b = 5.0D+00
    fx = 0.0D+00

    call dinvr ( status, b, fx, qleft, qhi )

    do while ( status == 1 )

      call cumbet ( x, y, a, b, cum, ccum )

      if ( p <= q ) then
        fx = cum - p
      else
        fx = ccum - q
      end if

      call dinvr ( status, b, fx, qleft, qhi )

    end do

    if ( status == -1 ) then
      if ( qleft ) then
        status = 1
        bound = 0.0D+00
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'CDFBET - Warning!'
        write ( *, '(a)' ) '  The desired answer appears to be lower than'
        write ( *, '(a,g14.6)' ) '  the search bound of ', bound
      else
        status = 2
        bound = inf
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'CDFBET - Warning!'
        write ( *, '(a)' ) '  The desired answer appears to be higher than'
        write ( *, '(a,g14.6)' ) '  the search bound of ', bound
      end if
    end if

  end if

  return
end
subroutine cdfbin ( which, p, q, s, xn, pr, ompr, status, bound )

!*****************************************************************************80
!
!! cdfbin() evaluates the CDF of the Binomial distribution.
!
!  Discussion:
!
!    This routine calculates any one parameter of the binomial distribution
!    given the others.
!
!    The value P of the cumulative distribution function is calculated
!    directly.
!
!    Computation of the other parameters involves a seach for a value that
!    produces the desired value of P.  The search relies on the
!    monotonicity of P with respect to the other parameters.
!
!    P is the probablility of S or fewer successes in XN binomial trials,
!    each trial having an individual probability of success of PR.
!
!  Licensing:
!
!    This code is distributed under the MIT license.
!
!  Modified:
!
!    15 February 2021
!
!  Author:
!
!    Barry Brown, James Lovato, Kathy Russell
!
!  Reference:
!
!    Milton Abramowitz, Irene Stegun,
!    Handbook of Mathematical Functions
!    1966, Formula 26.5.24.
!
!  Parameters:
!
!    Input, integer WHICH, indicates which of argument values is to
!    be calculated from the others.
!    1: Calculate P and Q from S, XN, PR and OMPR;
!    2: Calculate S from P, Q, XN, PR and OMPR;
!    3: Calculate XN from P, Q, S, PR and OMPR;
!    4: Calculate PR and OMPR from P, Q, S and XN.
!
!    Input/output, real ( kind = rk ) P, the cumulation, from 0 to S,
!    of the binomial distribution.  If P is an input value, it should
!    lie in the range [0,1].
!
!    Input/output, real ( kind = rk ) Q, equal to 1-P.  If Q is an input
!    value, it should lie in the range [0,1].  If Q is an output value,
!    it will lie in the range [0,1].
!
!    Input/output, real ( kind = rk ) S, the number of successes observed.
!    Whether this is an input or output value, it should lie in the
!    range [0,XN].
!
!    Input/output, real ( kind = rk ) XN, the number of binomial trials.
!    If this is an input value it should lie in the range: (0, +infinity).
!    If it is an output value it will be searched for in the
!    range [1.0D-300, 1.0D+300].
!
!    Input/output, real ( kind = rk ) PR, the probability of success in each
!    binomial trial.  Whether this is an input or output value, it should
!    lie in the range: [0,1].
!
!    Input/output, real ( kind = rk ) OMPR, equal to 1-PR.  Whether this is an
!    input or output value, it should lie in the range [0,1].  Also, it should
!    be the case that PR + OMPR = 1.
!
!    Output, integer STATUS, reports the status of the computation.
!     0, if the calculation completed correctly;
!    -I, if the input parameter number I is out of range;
!    +1, if the answer appears to be lower than lowest search bound;
!    +2, if the answer appears to be higher than greatest search bound;
!    +3, if P + Q /= 1;
!    +4, if PR + OMPR /= 1.
!
!    Output, real ( kind = rk ) BOUND, is only defined if STATUS is nonzero.
!    If STATUS is negative, then this is the value exceeded by parameter I.
!    if STATUS is 1 or 2, this is the search bound that was exceeded.
!
  implicit none

  integer, parameter :: rk = kind ( 1.0D+00 )

  real ( kind = rk ), parameter :: atol = 1.0D-10
  real ( kind = rk ) bound
  real ( kind = rk ) ccum
  real ( kind = rk ) cum
  real ( kind = rk ) fx
  real ( kind = rk ), parameter :: inf = 1.0D+300
  real ( kind = rk ) ompr
  real ( kind = rk ) p
  real ( kind = rk ) pr
  real ( kind = rk ) q
  logical qhi
  logical qleft
  real ( kind = rk ) s
  integer status
  real ( kind = rk ), parameter :: tol = 1.0D-08
  integer which
  real ( kind = rk ) xhi
  real ( kind = rk ) xlo
  real ( kind = rk ) xn

  status = 0
  bound = 0.0D+00
!
!  Check the arguments.
!
  if ( which < 1 ) then
    bound = 1.0D+00
    status = -1
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'CDFBET - Fatal error!'
    write ( *, '(a)' ) '  The input parameter WHICH is out of range.'
    write ( *, '(a)' ) '  Legal values are between 1 and 4.'
    return
  end if

  if ( 4 < which ) then
    bound = 4.0D+00
    status = -1
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'CDFBET - Fatal error!'
    write ( *, '(a)' ) '  The input parameter WHICH is out of range.'
    write ( *, '(a)' ) '  Legal values are between 1 and 4.'
    return
  end if
!
!  Unless P is to be computed, make sure it is legal.
!
  if ( which /= 1 ) then
    if ( p < 0.0D+00 ) then
      status = -2
      bound = 0.0D+00
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'CDFBET - Fatal error!'
      write ( *, '(a)' ) '  Input parameter P is out of range.'
      return
    else if ( 1.0D+00 < p ) then
      status = -2
      bound = 1.0D+00
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'CDFBET - Fatal error!'
      write ( *, '(a)' ) '  Input parameter P is out of range.'
      return
    end if
  end if
!
!  Unless Q is to be computed, make sure it is legal.
!
  if ( which /= 1 ) then
    if ( q < 0.0D+00 ) then
      status = -3
      bound = 0.0D+00
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'CDFBET - Fatal error!'
      write ( *, '(a)' ) '  Input parameter Q is out of range.'
      return
    else if ( 1.0D+00 < q ) then
      status = -3
      bound = 1.0
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'CDFBET - Fatal error!'
      write ( *, '(a)' ) '  Input parameter Q is out of range.'
      return
    end if
  end if
!
!  Unless XN is to be computed, make sure it is legal.
!
  if ( which /= 3 ) then
    if ( xn <= 0.0D+00 ) then
      bound = 0.0D+00
      status = -5
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'CDFBET - Fatal error!'
      write ( *, '(a)' ) '  Input parameter XN is out of range.'
      return
    end if
  end if
!
!  Unless S is to be computed, make sure it is legal.
!
  if ( which /= 2 ) then
    if ( s < 0.0D+00 ) then
      bound = 0.0D+00
      status = -4
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'CDFBET - Fatal error!'
      write ( *, '(a)' ) '  Input parameter S is out of range.'
      return
    else if ( which /= 3 .and. xn < s ) then
      bound = xn
      status = -4
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'CDFBET - Fatal error!'
      write ( *, '(a)' ) '  Input parameter S is out of range.'
      return
    end if
  end if
!
!  Unless PR is to be computed, make sure it is legal.
!
  if ( which /= 4 ) then
    if ( pr < 0.0D+00 ) then
      bound = 0.0D+00
      status = -6
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'CDFBET - Fatal error!'
      write ( *, '(a)' ) '  Input parameter PR is out of range.'
      return
    else if ( 1.0D+00 < pr ) then
      bound = 1.0D+00
      status = -6
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'CDFBET - Fatal error!'
      write ( *, '(a)' ) '  Input parameter PR is out of range.'
      return
    end if
  end if
!
!  Unless OMPR is to be computed, make sure it is legal.
!
  if ( which /= 4 ) then
    if ( ompr < 0.0D+00 ) then
      bound = 0.0D+00
      status = -7
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'CDFBET - Fatal error!'
      write ( *, '(a)' ) '  Input parameter OMPR is out of range.'
      return
    else if ( 1.0D+00 < ompr ) then
      bound = 1.0D+00
      status = -7
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'CDFBET - Fatal error!'
      write ( *, '(a)' ) '  Input parameter OMPR is out of range.'
      return
    end if
  end if
!
!  Check that P + Q = 1.
!
  if ( which /= 1 ) then
    if ( 3.0D+00 * epsilon ( p ) < abs ( ( p + q ) - 1.0D+00 ) ) then
      status = 3
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'CDFBET - Fatal error!'
      write ( *, '(a)' ) '  P + Q /= 1.'
      return
    end if
  end if
!
!  Check that PR + OMPR = 1.
!
  if ( which /= 4 ) then
    if ( 3.0D+00 * epsilon ( 1.0D+00 ) &
      < abs ( ( pr + ompr ) - 1.0D+00 ) ) then
      status = 4
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'CDFBET - Fatal error!'
      write ( *, '(a)' ) '  PR + OMPR /= 1.'
      return
    end if
  end if
!
!  Calculate P and Q.
!
  if ( which == 1 ) then

    call cumbin ( s, xn, pr, ompr, p, q )
    status = 0
!
!  Calculate S.
!
  else if ( which == 2 ) then

    call dstinv ( 0.0D+00, xn, 0.5D+00, 0.5D+00, 5.0D+00, atol, tol )

    status = 0
    s = 5.0D+00
    fx = 0.0D+00

    call dinvr ( status, s, fx, qleft, qhi )

    do while ( status == 1 )

      call cumbin ( s, xn, pr, ompr, cum, ccum )

      if ( p <= q ) then
        fx = cum - p
      else
        fx = ccum - q
      end if

      call dinvr ( status, s, fx, qleft, qhi )

    end do

    if ( status == -1 ) then
      if ( qleft ) then
        status = 1
        bound = 0.0D+00
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'CDFBIN - Warning!'
        write ( *, '(a)' ) '  The desired answer appears to be lower than'
        write ( *, '(a,g14.6)' ) '  the search bound of ', bound
      else
        status = 2
        bound = xn
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'CDFBIN - Warning!'
        write ( *, '(a)' ) '  The desired answer appears to be higher than'
        write ( *, '(a,g14.6)' ) '  the search bound of ', bound
      end if
    end if
!
!  Calculate XN.
!
  else if ( which == 3 ) then

    call dstinv ( 0.0D+00, inf, 0.5D+00, 0.5D+00, 5.0D+00, atol, tol )

    status = 0
    xn = 5.0D+00
    fx = 0.0D+00

    call dinvr ( status, xn, fx, qleft, qhi )

    do while ( status == 1 )

      call cumbin ( s, xn, pr, ompr, cum, ccum )

      if ( p <= q ) then
        fx = cum - p
      else
        fx = ccum - q
      end if

      call dinvr ( status, xn, fx, qleft, qhi )

    end do

    if ( status == -1 ) then
      if ( qleft ) then
        status = 1
        bound = 0.0D+00
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'CDFBIN - Warning!'
        write ( *, '(a)' ) '  The desired answer appears to be lower than'
        write ( *, '(a,g14.6)' ) '  the search bound of ', bound
        return
      else
        status = 2
        bound = inf
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'CDFBIN - Warning!'
        write ( *, '(a)' ) '  The desired answer appears to be higher than'
        write ( *, '(a,g14.6)' ) '  the search bound of ', bound
        return
      end if
    end if
!
!  Calculate PR and OMPR.
!
  else if ( which == 4 ) then

    call dstzr ( 0.0D+00, 1.0D+00, atol, tol )

    if ( p <= q ) then

      status = 0
      call dzror ( status, pr, fx, xlo, xhi, qleft, qhi )
      ompr = 1.0D+00 - pr

      do while ( status == 1 )

        call cumbin ( s, xn, pr, ompr, cum, ccum )
        fx = cum - p
        call dzror ( status, pr, fx, xlo, xhi, qleft, qhi )
        ompr = 1.0D+00 - pr

      end do

    else

      status = 0
      call dzror ( status, ompr, fx, xlo, xhi, qleft, qhi )
      pr = 1.0D+00 - ompr

      do while ( status == 1 )

        call cumbin ( s, xn, pr, ompr, cum, ccum )
        fx = ccum - q
        call dzror ( status, ompr, fx, xlo, xhi, qleft, qhi )
        pr = 1.0D+00 - ompr

      end do

    end if

    if ( status == -1 ) then
      if ( qleft ) then
        status = 1
        bound = 0.0D+00
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'CDFBIN - Warning!'
        write ( *, '(a)' ) '  The desired answer appears to be lower than'
        write ( *, '(a,g14.6)' ) '  the search bound of ', bound
      else
        status = 2
        bound = 1.0D+00
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'CDFBIN - Warning!'
        write ( *, '(a)' ) '  The desired answer appears to be higher than'
        write ( *, '(a,g14.6)' ) '  the search bound of ', bound
      end if
    end if

  end if

  return
end
subroutine cdfchi ( which, p, q, x, df, status, bound )

!*****************************************************************************80
!
!! cdfchi() evaluates the CDF of the chi square distribution.
!
!  Discussion:
!
!    This routine calculates any one parameter of the chi square distribution
!    given the others.
!
!    The value P of the cumulative distribution function is calculated
!    directly.
!
!    Computation of the other parameters involves a seach for a value that
!    produces the desired value of P.  The search relies on the
!    monotonicity of P with respect to the other parameters.
!
!    The CDF of the chi square distribution can be evaluated
!    within Mathematica by commands such as:
!
!      Needs["Statistics`ContinuousDistributions`"]
!      CDF [ ChiSquareDistribution [ DF ], X ]
!
!  Licensing:
!
!    This code is distributed under the MIT license.
!
!  Modified:
!
!    15 February 2021
!
!  Author:
!
!    Barry Brown, James Lovato, Kathy Russell
!
!  Reference:
!
!    Milton Abramowitz, Irene Stegun,
!    Handbook of Mathematical Functions
!    1966, Formula 26.4.19.
!
!    Stephen Wolfram,
!    The Mathematica Book,
!    Fourth Edition,
!    Wolfram Media / Cambridge University Press, 1999.
!
!  Parameters:
!
!    Input, integer WHICH, indicates which argument is to be
!    calculated from the others.
!    1: Calculate P and Q from X and DF;
!    2: Calculate X from P, Q and DF;
!    3: Calculate DF from P, Q and X.
!
!    Input/output, real ( kind = rk ) P, the integral from 0 to X of
!    the chi-square distribution.  If this is an input value, it should
!    lie in the range [0,1].
!
!    Input/output, real ( kind = rk ) Q, equal to 1-P.  If Q is an input
!    value, it should lie in the range [0,1].  If Q is an output value,
!    it will lie in the range [0,1].
!
!    Input/output, real ( kind = rk ) X, the upper limit of integration
!    of the chi-square distribution.  If this is an input
!    value, it should lie in the range: [0, +infinity).  If it is an output
!    value, it will be searched for in the range: [0,1.0D+300].
!
!    Input/output, real ( kind = rk ) DF, the degrees of freedom of the
!    chi-square distribution.  If this is an input value, it should lie
!    in the range: (0, +infinity).  If it is an output value, it will be
!    searched for in the range: [ 1.0D-300, 1.0D+300].
!
!    Output, integer STATUS, reports the status of the computation.
!     0, if the calculation completed correctly;
!    -I, if the input parameter number I is out of range;
!    +1, if the answer appears to be lower than lowest search bound;
!    +2, if the answer appears to be higher than greatest search bound;
!    +3, if P + Q /= 1;
!    +10, an error was returned from CUMGAM.
!
!    Output, real ( kind = rk ) BOUND, is only defined if STATUS is nonzero.
!    If STATUS is negative, then this is the value exceeded by parameter I.
!    if STATUS is 1 or 2, this is the search bound that was exceeded.
!
  implicit none

  integer, parameter :: rk = kind ( 1.0D+00 )

  real ( kind = rk ), parameter :: atol = 1.0D-10
  real ( kind = rk ) bound
  real ( kind = rk ) ccum
  real ( kind = rk ) cum
  real ( kind = rk ) df
  real ( kind = rk ) fx
  real ( kind = rk ), parameter :: inf = 1.0D+300
  real ( kind = rk ) p
  real ( kind = rk ) porq
  real ( kind = rk ) q
  logical qhi
  logical qleft
  integer status
  real ( kind = rk ), parameter :: tol = 1.0D-08
  integer which
  real ( kind = rk ) x

  status = 0
  bound = 0.0D+00
!
!  Check the arguments.
!
  if ( which < 1 ) then
    bound = 1.0
    status = -1
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'CDFCHI - Fatal error!'
    write ( *, '(a)' ) '  The input parameter WHICH is out of range.'
    write ( *, '(a)' ) '  Legal values are between 1 and 3.'
    return
  end if

  if ( 3 < which ) then
    bound = 3.0
    status = -1
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'CDFCHI - Fatal error!'
    write ( *, '(a)' ) '  The input parameter WHICH is out of range.'
    write ( *, '(a)' ) '  Legal values are between 1 and 3.'
    return
  end if
!
!  Unless P is to be computed, make sure it is legal.
!
  if ( which /= 1 ) then
    if ( p < 0.0D+00 ) then
      status = -2
      bound = 0.0D+00
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'CDFCHI - Fatal error!'
      write ( *, '(a)' ) '  Input parameter P is out of range.'
      return
    else if ( 1.0D+00 < p ) then
      status = -2
      bound = 1.0D+00
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'CDFCHI - Fatal error!'
      write ( *, '(a)' ) '  Input parameter P is out of range.'
      return
    end if
  end if
!
!  Unless Q is to be computed, make sure it is legal.
!
  if ( which /= 1 ) then
    if ( q < 0.0D+00 ) then
      status = -3
      bound = 0.0D+00
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'CDFCHI - Fatal error!'
      write ( *, '(a)' ) '  Input parameter Q is out of range.'
      return
    else if ( 1.0D+00 < q ) then
      status = -3
      bound = 1.0D+00
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'CDFCHI - Fatal error!'
      write ( *, '(a)' ) '  Input parameter Q is out of range.'
      return
    end if
  end if
!
!  Unless X is to be computed, make sure it is legal.
!
  if ( which /= 2 ) then
    if ( x < 0.0D+00 ) then
      bound = 0.0D+00
      status = -4
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'CDFCHI - Fatal error!'
      write ( *, '(a)' ) '  Input parameter X is out of range.'
      return
    end if
  end if
!
!  Unless DF is to be computed, make sure it is legal.
!
  if ( which /= 3 ) then
    if ( df <= 0.0D+00 ) then
      bound = 0.0D+00
      status = -5
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'CDFCHI - Fatal error!'
      write ( *, '(a)' ) '  Input parameter DF is out of range.'
      return
    end if
  end if
!
!  Check that P + Q = 1.
!
  if ( which /= 1 ) then
    if ( 3.0D+00 * epsilon ( p ) < abs ( ( p + q ) - 1.0D+00 ) ) then
      status = 3
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'CDFCHI - Fatal error!'
      write ( *, '(a)' ) '  P + Q /= 1.'
      return
    end if
  end if
!
!  Select the minimum of P and Q.
!
  if ( which /= 1 ) then
    porq = min ( p, q )
  end if
!
!  Calculate P and Q.
!
  if ( which == 1 ) then

    status = 0
    call cumchi ( x, df, p, q )

    if ( 1.5D+00 < porq ) then
      status = 10
      return
    end if
!
!  Calculate X.
!
  else if ( which == 2 ) then

    call dstinv ( 0.0D+00, inf, 0.5D+00, 0.5D+00, 5.0D+00, atol, tol )

    status = 0
    x = 5.0D+00
    fx = 0.0D+00

    call dinvr ( status, x, fx, qleft, qhi )

    do while ( status == 1 )

      call cumchi ( x, df, cum, ccum )

      if ( p <= q ) then
        fx = cum - p
      else
        fx = ccum - q
      end if

      if ( 1.5D+00 < fx + porq ) then
        status = 10
        return
      end if

      call dinvr ( status, x, fx, qleft, qhi )

    end do

    if ( status == -1 ) then
      if ( qleft ) then
        status = 1
        bound = 0.0D+00
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'CDFCHI - Warning!'
        write ( *, '(a)' ) '  The desired answer appears to be lower than'
        write ( *, '(a,g14.6)' ) '  the search bound of ', bound
      else
        status = 2
        bound = inf
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'CDFCHI - Warning!'
        write ( *, '(a)' ) '  The desired answer appears to be higher than'
        write ( *, '(a,g14.6)' ) '  the search bound of ', bound
      end if

    end if
!
!  Calculate DF.
!
  else if ( which == 3 ) then

    call dstinv ( 0.0D+00, inf, 0.5D+00, 0.5D+00, 5.0D+00, atol, tol )

    status = 0
    df = 5.0D+00
    fx = 0.0D+00

    call dinvr ( status, df, fx, qleft, qhi )

    do while ( status == 1 )

      call cumchi ( x, df, cum, ccum )

      if ( p <= q ) then
        fx = cum - p
      else
        fx = ccum - q
      end if

      if ( 1.5D+00 < fx + porq ) then
        status = 10
        return
      end if

      call dinvr ( status, df, fx, qleft, qhi )

    end do

    if ( status == -1 ) then
      if ( qleft ) then
        status = 1
        bound = 0.0D+00
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'CDFCHI - Warning!'
        write ( *, '(a)' ) '  The desired answer appears to be lower than'
        write ( *, '(a,g14.6)' ) '  the search bound of ', bound
      else
        status = 2
        bound = inf
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'CDFCHI - Warning!'
        write ( *, '(a)' ) '  The desired answer appears to be higher than'
        write ( *, '(a,g14.6)' ) '  the search bound of ', bound
      end if
    end if

  end if

  return
end
subroutine cdfchn ( which, p, q, x, df, pnonc, status, bound )

!*****************************************************************************80
!
!! cdfchn() evaluates the CDF of the Noncentral Chi-Square.
!
!  Discussion:
!
!    This routine calculates any one parameter of the noncentral chi-square
!    distribution given values for the others.
!
!    The value P of the cumulative distribution function is calculated
!    directly.
!
!    Computation of the other parameters involves a seach for a value that
!    produces the desired value of P.  The search relies on the
!    monotonicity of P with respect to the other parameters.
!
!    The computation time required for this routine is proportional
!    to the noncentrality parameter (PNONC).  Very large values of
!    this parameter can consume immense computer resources.  This is
!    why the search range is bounded by 10,000.
!
!    The CDF of the noncentral chi square distribution can be evaluated
!    within Mathematica by commands such as:
!
!      Needs["Statistics`ContinuousDistributions`"]
!      CDF[ NoncentralChiSquareDistribution [ DF, LAMBDA ], X ]
!
!  Licensing:
!
!    This code is distributed under the MIT license.
!
!  Modified:
!
!    15 February 2021
!
!  Author:
!
!    Barry Brown, James Lovato, Kathy Russell
!
!  Reference:
!
!    Milton Abramowitz, Irene Stegun,
!    Handbook of Mathematical Functions
!    1966, Formula 26.5.25.
!
!    Stephen Wolfram,
!    The Mathematica Book,
!    Fourth Edition,
!    Wolfram Media / Cambridge University Press, 1999.
!
!  Parameters:
!
!    Input, integer WHICH, indicates which argument is to be
!    calculated from the others.
!    1: Calculate P and Q from X, DF and PNONC;
!    2: Calculate X from P, DF and PNONC;
!    3: Calculate DF from P, X and PNONC;
!    4: Calculate PNONC from P, X and DF.
!
!    Input/output, real ( kind = rk ) P, the integral from 0 to X of
!    the noncentral chi-square distribution.  If this is an input
!    value, it should lie in the range: [0, 1.0-1.0D-16).
!
!    Input/output, real ( kind = rk ) Q, is generally not used by this
!    subroutine and is only included for similarity with other routines.
!    However, if P is to be computed, then a value will also be computed
!    for Q.
!
!    Input, real ( kind = rk ) X, the upper limit of integration of the
!    noncentral chi-square distribution.  If this is an input value, it
!    should lie in the range: [0, +infinity).  If it is an output value,
!    it will be sought in the range: [0,1.0D+300].
!
!    Input/output, real ( kind = rk ) DF, the number of degrees of freedom
!    of the noncentral chi-square distribution.  If this is an input value,
!    it should lie in the range: (0, +infinity).  If it is an output value,
!    it will be searched for in the range: [ 1.0D-300, 1.0D+300].
!
!    Input/output, real ( kind = rk ) PNONC, the noncentrality parameter of
!    the noncentral chi-square distribution.  If this is an input value, it
!    should lie in the range: [0, +infinity).  If it is an output value,
!    it will be searched for in the range: [0,1.0D+4]
!
!    Output, integer STATUS, reports on the calculation.
!    0, if calculation completed correctly;
!    -I, if input parameter number I is out of range;
!    1, if the answer appears to be lower than the lowest search bound;
!    2, if the answer appears to be higher than the greatest search bound.
!
!    Output, real ( kind = rk ) BOUND, is only defined if STATUS is nonzero.
!    If STATUS is negative, then this is the value exceeded by parameter I.
!    if STATUS is 1 or 2, this is the search bound that was exceeded.
!
  implicit none

  integer, parameter :: rk = kind ( 1.0D+00 )

  real ( kind = rk ), parameter :: atol=1.0D-50
  real ( kind = rk ) bound
  real ( kind = rk ) ccum
  real ( kind = rk ) cum
  real ( kind = rk ) df
  real ( kind = rk ) fx
  real ( kind = rk ), parameter :: inf=1.0D+300
  real ( kind = rk ) p
  real ( kind = rk ) pnonc
  real ( kind = rk ) q
  logical qhi
  logical qleft
  integer status
  real ( kind = rk ), parameter :: tent4=1.0D+04
  real ( kind = rk ), parameter :: tol=1.0D-08
  integer which
  real ( kind = rk ) x

  status = 0
  bound = 0.0D+00
!
!  Check the arguments.
!
  if ( which < 1 ) then
    bound = 1.0D+00
    status = -1
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'CDFCHN - Fatal error!'
    write ( *, '(a)' ) '  The input parameter WHICH is out of range.'
    write ( *, '(a)' ) '  Legal values are between 1 and 4.'
    return
  end if

  if ( 4 < which ) then
    bound = 4.0D+00
    status = -1
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'CDFCHN - Fatal error!'
    write ( *, '(a)' ) '  The input parameter WHICH is out of range.'
    write ( *, '(a)' ) '  Legal values are between 1 and 4.'
    return
  end if
!
!  Unless P is to be computed, make sure it is legal.
!
  if ( which /= 1 ) then
    if ( p < 0.0D+00 ) then
      status = -2
      bound = 0.0D+00
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'CDFCHN - Fatal error!'
      write ( *, '(a)' ) '  Input parameter P is out of range.'
      return
    else if ( 1.0D+00 < p ) then
      status = -2
      bound = 1.0D+00
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'CDFCHN - Fatal error!'
      write ( *, '(a)' ) '  Input parameter P is out of range.'
      return
    end if
  end if
!
!  Unless X is to be computed, make sure it is legal.
!
  if ( which /= 2 ) then
    if ( x < 0.0D+00 ) then
      bound = 0.0D+00
      status = -4
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'CDFCHN - Fatal error!'
      write ( *, '(a)' ) '  Input parameter X is out of range.'
      return
    end if
  end if
!
!  Unless DF is to be computed, make sure it is legal.
!
  if ( which /= 3 ) then
    if ( df <= 0.0D+00 ) then
      bound = 0.0D+00
      status = -5
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'CDFCHN - Fatal error!'
      write ( *, '(a)' ) '  Input parameter DF is out of range.'
      return
    end if
  end if
!
!  Unless PNONC is to be computed, make sure it is legal.
!
  if ( which /= 4 ) then
    if ( pnonc < 0.0D+00 ) then
      bound = 0.0D+00
      status = -6
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'CDFCHN - Fatal error!'
      write ( *, '(a)' ) '  Input parameter PNONC is out of range.'
      return
    end if
  end if
!
!  Calculate P and Q.
!
  if ( which == 1 ) then

    call cumchn ( x, df, pnonc, p, q )
    status = 0
!
!  Calculate X.
!
  else if ( which == 2 ) then

    call dstinv ( 0.0D+00, inf, 0.5D+00, 0.5D+00, 5.0D+00, atol, tol )

    status = 0
    x = 5.0D+00
    fx = 0.0D+00

    call dinvr ( status, x, fx, qleft, qhi )

    do while ( status == 1 )

      call cumchn ( x, df, pnonc, cum, ccum )
      fx = cum - p
      call dinvr ( status, x, fx, qleft, qhi )

    end do

    if ( status == -1 ) then
      if ( qleft ) then
        status = 1
        bound = 0.0D+00
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'CDFCHN - Warning!'
        write ( *, '(a)' ) '  The desired answer appears to be lower than'
        write ( *, '(a,g14.6)' ) '  the search bound of ', bound
      else
        status = 2
        bound = inf
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'CDFCHN - Warning!'
        write ( *, '(a)' ) '  The desired answer appears to be higher than'
        write ( *, '(a,g14.6)' ) '  the search bound of ', bound
      end if
    end if
!
!  Calculate DF.
!
  else if ( which == 3 ) then

    call dstinv ( 0.0D+00, inf, 0.5D+00, 0.5D+00, 5.0D+00, atol, tol )

    status = 0
    df = 5.0D+00
    fx = 0.0D+00

    call dinvr ( status, df, fx, qleft, qhi )

    do while ( status == 1 )

      call cumchn ( x, df, pnonc, cum, ccum )
      fx = cum - p
      call dinvr ( status, df, fx, qleft, qhi )

    end do

    if ( status == -1 )then
      if ( qleft ) then
        status = 1
        bound = 0.0D+00
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'CDFCHN - Warning!'
        write ( *, '(a)' ) '  The desired answer appears to be lower than'
        write ( *, '(a,g14.6)' ) '  the search bound of ', bound
      else
        status = 2
        bound = inf
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'CDFCHN - Warning!'
        write ( *, '(a)' ) '  The desired answer appears to be higher than'
        write ( *, '(a,g14.6)' ) '  the search bound of ', bound
      end if
    end if
!
!  Calculate PNONC.
!
  else if ( which == 4 ) then

    call dstinv ( 0.0D+00, tent4, 0.5D+00, 0.5D+00, 5.0D+00, atol, tol )

    status = 0
    pnonc = 5.0D+00
    fx = 0.0D+00

    call dinvr ( status, pnonc, fx, qleft, qhi )

    do while ( status == 1 )

      call cumchn ( x, df, pnonc, cum, ccum )
      fx = cum - p
      call dinvr ( status, pnonc, fx, qleft, qhi )

    end do

    if ( status == -1 ) then
      if ( qleft ) then
        status = 1
        bound = 0.0D+00
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'CDFCHN - Warning!'
        write ( *, '(a)' ) '  The desired answer appears to be lower than'
        write ( *, '(a,g14.6)' ) '  the search bound of ', bound
      else
        status = 2
        bound = tent4
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'CDFCHN - Warning!'
        write ( *, '(a)' ) '  The desired answer appears to be higher than'
        write ( *, '(a,g14.6)' ) '  the search bound of ', bound
      end if
    end if

  end if

  return
end
subroutine cdff ( which, p, q, f, dfn, dfd, status, bound )

!*****************************************************************************80
!
!! cdff() evaluates the CDF of the F distribution.
!
!  Discussion:
!
!    This routine calculates any one parameter of the F distribution
!    given the others.
!
!    The value P of the cumulative distribution function is calculated
!    directly.
!
!    Computation of the other parameters involves a seach for a value that
!    produces the desired value of P.  The search relies on the
!    monotonicity of P with respect to the other parameters.
!
!    The value of the cumulative F distribution is not necessarily
!    monotone in either degrees of freedom.  There thus may be two
!    values that provide a given CDF value.  This routine assumes
!    monotonicity and will find an arbitrary one of the two values.
!
!  Licensing:
!
!    This code is distributed under the MIT license.
!
!  Modified:
!
!    15 February 2021
!
!  Author:
!
!    Barry Brown, James Lovato, Kathy Russell
!
!  Reference:
!
!    Milton Abramowitz, Irene Stegun,
!    Handbook of Mathematical Functions
!    1966, Formula 26.6.2.
!
!  Parameters:
!
!    Input, integer WHICH, indicates which argument is to be
!    calculated from the others.
!    1: Calculate P and Q from F, DFN and DFD;
!    2: Calculate F from P, Q, DFN and DFD;
!    3: Calculate DFN from P, Q, F and DFD;
!    4: Calculate DFD from P, Q, F and DFN.
!
!    Input/output, real ( kind = rk ) P, the integral from 0 to F of
!    the F-density.  If it is an input value, it should lie in the
!    range [0,1].
!
!    Input/output, real ( kind = rk ) Q, equal to 1-P.  If Q is an input
!    value, it should lie in the range [0,1].  If Q is an output value,
!    it will lie in the range [0,1].
!
!    Input/output, real ( kind = rk ) F, the upper limit of integration
!    of the F-density.  If this is an input value, it should lie in the
!    range [0, +infinity).  If it is an output value, it will be searched
!    for in the range [0,1.0D+300].
!
!    Input/output, real ( kind = rk ) DFN, the number of degrees of
!    freedom of the numerator sum of squares.  If this is an input value,
!    it should lie in the range: (0, +infinity).  If it is an output value,
!    it will be searched for in the range: [ 1.0D-300, 1.0D+300].
!
!    Input/output, real ( kind = rk ) DFD, the number of degrees of freedom
!    of the denominator sum of squares.  If this is an input value, it should
!    lie in the range: (0, +infinity).  If it is an output value, it will
!    be searched for in the  range: [ 1.0D-300, 1.0D+300].
!
!    Output, integer STATUS, reports the status of the computation.
!     0, if the calculation completed correctly;
!    -I, if the input parameter number I is out of range;
!    +1, if the answer appears to be lower than lowest search bound;
!    +2, if the answer appears to be higher than greatest search bound;
!    +3, if P + Q /= 1.
!
!    Output, real ( kind = rk ) BOUND, is only defined if STATUS is nonzero.
!    If STATUS is negative, then this is the value exceeded by parameter I.
!    if STATUS is 1 or 2, this is the search bound that was exceeded.
!
  implicit none

  integer, parameter :: rk = kind ( 1.0D+00 )

  real ( kind = rk ), parameter :: atol = 1.0D-10
  real ( kind = rk ) bound
  real ( kind = rk ) bound_hi
  real ( kind = rk ) bound_lo
  real ( kind = rk ) ccum
  real ( kind = rk ) cum
  real ( kind = rk ) dfd
  real ( kind = rk ) dfn
  real ( kind = rk ) f
  real ( kind = rk ) fx
  real ( kind = rk ), parameter :: inf = 1.0D+300
  real ( kind = rk ) p
  real ( kind = rk ) q
  logical qhi
  logical qleft
  integer status
  real ( kind = rk ), parameter :: tol = 1.0D-08
  integer which

  status = 0
  bound = 0.0D+00
!
!  Check the arguments.
!
  if ( which < 1 ) then
    bound = 1.0D+00
    status = -1
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'CDFF - Fatal error!'
    write ( *, '(a)' ) '  The input parameter WHICH is out of range.'
    write ( *, '(a)' ) '  Legal values are between 1 and 4.'
    return
  end if

  if ( 4 < which ) then
    bound = 4.0D+00
    status = -1
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'CDFF - Fatal error!'
    write ( *, '(a)' ) '  The input parameter WHICH is out of range.'
    write ( *, '(a)' ) '  Legal values are between 1 and 4.'
    return
  end if
!
!  Unless P is to be computed, make sure it is legal.
!
  if ( which /= 1 ) then
    if ( p < 0.0D+00 ) then
      status = -2
      bound = 0.0D+00
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'CDFF - Fatal error!'
      write ( *, '(a)' ) '  Input parameter P is out of range.'
      return
    else if ( 1.0D+00 < p ) then
      status = -2
      bound = 1.0D+00
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'CDFF - Fatal error!'
      write ( *, '(a)' ) '  Input parameter P is out of range.'
      return
    end if
  end if
!
!  Unless Q is to be computed, make sure it is legal.
!
  if ( which /= 1 ) then
    if ( q < 0.0D+00 ) then
      status = -3
      bound = 0.0D+00
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'CDFF - Fatal error!'
      write ( *, '(a)' ) '  Input parameter Q is out of range.'
      return
    else if ( 1.0D+00 < q ) then
      status = -3
      bound = 1.0D+00
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'CDFF - Fatal error!'
      write ( *, '(a)' ) '  Input parameter Q is out of range.'
      return
    end if
  end if
!
!  Unless F is to be computed, make sure it is legal.
!
  if ( which /= 2 ) then
    if ( f < 0.0D+00 ) then
      bound = 0.0D+00
      status = -4
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'CDFF - Fatal error!'
      write ( *, '(a)' ) '  Input parameter F is out of range.'
      return
    end if
  end if
!
!  Unless DFN is to be computed, make sure it is legal.
!
  if ( which /= 3 ) then
    if ( dfn <= 0.0D+00 ) then
      bound = 0.0D+00
      status = -5
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'CDFF - Fatal error!'
      write ( *, '(a)' ) '  Input parameter DFN is out of range.'
      return
    end if
  end if
!
!  Unless DFD is to be computed, make sure it is legal.
!
  if ( which /= 4 ) then
    if ( dfd <= 0.0D+00 ) then
      bound = 0.0D+00
      status = -6
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'CDFF - Fatal error!'
      write ( *, '(a)' ) '  Input parameter DFD is out of range.'
      return
    end if
  end if
!
!  Check that P + Q = 1.
!
  if ( which /= 1 ) then
    if ( 3.0D+00 * epsilon ( p ) < abs ( ( p + q ) - 1.0D+00 ) ) then
      status = 3
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'CDFF - Fatal error!'
      write ( *, '(a)' ) '  P + Q /= 1.'
      return
    end if
  end if
!
!  Calculate P and Q.
!
  if ( which == 1 ) then

    call cumf ( f, dfn, dfd, p, q )
    status = 0
!
!  Calculate F.
!
  else if ( which == 2 ) then

    call dstinv ( 0.0D+00, inf, 0.5D+00, 0.5D+00, 5.0D+00, atol, tol )

    status = 0
    f = 5.0D+00
    fx = 0.0D+00

    call dinvr ( status, f, fx, qleft, qhi )

    do while ( status == 1 )

      call cumf ( f, dfn, dfd, cum, ccum )

      if ( p <= q ) then
        fx = cum - p
      else
        fx = ccum - q
      end if

      call dinvr ( status, f, fx, qleft, qhi )

    end do

    if ( status == -1 ) then

      if ( qleft ) then
        status = 1
        bound = 0.0D+00
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'CDFF - Warning!'
        write ( *, '(a)' ) '  The desired answer appears to be lower than'
        write ( *, '(a,g14.6)' ) '  the search bound of ', bound
      else
        status = 2
        bound = inf
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'CDFF - Warning!'
        write ( *, '(a)' ) '  The desired answer appears to be higher than'
        write ( *, '(a,g14.6)' ) '  the search bound of ', bound
      end if

    end if
!
!  Calculate DFN.
!
!  Note that, in the original calculation, the lower bound for DFN was 0.
!  Using DFN = 0 causes an error in CUMF when it calls BETA_INC.
!  The lower bound was set to the more reasonable value of 1.
!  JVB, 14 April 2007.
!
  else if ( which == 3 ) then

    bound_lo = 1.0D+00
    bound_hi = inf

    call dstinv ( bound_lo, bound_hi, 0.5D+00, 0.5D+00, 5.0D+00, atol, tol )

    status = 0
    dfn = 5.0D+00
    fx = 0.0D+00

    call dinvr ( status, dfn, fx, qleft, qhi )

    do while ( status == 1 )

      call cumf ( f, dfn, dfd, cum, ccum )

      if ( p <= q ) then
        fx = cum - p
      else
        fx = ccum - q
      end if

      call dinvr ( status, dfn, fx, qleft, qhi )

    end do

    if ( status == -1 ) then

      if ( qleft ) then
        status = 1
        bound = bound_lo
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'CDFF - Warning!'
        write ( *, '(a)' ) '  The desired answer appears to be lower than'
        write ( *, '(a,g14.6)' ) '  the search bound of ', bound_lo
        return
      else
        status = 2
        bound = bound_hi
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'CDFF - Warning!'
        write ( *, '(a)' ) '  The desired answer appears to be higher than'
        write ( *, '(a,g14.6)' ) '  the search bound of ', bound_hi
        return
      end if

    end if
!
!  Calculate DFD.
!
!  Note that, in the original calculation, the lower bound for DFD was 0.
!  Using DFD = 0 causes an error in CUMF when it calls BETA_INC.
!  The lower bound was set to the more reasonable value of 1.
!  JVB, 14 April 2007.
!
  else if ( which == 4 ) then

    bound_lo = 1.0D+00
    bound_hi = inf

    call dstinv ( bound_lo, bound_hi, 0.5D+00, 0.5D+00, 5.0D+00, atol, tol )

    status = 0
    dfd = 5.0D+00
    fx = 0.0D+00

    call dinvr ( status, dfd, fx, qleft, qhi )

    do while ( status == 1 )

      call cumf ( f, dfn, dfd, cum, ccum )

      if ( p <= q ) then
        fx = cum - p
      else
        fx = ccum - q
      end if

      call dinvr ( status, dfd, fx, qleft, qhi )

    end do

    if ( status == -1 ) then
      if ( qleft ) then
        status = 1
        bound = bound_lo
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'CDFF - Warning!'
        write ( *, '(a)' ) '  The desired answer appears to be lower than'
        write ( *, '(a,g14.6)' ) '  the search bound of ', bound_lo
      else
        status = 2
        bound = bound_hi
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'CDFF - Warning!'
        write ( *, '(a)' ) '  The desired answer appears to be higher than'
        write ( *, '(a,g14.6)' ) '  the search bound of ', bound_hi
      end if
    end if

  end if

  return
end
subroutine cdffnc ( which, p, q, f, dfn, dfd, pnonc, status, bound )

!*****************************************************************************80
!
!! cdffnc() evaluates the CDF of the Noncentral F distribution.
!
!  Discussion:
!
!    This routine originally used 1.0D+300 as the upper bound for the
!    interval in which many of the missing parameters are to be sought.
!    Since the underlying rootfinder routine needs to evaluate the
!    function at this point, it is no surprise that the program was
!    experiencing overflows.  A less extravagant upper bound
!    is being tried for now!
!
!    This routine calculates any one parameter of the Noncentral F distribution
!    given the others.
!
!    The value P of the cumulative distribution function is calculated
!    directly.
!
!    Computation of the other parameters involves a seach for a value that
!    produces the desired value of P.  The search relies on the
!    monotonicity of P with respect to the other parameters.
!
!    The computation time required for this routine is proportional
!    to the noncentrality parameter PNONC.  Very large values of
!    this parameter can consume immense computer resources.  This is
!    why the search range is bounded by 10,000.
!
!    The value of the cumulative noncentral F distribution is not
!    necessarily monotone in either degree of freedom.  There thus
!    may be two values that provide a given CDF value.  This routine
!    assumes monotonicity and will find an arbitrary one of the two
!    values.
!
!    The CDF of the noncentral F distribution can be evaluated
!    within Mathematica by commands such as:
!
!      Needs["Statistics`ContinuousDistributions`"]
!      CDF [ NoncentralFRatioDistribution [ DFN, DFD, PNONC ], X ]
!
!  Licensing:
!
!    This code is distributed under the MIT license.
!
!  Modified:
!
!    15 February 2021
!
!  Author:
!
!    Barry Brown, James Lovato, Kathy Russell
!
!  Reference:
!
!    Milton Abramowitz, Irene Stegun,
!    Handbook of Mathematical Functions
!    1966, Formula 26.6.20.
!
!    Stephen Wolfram,
!    The Mathematica Book,
!    Fourth Edition,
!    Wolfram Media / Cambridge University Press, 1999.
!
!  Parameters:
!
!    Input, integer WHICH, indicates which argument is to be
!    calculated from the others.
!    1: Calculate P and Q from F, DFN, DFD and PNONC;
!    2: Calculate F from P, Q, DFN, DFD and PNONC;
!    3: Calculate DFN from P, Q, F, DFD and PNONC;
!    4: Calculate DFD from P, Q, F, DFN and PNONC;
!    5: Calculate PNONC from P, Q, F, DFN and DFD.
!
!    Input/output, real ( kind = rk ) P, the integral from 0 to F of
!    the noncentral F-density.  If P is an input value it should
!    lie in the range [0,1) (Not including 1!).
!
!    Dummy, real ( kind = rk ) Q, is not used by this subroutine,
!    and is only included for similarity with the other routines.
!    Its input value is not checked.  If P is to be computed, the
!    Q is set to 1 - P.
!
!    Input/output, real ( kind = rk ) F, the upper limit of integration
!    of the noncentral F-density.  If this is an input value, it should
!    lie in the range: [0, +infinity).  If it is an output value, it
!    will be searched for in the range: [0,1.0D+30].
!
!    Input/output, real ( kind = rk ) DFN, the number of degrees of freedom
!    of the numerator sum of squares.  If this is an input value, it should
!    lie in the range: (0, +infinity).  If it is an output value, it will
!    be searched for in the range: [ 1.0, 1.0D+30].
!
!    Input/output, real ( kind = rk ) DFD, the number of degrees of freedom
!    of the denominator sum of squares.  If this is an input value, it should
!    be in range: (0, +infinity).  If it is an output value, it will be
!    searched for in the range [1.0, 1.0D+30].
!
!    Input/output, real ( kind = rk ) PNONC, the noncentrality parameter
!    If this is an input value, it should be nonnegative.
!    If it is an output value, it will be searched for in the range: [0,1.0D+4].
!
!    Output, integer STATUS, reports the status of the computation.
!     0, if the calculation completed correctly;
!    -I, if the input parameter number I is out of range;
!    +1, if the answer appears to be lower than lowest search bound;
!    +2, if the answer appears to be higher than greatest search bound;
!    +3, if P + Q /= 1.
!
!    Output, real ( kind = rk ) BOUND, is only defined if STATUS is nonzero.
!    If STATUS is negative, then this is the value exceeded by parameter I.
!    if STATUS is 1 or 2, this is the search bound that was exceeded.
!
  implicit none

  integer, parameter :: rk = kind ( 1.0D+00 )

  real ( kind = rk ), parameter :: atol = 1.0D-10
  real ( kind = rk ) bound
  real ( kind = rk ) ccum
  real ( kind = rk ) cum
  real ( kind = rk ) dfd
  real ( kind = rk ) dfn
  real ( kind = rk ) f
  real ( kind = rk ) fx
  real ( kind = rk ), parameter :: inf = 1.0D+30
  real ( kind = rk ) p
  real ( kind = rk ) pnonc
  real ( kind = rk ) q
  logical qhi
  logical qleft
  integer status
  real ( kind = rk ), parameter :: tent4 = 1.0D+04
  real ( kind = rk ), parameter :: tol = 1.0D-08
  integer which

  status = 0
  bound = 0.0D+00
!
!  Check the arguments.
!
  if ( which < 1 ) then
    bound = 1.0D+00
    status = -1
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'CDFFNC - Fatal error!'
    write ( *, '(a)' ) '  The input parameter WHICH is out of range.'
    write ( *, '(a)' ) '  Legal values are between 1 and 5.'
    return
  end if

  if ( 5 < which ) then
    bound = 5.0D+00
    status = -1
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'CDFFNC - Fatal error!'
    write ( *, '(a)' ) '  The input parameter WHICH is out of range.'
    write ( *, '(a)' ) '  Legal values are between 1 and 5.'
    return
  end if
!
!  Unless P is to be computed, make sure it is legal.
!
  if ( which /= 1 ) then
    if ( p < 0.0D+00 ) then
      status = -2
      bound = 0.0D+00
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'CDFFNC - Fatal error!'
      write ( *, '(a)' ) '  Input parameter P is out of range.'
      return
    else if ( 1.0D+00 < p ) then
      status = -2
      bound = 1.0D+00
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'CDFFNC - Fatal error!'
      write ( *, '(a)' ) '  Input parameter P is out of range.'
      return
    end if
  end if
!
!  Unless F is to be computed, make sure it is legal.
!
  if ( which /= 2 ) then
    if ( f < 0.0D+00 ) then
      bound = 0.0D+00
      status = -4
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'CDFFNC - Fatal error!'
      write ( *, '(a)' ) '  Input parameter F is out of range.'
      return
    end if
  end if
!
!  Unless DFN is to be computed, make sure it is legal.
!
  if ( which /= 3 ) then
    if ( dfn <= 0.0D+00 ) then
      bound = 0.0D+00
      status = -5
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'CDFFNC - Fatal error!'
      write ( *, '(a)' ) '  Input parameter DFN is out of range.'
      return
    end if
  end if
!
!  Unless DFD is to be computed, make sure it is legal.
!
  if ( which /= 4 ) then
    if ( dfd <= 0.0D+00 ) then
      bound = 0.0D+00
      status = -6
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'CDFFNC - Fatal error!'
      write ( *, '(a)' ) '  Input parameter DFD is out of range.'
      return
    end if
  end if
!
!  Unless PNONC is to be computed, make sure it is legal.
!
  if ( which /= 5 ) then
    if ( pnonc < 0.0D+00 ) then
      bound = 0.0D+00
      status = -7
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'CDFFNC - Fatal error!'
      write ( *, '(a)' ) '  Input parameter PNONC is out of range.'
      return
    end if
  end if
!
! Calculate P and Q.
!
  if ( which == 1 ) then

    call cumfnc ( f, dfn, dfd, pnonc, p, q )
    status = 0
!
!  Calculate F.
!
  else if ( which == 2 ) then

    call dstinv ( 0.0D+00, inf, 0.5D+00, 0.5D+00, 5.0D+00, atol, tol )

    status = 0
    f = 5.0D+00
    fx = 0.0D+00

    call dinvr ( status, f, fx, qleft, qhi )

    do while ( status == 1 )

      call cumfnc ( f, dfn, dfd, pnonc, cum, ccum )
      fx = cum - p
      call dinvr ( status, f, fx, qleft, qhi )

    end do

    if ( status == -1 ) then
      if ( qleft ) then
        status = 1
        bound = 0.0D+00
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'CDFFNC - Warning!'
        write ( *, '(a)' ) '  The desired answer appears to be lower than'
        write ( *, '(a,g14.6)' ) '  the search bound of ', bound
        return
      else
        status = 2
        bound = inf
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'CDFFNC - Warning!'
        write ( *, '(a)' ) '  The desired answer appears to be higher than'
        write ( *, '(a,g14.6)' ) '  the search bound of ', bound
        return
      end if
    end if
!
!  Calculate DFN.
!
  else if ( which == 3 ) then

    call dstinv ( 1.0D+00, inf, 0.5D+00, 0.5D+00, 5.0D+00, atol, tol )

    status = 0
    dfn = 5.0D+00
    fx = 0.0D+00

    call dinvr ( status, dfn, fx, qleft, qhi )

    do while ( status == 1 )

      call cumfnc ( f, dfn, dfd, pnonc, cum, ccum )
      fx = cum - p

      call dinvr ( status, dfn, fx, qleft, qhi )

    end do

    if ( status == -1 ) then
      if ( qleft ) then
        status = 1
        bound = 0.0D+00
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'CDFFNC - Warning!'
        write ( *, '(a)' ) '  The desired answer appears to be lower than'
        write ( *, '(a,g14.6)' ) '  the search bound of ', bound
      else
        status = 2
        bound = inf
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'CDFFNC - Warning!'
        write ( *, '(a)' ) '  The desired answer appears to be higher than'
        write ( *, '(a,g14.6)' ) '  the search bound of ', bound
      end if
    end if
!
!  Calculate DFD.
!
  else if ( which == 4 ) then

    call dstinv ( 1.0D+00, inf, 0.5D+00, 0.5D+00, 5.0D+00, atol, tol )

    status = 0
    dfd = 5.0D+00
    fx = 0.0D+00

    call dinvr ( status, dfd, fx, qleft, qhi )

    do while ( status == 1 )

      call cumfnc ( f, dfn, dfd, pnonc, cum, ccum )
      fx = cum - p
      call dinvr ( status, dfd, fx, qleft, qhi )

    end do

    if ( status == -1 ) then
      if ( qleft ) then
        status = 1
        bound = 0.0D+00
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'CDFFNC - Warning!'
        write ( *, '(a)' ) '  The desired answer appears to be lower than'
        write ( *, '(a,g14.6)' ) '  the search bound of ', bound
      else
        status = 2
        bound = inf
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'CDFFNC - Warning!'
        write ( *, '(a)' ) '  The desired answer appears to be higher than'
        write ( *, '(a,g14.6)' ) '  the search bound of ', bound
      end if
    end if
!
!  Calculate PNONC.
!
  else if ( which == 5 ) then

    call dstinv ( 0.0D+00, tent4, 0.5D+00, 0.5D+00, 5.0D+00, atol, tol )

    status = 0
    pnonc = 5.0D+00
    fx = 0.0D+00

    call dinvr ( status, pnonc, fx, qleft, qhi )

    do while ( status == 1 )

      call cumfnc ( f, dfn, dfd, pnonc, cum, ccum )
      fx = cum - p

      call dinvr ( status, pnonc, fx, qleft, qhi )

    end do

    if ( status == -1 ) then
      if ( qleft ) then
        status = 1
        bound = 0.0D+00
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'CDFFNC - Warning!'
        write ( *, '(a)' ) '  The desired answer appears to be lower than'
        write ( *, '(a,g14.6)' ) '  the search bound of ', bound
      else
        status = 2
        bound = tent4
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'CDFFNC - Warning!'
        write ( *, '(a)' ) '  The desired answer appears to be higher than'
        write ( *, '(a,g14.6)' ) '  the search bound of ', bound
      end if
    end if

  end if

  return
end
subroutine cdfgam ( which, p, q, x, shape, scale, status, bound )

!*****************************************************************************80
!
!! cdfgam() evaluates the CDF of the Gamma Distribution.
!
!  Discussion:
!
!    This routine calculates any one parameter of the Gamma distribution
!    given the others.
!
!    The cumulative distribution function P is calculated directly.
!
!    Computation of the other parameters involves a seach for a value that
!    produces the desired value of P.  The search relies on the
!    monotonicity of P with respect to the other parameters.
!
!    The gamma density is proportional to T^(SHAPE - 1) * EXP(- SCALE * T)
!
!  Licensing:
!
!    This code is distributed under the MIT license.
!
!  Modified:
!
!    15 February 2021
!
!  Author:
!
!    Barry Brown, James Lovato, Kathy Russell
!
!  Reference:
!
!    Armido DiDinato, Alfred Morris,
!    Algorithm 654:
!    Computation of the incomplete gamma function ratios and their inverse,
!    ACM Transactions on Mathematical Software,
!    Volume 12, 1986, pages 377-393.
!
!  Parameters:
!
!    Input, integer WHICH, indicates which argument is to be
!    calculated from the others.
!    1: Calculate P and Q from X, SHAPE and SCALE;
!    2: Calculate X from P, Q, SHAPE and SCALE;
!    3: Calculate SHAPE from P, Q, X and SCALE;
!    4: Calculate SCALE from P, Q, X and SHAPE.
!
!    Input/output, real ( kind = rk ) P, the integral from 0 to X of the
!    Gamma density.  If this is an input value, it should lie in the
!    range: [0,1].
!
!    Input/output, real ( kind = rk ) Q, equal to 1-P.  If Q is an input
!    value, it should lie in the range [0,1].  If Q is an output value,
!    it will lie in the range [0,1].
!
!    Input/output, real ( kind = rk ) X, the upper limit of integration of
!    the Gamma density.  If this is an input value, it should lie in the
!    range: [0, +infinity).  If it is an output value, it will lie in
!    the range: [0,1E300].
!
!    Input/output, real ( kind = rk ) SHAPE, the shape parameter of the
!    Gamma density.  If this is an input value, it should lie in the range:
!    (0, +infinity).  If it is an output value, it will be searched for
!    in the range: [1.0D-300,1.0D+300].
!
!    Input/output, real ( kind = rk ) SCALE, the scale parameter of the
!    Gamma density.  If this is an input value, it should lie in the range
!    (0, +infinity).  If it is an output value, it will be searched for
!    in the range: (1.0D-300,1.0D+300].
!
!    Output, integer STATUS, reports the status of the computation.
!     0, if the calculation completed correctly;
!    -I, if the input parameter number I is out of range;
!    +1, if the answer appears to be lower than lowest search bound;
!    +2, if the answer appears to be higher than greatest search bound;
!    +3, if P + Q /= 1;
!    +10, if the Gamma or inverse Gamma routine cannot compute the answer.
!    This usually happens only for X and SHAPE very large (more than 1.0D+10.
!
!    Output, real ( kind = rk ) BOUND, is only defined if STATUS is nonzero.
!    If STATUS is negative, then this is the value exceeded by parameter I.
!    if STATUS is 1 or 2, this is the search bound that was exceeded.
!
  implicit none

  integer, parameter :: rk = kind ( 1.0D+00 )

  real ( kind = rk ), parameter :: atol = 1.0D-10
  real ( kind = rk ) bound
  real ( kind = rk ) ccum
  real ( kind = rk ) cum
  real ( kind = rk ) fx
  integer ierr
  real ( kind = rk ), parameter :: inf=1.0D+300
  real ( kind = rk ) p
  real ( kind = rk ) porq
  real ( kind = rk ) q
  logical qhi
  logical qleft
  real ( kind = rk ) scale
  real ( kind = rk ) shape
  real ( kind = rk ), parameter :: tol = 1.0D-08
  integer status,which
  real ( kind = rk ) x
  real ( kind = rk ) xscale
  real ( kind = rk ) xx

  status = 0
  bound = 0.0D+00
!
!  Check the arguments.
!
  if ( which < 1 ) then
    bound = 1.0D+00
    status = -1
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'CDFGAM - Fatal error!'
    write ( *, '(a)' ) '  The input parameter WHICH is out of range.'
    write ( *, '(a)' ) '  Legal values are between 1 and 4.'
    return
  end if

  if ( 4 < which ) then
    bound = 4.0D+00
    status = -1
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'CDFGAM - Fatal error!'
    write ( *, '(a)' ) '  The input parameter WHICH is out of range.'
    write ( *, '(a)' ) '  Legal values are between 1 and 4.'
    return
  end if
!
!  Unless P is to be computed, make sure it is legal.
!
  if ( which /= 1 ) then
    if ( p < 0.0D+00 ) then
      status = -2
      bound = 0.0D+00
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'CDFGAM - Fatal error!'
      write ( *, '(a)' ) '  Input parameter P is out of range.'
      return
    else if ( 1.0D+00 < p ) then
      status = -2
      bound = 1.0D+00
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'CDFGAM - Fatal error!'
      write ( *, '(a)' ) '  Input parameter P is out of range.'
      return
    end if
  end if
!
!  Unless Q is to be computed, make sure it is legal.
!
  if ( which /= 1 ) then
    if ( q < 0.0D+00 ) then
      status = -3
      bound = 0.0D+00
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'CDFGAM - Fatal error!'
      write ( *, '(a)' ) '  Input parameter Q is out of range.'
      return
    else if ( 1.0D+00 < q ) then
      status = -3
      bound = 1.0
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'CDFGAM - Fatal error!'
      write ( *, '(a)' ) '  Input parameter Q is out of range.'
      return
    end if
  end if
!
!  Unless X is to be computed, make sure it is legal.
!
  if ( which /= 2 ) then
    if ( x < 0.0D+00 ) then
      bound = 0.0D+00
      status = -4
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'CDFGAM - Fatal error!'
      write ( *, '(a)' ) '  Input parameter X is out of range.'
      return
    end if
  end if
!
!  Unless SHAPE is to be computed, make sure it is legal.
!
  if ( which /= 3 ) then
    if ( shape <= 0.0D+00 ) then
      bound = 0.0D+00
      status = -5
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'CDFGAM - Fatal error!'
      write ( *, '(a)' ) '  Input parameter SHAPE is out of range.'
      return
    end if
  end if
!
!  Unless SCALE is to be computed, make sure it is legal.
!
  if ( which /= 4 ) then
    if ( scale <= 0.0D+00 ) then
      bound = 0.0D+00
      status = -6
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'CDFGAM - Fatal error!'
      write ( *, '(a)' ) '  Input parameter SCALE is out of range.'
      return
    end if
  end if
!
!  Check that P + Q = 1.
!
  if ( which /= 1 ) then
    if ( 3.0D+00 * epsilon ( p ) < abs ( ( p + q ) - 1.0D+0 ) ) then
      status = 3
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'CDFGAM - Fatal error!'
      write ( *, '(a)' ) '  P + Q /= 1.'
      return
    end if
  end if
!
!  Select the minimum of P or Q.
!
  if ( which /= 1 ) then
    porq = min ( p, q )
  end if
!
!  Calculate P and Q.
!
  if ( which == 1 ) then

    status = 0
    xscale = x * scale
    call cumgam ( xscale, shape, p, q )

    if ( 1.5D+00 < porq ) then
      status = 10
    end if
!
!  Calculate X.
!
  else if ( which == 2 ) then

    call gamma_inc_inv ( shape, xx, -1.0D+00, p, q, ierr )

    if ( ierr < 0.0D+00 ) then
      status = 10
      return
    end if

    x = xx / scale
    status = 0
!
!  Calculate SHAPE.
!
  else if ( which == 3 ) then

    xscale = x * scale

    call dstinv ( 0.0D+00, inf, 0.5D+00, 0.5D+00, 5.0D+00, atol, tol )

    status = 0
    shape = 5.0D+00
    fx = 0.0D+00

    call dinvr ( status, shape, fx, qleft, qhi )

    do while ( status == 1 )

      call cumgam ( xscale, shape, cum, ccum )

      if ( p <= q ) then
        fx = cum - p
      else
        fx = ccum - q
      end if

      if ( p <= q .and. 1.5D+00 < cum ) then
        status = 10
        return
      else if ( q < p .and. 1.5D+00 < ccum ) then
        status = 10
        return
      end if

      call dinvr ( status, shape, fx, qleft, qhi )

    end do

    if ( status == -1 ) then
      if ( qleft ) then
        status = 1
        bound = 0.0D+00
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'CDFGAM - Warning!'
        write ( *, '(a)' ) '  The desired answer appears to be lower than'
        write ( *, '(a,g14.6)' ) '  the search bound of ', bound
      else
        status = 2
        bound = inf
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'CDFGAM - Warning!'
        write ( *, '(a)' ) '  The desired answer appears to be higher than'
        write ( *, '(a,g14.6)' ) '  the search bound of ', bound
      end if
    end if
!
!  Calculate SCALE.
!
  else if ( which == 4 ) then

    call gamma_inc_inv ( shape, xx, -1.0D+00, p, q, ierr )

    if ( ierr < 0.0D+00 ) then
      status = 10
    else
      scale = xx / x
      status = 0
    end if

  end if

  return
end
subroutine cdfnbn ( which, p, q, f, s, pr, ompr, status, bound )

!*****************************************************************************80
!
!! cdfnbn() evaluates the CDF of the Negative Binomial distribution
!
!  Discussion:
!
!    This routine calculates any one parameter of the negative binomial
!    distribution given values for the others.
!
!    The cumulative negative binomial distribution returns the
!    probability that there will be F or fewer failures before the
!    S-th success in binomial trials each of which has probability of
!    success PR.
!
!    The individual term of the negative binomial is the probability of
!    F failures before S successes and is
!    Choose( F, S+F-1 ) * PR^(S) * (1-PR)^F
!
!    Computation of other parameters involve a seach for a value that
!    produces the desired value of P.  The search relies on the
!    monotonicity of P with respect to the other parameters.
!
!  Licensing:
!
!    This code is distributed under the MIT license.
!
!  Modified:
!
!    15 February 2021
!
!  Author:
!
!    Barry Brown, James Lovato, Kathy Russell
!
!  Reference:
!
!    Milton Abramowitz, Irene Stegun,
!    Handbook of Mathematical Functions
!    1966, Formula 26.5.26.
!
!  Parameters:
!
!    Input, integer WHICH, indicates which argument is to be
!    calculated from the others.
!    1: Calculate P and Q from F, S, PR and OMPR;
!    2: Calculate F from P, Q, S, PR and OMPR;
!    3: Calculate S from P, Q, F, PR and OMPR;
!    4: Calculate PR and OMPR from P, Q, F and S.
!
!    Input/output, real ( kind = rk ) P, the cumulation from 0 to F of
!    the negative binomial distribution.  If P is an input value, it
!    should lie in the range [0,1].
!
!    Input/output, real ( kind = rk ) Q, equal to 1-P.  If Q is an input
!    value, it should lie in the range [0,1].  If Q is an output value,
!    it will lie in the range [0,1].
!
!    Input/output, real ( kind = rk ) F, the upper limit of cumulation of
!    the binomial distribution.  There are F or fewer failures before
!    the S-th success.  If this is an input value, it may lie in the
!    range [0,+infinity), and if it is an output value, it will be searched
!    for in the range [0,1.0D+300].
!
!    Input/output, real ( kind = rk ) S, the number of successes.
!    If this is an input value, it should lie in the range: [0, +infinity).
!    If it is an output value, it will be searched for in the range:
!    [0, 1.0D+300].
!
!    Input/output, real ( kind = rk ) PR, the probability of success in each
!    binomial trial.  Whether an input or output value, it should lie in the
!    range [0,1].
!
!    Input/output, real ( kind = rk ) OMPR, the value of (1-PR).  Whether an
!    input or output value, it should lie in the range [0,1].
!
!    Output, integer STATUS, reports the status of the computation.
!     0, if the calculation completed correctly;
!    -I, if the input parameter number I is out of range;
!    +1, if the answer appears to be lower than lowest search bound;
!    +2, if the answer appears to be higher than greatest search bound;
!    +3, if P + Q /= 1;
!    +4, if PR + OMPR /= 1.
!
!    Output, real ( kind = rk ) BOUND, is only defined if STATUS is nonzero.
!    If STATUS is negative, then this is the value exceeded by parameter I.
!    if STATUS is 1 or 2, this is the search bound that was exceeded.
!
  implicit none

  integer, parameter :: rk = kind ( 1.0D+00 )

  real ( kind = rk ), parameter :: atol = 1.0D-10
  real ( kind = rk ) bound
  real ( kind = rk ) ccum
  real ( kind = rk ) cum
  real ( kind = rk ) f
  real ( kind = rk ) fx
  real ( kind = rk ), parameter :: inf = 1.0D+300
  real ( kind = rk ) ompr
  real ( kind = rk ) p
  real ( kind = rk ) pr
  real ( kind = rk ) q
  logical qhi
  logical qleft
  real ( kind = rk ) s
  integer status
  real ( kind = rk ), parameter :: tol = 1.0D-08
  integer which
  real ( kind = rk ) xhi
  real ( kind = rk ) xlo

  status = 0
  bound = 0.0D+00
!
!  Check the arguments.
!
  if ( which < 1 ) then
    bound = 1.0D+00
    status = -1
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'CDFNBN - Fatal error!'
    write ( *, '(a)' ) '  The input parameter WHICH is out of range.'
    write ( *, '(a)' ) '  Legal values are between 1 and 4.'
    return
  end if

  if ( 4 < which ) then
    bound = 4.0D+00
    status = -1
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'CDFNBN - Fatal error!'
    write ( *, '(a)' ) '  The input parameter WHICH is out of range.'
    write ( *, '(a)' ) '  Legal values are between 1 and 4.'
    return
  end if
!
!  Unless P is to be computed, make sure it is legal.
!
  if ( which /= 1 ) then
    if ( p < 0.0D+00 ) then
      status = -2
      bound = 0.0D+00
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'CDFNBN - Fatal error!'
      write ( *, '(a)' ) '  Input parameter P is out of range.'
      return
    else if ( 1.0D+00 < p ) then
      status = -2
      bound = 1.0D+00
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'CDFNBN - Fatal error!'
      write ( *, '(a)' ) '  Input parameter P is out of range.'
      return
    end if
  end if
!
!  Unless Q is to be computed, make sure it is legal.
!
  if ( which /= 1 ) then
    if ( q < 0.0D+00 ) then
      status = -3
      bound = 0.0D+00
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'CDFNBN - Fatal error!'
      write ( *, '(a)' ) '  Input parameter Q is out of range.'
      return
    else if ( 1.0D+00 < q ) then
      status = -3
      bound = 1.0
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'CDFNBN - Fatal error!'
      write ( *, '(a)' ) '  Input parameter Q is out of range.'
      return
    end if
  end if
!
!  Unless F is to be computed, make sure it is legal.
!
  if ( which /= 2 ) then
    if ( f < 0.0D+00 ) then
      bound = 0.0D+00
      status = -4
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'CDFNBN - Fatal error!'
      write ( *, '(a)' ) '  Input parameter F is out of range.'
      return
    end if
  end if
!
!  Unless S is to be computed, make sure it is legal.
!
  if ( which /= 3 ) then
    if ( s < 0.0D+00 ) then
      bound = 0.0D+00
      status = -5
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'CDFNBN - Fatal error!'
      write ( *, '(a)' ) '  Input parameter S is out of range.'
      return
    end if
  end if
!
!  Unless PR is to be computed, make sure it is legal.
!
  if ( which /= 4 ) then
    if ( pr < 0.0D+00 ) then
      bound = 0.0D+00
      status = -6
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'CDFNBN - Fatal error!'
      write ( *, '(a)' ) '  Input parameter PR is out of range.'
      return
    else if ( 1.0D+00 < pr ) then
      bound = 1.0D+00
      status = -6
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'CDFNBN - Fatal error!'
      write ( *, '(a)' ) '  Input parameter PR is out of range.'
      return
    end if
  end if
!
!  Unless OMPR is to be computed, make sure it is legal.
!
  if ( which /= 4 ) then
    if ( ompr < 0.0D+00 ) then
      bound = 0.0D+00
      status = -7
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'CDFNBN - Fatal error!'
      write ( *, '(a)' ) '  Input parameter OMPR is out of range.'
      return
    else if ( 1.0D+00 < ompr ) then
      bound = 1.0D+00
      status = -7
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'CDFNBN - Fatal error!'
      write ( *, '(a)' ) '  Input parameter OMPR is out of range.'
      return
    end if
  end if
!
!  Check that P + Q = 1.
!
  if ( which /= 1 ) then
    if ( 3.0D+00 * epsilon ( p ) < abs ( ( p + q ) - 1.0D+00 ) ) then
      status = 3
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'CDFNBN - Fatal error!'
      write ( *, '(a)' ) '  P + Q /= 1.'
      return
    end if
  end if
!
!  Check that PR + OMPR = 1.
!
  if ( which /= 4 ) then
    if ( 3.0D+00 * epsilon ( pr ) < abs ( ( pr + ompr ) - 1.0D+00 ) ) then
      status = 4
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'CDFNBN - Fatal error!'
      write ( *, '(a)' ) '  PR + OMPR /= 1.'
      return
    end if
  end if
!
!  Calculate P and Q.
!
  if ( which == 1 ) then

    call cumnbn ( f, s, pr, ompr, p, q )
    status = 0
!
!  Calculate F.
!
  else if ( which == 2 ) then

    call dstinv ( 0.0D+00, inf, 0.5D+00, 0.5D+00, 5.0D+00, atol, tol )

    status = 0
    f = 5.0D+00
    fx = 0.0D+00

    call dinvr ( status, f, fx, qleft, qhi )

    do while ( status == 1 )

      call cumnbn ( f, s, pr, ompr, cum, ccum )

      if ( p <= q ) then
        fx = cum - p
      else
        fx = ccum - q
      end if

      call dinvr ( status, f, fx, qleft, qhi )

    end do

    if ( status == -1 ) then
      if ( qleft ) then
        status = 1
        bound = 0.0D+00
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'CDFNBN - Warning!'
        write ( *, '(a)' ) '  The desired answer appears to be lower than'
        write ( *, '(a,g14.6)' ) '  the search bound of ', bound
      else
        status = 2
        bound = inf
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'CDFNBN - Warning!'
        write ( *, '(a)' ) '  The desired answer appears to be higher than'
        write ( *, '(a,g14.6)' ) '  the search bound of ', bound
      end if
    end if
!
!  Calculate S.
!
  else if ( which == 3 ) then

    call dstinv ( 0.0D+00, inf, 0.5D+00, 0.5D+00, 5.0D+00, atol, tol )

    status = 0
    s = 5.0D+00
    fx = 0.0D+00

    call dinvr ( status, s, fx, qleft, qhi )

    do while ( status == 1 )

      call cumnbn ( f, s, pr, ompr, cum, ccum )

      if ( p <= q ) then
        fx = cum - p
      else
        fx = ccum - q
      end if

      call dinvr ( status, s, fx, qleft, qhi )

    end do

    if ( status == -1 ) then
      if ( qleft ) then
        status = 1
        bound = 0.0D+00
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'CDFNBN - Warning!'
        write ( *, '(a)' ) '  The desired answer appears to be lower than'
        write ( *, '(a,g14.6)' ) '  the search bound of ', bound
      else
        status = 2
        bound = inf
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'CDFNBn - Warning!'
        write ( *, '(a)' ) '  The desired answer appears to be higher than'
        write ( *, '(a,g14.6)' ) '  the search bound of ', bound
      end if
    end if
!
!  Calculate PR and OMPR.
!
  else if ( which == 4 ) then

    call dstzr ( 0.0D+00, 1.0D+00, atol, tol )

    if ( p <= q ) then

      status = 0
      call dzror ( status, pr, fx, xlo, xhi, qleft, qhi )
      ompr = 1.0D+00 - pr

      do while ( status == 1 )

        call cumnbn ( f, s, pr, ompr, cum, ccum )
        fx = cum - p
        call dzror ( status, pr, fx, xlo, xhi, qleft, qhi )
        ompr = 1.0D+00 - pr

      end do

    else

      status = 0
      call dzror ( status, ompr, fx, xlo, xhi, qleft, qhi )
      pr = 1.0D+00 - ompr

      do while ( status == 1 )

        call cumnbn ( f, s, pr, ompr, cum, ccum )
        fx = ccum - q
        call dzror ( status, ompr, fx, xlo, xhi, qleft, qhi )
        pr = 1.0D+00 - ompr

      end do

    end if

    if ( status == -1 ) then

      if ( qleft ) then
        status = 1
        bound = 0.0D+00
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'CDFNBN - Warning!'
        write ( *, '(a)' ) '  The desired answer appears to be lower than'
        write ( *, '(a,g14.6)' ) '  the search bound of ', bound
      else
        status = 2
        bound = 1.0D+00
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'CDFNBN - Warning!'
        write ( *, '(a)' ) '  The desired answer appears to be higher than'
        write ( *, '(a,g14.6)' ) '  the search bound of ', bound
      end if

    end if

  end if

  return
end
subroutine cdfnor ( which, p, q, x, mean, sd, status, bound )

!*****************************************************************************80
!
!! cdfnor() evaluates the CDF of the Normal distribution.
!
!  Discussion:
!
!    A slightly modified version of ANORM from SPECFUN
!    is used to calculate the cumulative standard normal distribution.
!
!    The rational functions from pages 90-95 of Kennedy and Gentle
!    are used as starting values to a Newton iteration which
!    compute the inverse standard normal.  Therefore no searches are
!    necessary for any parameter.
!
!    For X < -15, the asymptotic expansion for the normal is used  as
!    the starting value in finding the inverse standard normal.
!
!    The normal density is proportional to
!    exp ( - 0.5 * (( X - MEAN)/SD)^2)
!
!  Licensing:
!
!    This code is distributed under the MIT license.
!
!  Modified:
!
!    15 February 2021
!
!  Author:
!
!    Barry Brown, James Lovato, Kathy Russell
!
!  Reference:
!
!    Milton Abramowitz, Irene Stegun,
!    Handbook of Mathematical Functions
!    1966, Formula 26.2.12.
!
!    William Cody,
!    Algorithm 715:
!    SPECFUN - A Portable Fortran Package of
!    Special Function Routines and Test Drivers,
!    ACM Transactions on Mathematical Software,
!    Volume 19, Number 1, pages 22-32, 1993.
!
!    William Kennedy, James Gentle,
!    Statistical Computing,
!    Marcel Dekker, NY, 1980,
!    QA276.4 K46
!
!  Parameters:
!
!    Input, integer WHICH, indicates which argument is to be
!    calculated from the others.
!    1: Calculate P and Q from X, MEAN and SD;
!    2: Calculate X from P, Q, MEAN and SD;
!    3: Calculate MEAN from P, Q, X and SD;
!    4: Calculate SD from P, Q, X and MEAN.
!
!    Input/output, real ( kind = rk ) P, the integral from -infinity to X
!    of the Normal density.  If this is an input or output value, it will
!    lie in the range [0,1].
!
!    Input/output, real ( kind = rk ) Q, equal to 1-P.  If Q is an input
!    value, it should lie in the range [0,1].  If Q is an output value,
!    it will lie in the range [0,1].
!
!    Input/output, real ( kind = rk ) X, the upper limit of integration of
!    the Normal density.
!
!    Input/output, real ( kind = rk ) MEAN, the mean of the Normal density.
!
!    Input/output, real ( kind = rk ) SD, the standard deviation of the
!    Normal density.  If this is an input value, it should lie in the
!    range (0,+infinity).
!
!    Output, integer STATUS, the status of the calculation.
!    0, if calculation completed correctly;
!    -I, if input parameter number I is out of range;
!    1, if answer appears to be lower than lowest search bound;
!    2, if answer appears to be higher than greatest search bound;
!    3, if P + Q /= 1.
!
!    Output, real ( kind = rk ) BOUND, is only defined if STATUS is nonzero.
!    If STATUS is negative, then this is the value exceeded by parameter I.
!    if STATUS is 1 or 2, this is the search bound that was exceeded.
!
  implicit none

  integer, parameter :: rk = kind ( 1.0D+00 )

  real ( kind = rk ) bound
  real ( kind = rk ) dinvnr
  real ( kind = rk ) mean
  real ( kind = rk ) p
  real ( kind = rk ) q
  real ( kind = rk ) sd
  integer status
  integer which
  real ( kind = rk ) x
  real ( kind = rk ) z

  status = 0
  bound = 0.0D+00
!
!  Check the arguments.
!
  status = 0

  if ( which < 1 ) then
    status = -1
    bound = 1.0D+00
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'CDFNOR - Fatal error!'
    write ( *, '(a)' ) '  The input parameter WHICH is out of range.'
    write ( *, '(a)' ) '  Legal values are between 1 and 4.'
    return
  else if ( 4 < which ) then
    status = -1
    bound = 4.0D+00
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'CDFNOR - Fatal error!'
    write ( *, '(a)' ) '  The input parameter WHICH is out of range.'
    write ( *, '(a)' ) '  Legal values are between 1 and 4.'
    return
  end if
!
!  Unless P is to be computed, make sure it is legal.
!
  if ( which /= 1 ) then
    if ( p < 0.0D+00 ) then
      status = -2
      bound = 0.0D+00
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'CDFNOR - Fatal error!'
      write ( *, '(a)' ) '  Input parameter P is out of range.'
      return
    else if ( 1.0D+00 < p ) then
      status = -2
      bound = 1.0D+00
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'CDFNOR - Fatal error!'
      write ( *, '(a)' ) '  Input parameter P is out of range.'
      return
    end if
  end if
!
!  Unless Q is to be computed, make sure it is legal.
!
  if ( which /= 1 ) then
    if ( q < 0.0D+00 ) then
      status = -3
      bound = 0.0D+00
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'CDFNOR - Fatal error!'
      write ( *, '(a)' ) '  Input parameter Q is out of range.'
      return
    else if ( 1.0D+00 < q ) then
      status = -3
      bound = 1.0D+00
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'CDFNOR - Fatal error!'
      write ( *, '(a)' ) '  Input parameter Q is out of range.'
      return
    end if
  end if
!
!  Check that P + Q = 1.
!
  if ( which /= 1 ) then
    if ( 3.0D+00 * epsilon ( p ) < abs ( ( p + q ) - 1.0D+00 ) ) then
      status = 3
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'CDFNOR - Fatal error!'
      write ( *, '(a)' ) '  P + Q /= 1.'
      return
    end if
  end if

  if ( which /= 4 ) then
    if ( sd <= 0.0D+00 ) then
      bound = 0.0D+00
      status = -6
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'CDFNOR - Fatal error!'
      write ( *, '(a)' ) '  Input parameter SD is out of range.'
      return
    end if
  end if
!
!  Calculate P and Q.
!
  if ( which == 1 ) then

    z = ( x - mean ) / sd
    call cumnor ( z, p, q )
!
!  Calculate X.
!
  else if ( which == 2 ) then

    z = dinvnr ( p, q )
    x = sd * z + mean
!
!  Calculate MEAN.
!
  else if ( which == 3 ) then

    z = dinvnr ( p, q )
    mean = x - sd * z
!
!  Calculate SD.
!
  else if ( which == 4 ) then

    z = dinvnr ( p, q )
    sd = ( x - mean ) / z

  end if

  return
end
subroutine cdfpoi ( which, p, q, s, xlam, status, bound )

!*****************************************************************************80
!
!! cdfpoi() evaluates the CDF of the Poisson distribution.
!
!  Discussion:
!
!    This routine calculates any one parameter of the Poisson distribution
!    given the others.
!
!    The value P of the cumulative distribution function is calculated
!    directly.
!
!    Computation of other parameters involve a seach for a value that
!    produces the desired value of P.  The search relies on the
!    monotonicity of P with respect to the other parameters.
!
!  Licensing:
!
!    This code is distributed under the MIT license.
!
!  Modified:
!
!    15 February 2021
!
!  Author:
!
!    Barry Brown, James Lovato, Kathy Russell
!
!  Reference:
!
!    Milton Abramowitz, Irene Stegun,
!    Handbook of Mathematical Functions
!    1966, Formula 26.4.21.
!
!  Parameters:
!
!    Input, integer WHICH, indicates which argument is to be
!    calculated from the others.
!    1: Calculate P and Q from S and XLAM;
!    2: Calculate A from P, Q and XLAM;
!    3: Calculate XLAM from P, Q and S.
!
!    Input/output, real ( kind = rk ) P, the cumulation from 0 to S of the
!    Poisson density.  Whether this is an input or output value, it will
!    lie in the range [0,1].
!
!    Input/output, real ( kind = rk ) Q, equal to 1-P.  If Q is an input
!    value, it should lie in the range [0,1].  If Q is an output value,
!    it will lie in the range [0,1].
!
!    Input/output, real ( kind = rk ) S, the upper limit of cumulation of
!    the Poisson CDF.  If this is an input value, it should lie in
!    the range: [0, +infinity).  If it is an output value, it will be
!    searched for in the range: [0,1.0D+300].
!
!    Input/output, real ( kind = rk ) XLAM, the mean of the Poisson
!    distribution.  If this is an input value, it should lie in the range
!    [0, +infinity).  If it is an output value, it will be searched for
!    in the range: [0,1E300].
!
!    Output, integer STATUS, reports the status of the computation.
!     0, if the calculation completed correctly;
!    -I, if the input parameter number I is out of range;
!    +1, if the answer appears to be lower than lowest search bound;
!    +2, if the answer appears to be higher than greatest search bound;
!    +3, if P + Q /= 1.
!
!    Output, real ( kind = rk ) BOUND, is only defined if STATUS is nonzero.
!    If STATUS is negative, then this is the value exceeded by parameter I.
!    if STATUS is 1 or 2, this is the search bound that was exceeded.
!
  implicit none

  integer, parameter :: rk = kind ( 1.0D+00 )

  real ( kind = rk ), parameter :: atol = 1.0D-10
  real ( kind = rk ) bound
  real ( kind = rk ) ccum
  real ( kind = rk ) cum
  real ( kind = rk ) fx
  real ( kind = rk ), parameter :: inf = 1.0D+300
  real ( kind = rk ) p
  real ( kind = rk ) q
  logical qhi
  logical qleft
  real ( kind = rk ) s
  integer status
  real ( kind = rk ), parameter :: tol = 1.0D-08
  integer which
  real ( kind = rk ) xlam

  status = 0
  bound = 0.0D+00
!
!  Check the arguments.
!
  if ( which < 1 ) then
    bound = 1.0D+00
    status = -1
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'CDFPOI - Fatal error!'
    write ( *, '(a)' ) '  The input parameter WHICH is out of range.'
    write ( *, '(a)' ) '  Legal values are between 1 and 3.'
    return
  end if

  if ( 3 < which ) then
    bound = 3.0D+00
    status = -1
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'CDFPOI - Fatal error!'
    write ( *, '(a)' ) '  The input parameter WHICH is out of range.'
    write ( *, '(a)' ) '  Legal values are between 1 and 3.'
    return
  end if
!
!  Unless P is to be computed, make sure it is legal.
!
  if ( which /= 1 ) then
    if ( p < 0.0D+00 ) then
      status = -2
      bound = 0.0D+00
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'CDFPOI - Fatal error!'
      write ( *, '(a)' ) '  Input parameter P is out of range.'
      return
    else if ( 1.0D+00 < p ) then
      status = -2
      bound = 1.0D+00
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'CDFPOI - Fatal error!'
      write ( *, '(a)' ) '  Input parameter P is out of range.'
      return
    end if
  end if
!
!  Unless Q is to be computed, make sure it is legal.
!
  if ( which /= 1 ) then
    if ( q < 0.0D+00 ) then
      status = -3
      bound = 0.0D+00
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'CDFPOI - Fatal error!'
      write ( *, '(a)' ) '  Input parameter Q is out of range.'
      return
    else if ( 1.0D+00 < q ) then
      status = -3
      bound = 1.0D+00
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'CDFPOI - Fatal error!'
      write ( *, '(a)' ) '  Input parameter Q is out of range.'
      return
    end if
  end if
!
!  Unless S is to be computed, make sure it is legal.
!
  if ( which /= 2 ) then
    if ( s < 0.0D+00 ) then
      bound = 0.0D+00
      status = -4
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'CDFPOI - Fatal error!'
      write ( *, '(a)' ) '  Input parameter S is out of range.'
      return
    end if
  end if
!
!  Unless XLAM is to be computed, make sure it is legal.
!
  if ( which /= 3 ) then
    if ( xlam < 0.0D+00 ) then
      bound = 0.0D+00
      status = -5
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'CDFPOI - Fatal error!'
      write ( *, '(a)' ) '  Input parameter XLAM is out of range.'
      return
    end if
  end if
!
!  Check that P + Q = 1.
!
  if ( which /= 1 ) then
    if ( 3.0D+00 * epsilon ( p ) < abs ( ( p + q ) - 1.0D+00 ) ) then
      status = 3
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'CDFPOI - Fatal error!'
      write ( *, '(a)' ) '  P + Q /= 1.'
      return
    end if
  end if
!
!  Calculate P and Q.
!
  if ( which == 1 ) then

    call cumpoi ( s, xlam, p, q )
    status = 0
!
!  Calculate S.
!
  else if ( which == 2 ) then

    call dstinv ( 0.0D+00, inf, 0.5D+00, 0.5D+00, 5.0D+00, atol, tol )

    status = 0
    s = 5.0D+00
    fx = 0.0D+00

    call dinvr ( status, s, fx, qleft, qhi )

    do while ( status == 1 )

      call cumpoi ( s, xlam, cum, ccum )

      if ( p <= q ) then
        fx = cum - p
      else
        fx = ccum - q
      end if

      call dinvr ( status, s, fx, qleft, qhi )

    end do

    if ( status == -1 ) then
      if ( qleft ) then
        status = 1
        bound = 0.0D+00
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'CDFPOI - Warning!'
        write ( *, '(a)' ) '  The desired answer appears to be lower than'
        write ( *, '(a,g14.6)' ) '  the search bound of ', bound
      else
        status = 2
        bound = inf
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'CDFPOI - Warning!'
        write ( *, '(a)' ) '  The desired answer appears to be higher than'
        write ( *, '(a,g14.6)' ) '  the search bound of ', bound
      end if
    end if
!
!  Calculate XLAM.
!
  else if ( which == 3 ) then

    call dstinv ( 0.0D+00, inf, 0.5D+00, 0.5D+00, 5.0D+00, atol, tol )

    status = 0
    xlam = 5.0D+00
    fx = 0.0D+00

    call dinvr ( status, xlam, fx, qleft, qhi )

    do while ( status == 1 )

      call cumpoi ( s, xlam, cum, ccum )

      if ( p <= q ) then
        fx = cum - p
      else
        fx = ccum - q
      end if

      call dinvr ( status, xlam, fx, qleft, qhi )

    end do

    if ( status == -1 ) then
      if ( qleft ) then
        status = 1
        bound = 0.0D+00
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'CDFPOI - Warning!'
        write ( *, '(a)' ) '  The desired answer appears to be lower than'
        write ( *, '(a,g14.6)' ) '  the search bound of ', bound
      else
        status = 2
        bound = inf
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'CDFPOI - Warning!'
        write ( *, '(a)' ) '  The desired answer appears to be higher than'
        write ( *, '(a,g14.6)' ) '  the search bound of ', bound
      end if
    end if

  end if

  return
end
subroutine cdft ( which, p, q, t, df, status, bound )

!*****************************************************************************80
!
!! cdft() evaluates the CDF of the T distribution.
!
!  Discussion:
!
!    This routine calculates any one parameter of the T distribution
!    given the others.
!
!    The value P of the cumulative distribution function is calculated
!    directly.
!
!    Computation of other parameters involve a seach for a value that
!    produces the desired value of P.   The search relies on the
!    monotonicity of P with respect to the other parameters.
!
!    The original version of this routine allowed the search interval
!    to extend from -1.0D+300 to +1.0D+300, which is fine until you
!    try to evaluate a function at such a point!
!
!  Licensing:
!
!    This code is distributed under the MIT license.
!
!  Modified:
!
!    15 February 2021
!
!  Author:
!
!    Barry Brown, James Lovato, Kathy Russell
!
!  Reference:
!
!    Milton Abramowitz, Irene Stegun,
!    Handbook of Mathematical Functions
!    1966, Formula 26.5.27.
!
!  Parameters:
!
!    Input, integer WHICH, indicates which argument is to be
!    calculated from the others.
!    1 : Calculate P and Q from T and DF;
!    2 : Calculate T from P, Q and DF;
!    3 : Calculate DF from P, Q and T.
!
!    Input/output, real ( kind = rk ) P, the integral from -infinity to T of
!    the T-density.  Whether an input or output value, this will lie in the
!    range [0,1].
!
!    Input/output, real ( kind = rk ) Q, equal to 1-P.  If Q is an input
!    value, it should lie in the range [0,1].  If Q is an output value,
!    it will lie in the range [0,1].
!
!    Input/output, real ( kind = rk ) T, the upper limit of integration of
!    the T-density.  If this is an input value, it may have any value.
!    It it is an output value, it will be searched for in the range
!    [ -1.0D+30, 1.0D+30 ].
!
!    Input/output, real ( kind = rk ) DF, the number of degrees of freedom
!    of the T distribution.  If this is an input value, it should lie
!    in the range: (0 , +infinity).  If it is an output value, it will be
!    searched for in the range: [1, 1.0D+10].
!
!    Output, integer STATUS, reports the status of the computation.
!     0, if the calculation completed correctly;
!    -I, if the input parameter number I is out of range;
!    +1, if the answer appears to be lower than lowest search bound;
!    +2, if the answer appears to be higher than greatest search bound;
!    +3, if P + Q /= 1.
!
!    Output, real ( kind = rk ) BOUND, is only defined if STATUS is nonzero.
!    If STATUS is negative, then this is the value exceeded by parameter I.
!    if STATUS is 1 or 2, this is the search bound that was exceeded.
!
  implicit none

  integer, parameter :: rk = kind ( 1.0D+00 )

  real ( kind = rk ), parameter :: atol = 1.0D-10
  real ( kind = rk ) bound
  real ( kind = rk ) ccum
  real ( kind = rk ) cum
  real ( kind = rk ) df
  real ( kind = rk ) dt1
  real ( kind = rk ) fx
  real ( kind = rk ), parameter :: inf = 1.0D+30
  real ( kind = rk ), parameter :: maxdf = 1.0D+10
  real ( kind = rk ) p
  real ( kind = rk ) q
  logical qhi
  logical qleft
  integer status
  real ( kind = rk ) t
  real ( kind = rk ), parameter :: tol = 1.0D-08
  integer which

  status = 0
  bound = 0.0D+00
!
!  Check the arguments.
!
  if ( which < 1 ) then
    bound = 1.0D+00
    status = -1
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'CDFT - Fatal error!'
    write ( *, '(a)' ) '  The input parameter WHICH is out of range.'
    write ( *, '(a)' ) '  Legal values are between 1 and 3.'
    return
  end if

  if ( 3 < which ) then
    bound = 3.0D+00
    status = -1
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'CDFT - Fatal error!'
    write ( *, '(a)' ) '  The input parameter WHICH is out of range.'
    write ( *, '(a)' ) '  Legal values are between 1 and 3.'
    return
  end if
!
!  Unless P is to be computed, make sure it is legal.
!
  if ( which /= 1 ) then
    if ( p < 0.0D+00 ) then
      status = -2
      bound = 0.0D+00
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'CDFT - Fatal error!'
      write ( *, '(a)' ) '  Input parameter P is out of range.'
      return
    else if ( 1.0D+00 < p ) then
      status = -2
      bound = 1.0D+00
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'CDFT - Fatal error!'
      write ( *, '(a)' ) '  Input parameter P is out of range.'
      return
    end if
  end if
!
!  Unless Q is to be computed, make sure it is legal.
!
  if ( which /= 1 ) then
    if ( q < 0.0D+00 ) then
      status = -3
      bound = 0.0D+00
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'CDFT - Fatal error!'
      write ( *, '(a)' ) '  Input parameter Q is out of range.'
      return
    else if ( 1.0D+00 < q ) then
      status = -3
      bound = 1.0D+00
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'CDFT - Fatal error!'
      write ( *, '(a)' ) '  Input parameter Q is out of range.'
      return
    end if
  end if
!
!  Unless DF is to be computed, make sure it is legal.
!
  if ( which /= 3 ) then
    if ( df <= 0.0D+00 ) then
      bound = 0.0D+00
      status = -5
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'CDFT - Fatal error!'
      write ( *, '(a)' ) '  Input parameter DF is out of range.'
      return
    end if
  end if
!
!  Check that P + Q = 1.
!
  if ( which /= 1 ) then
    if ( 3.0D+00 * epsilon ( 1.0D+00 ) &
      < abs ( ( p + q ) - 1.0D+00 ) ) then
      status = 3
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'CDFT - Fatal error!'
      write ( *, '(a)' ) '  P + Q /= 1.'
      return
    end if
  end if
!
!  Calculate P and Q.
!
  if ( which == 1 ) then

    call cumt ( t, df, p, q )
    status = 0
!
!  Calculate T.
!
  else if ( which == 2 ) then

    call dstinv ( -inf, inf, 0.5D+00, 0.5D+00, 5.0D+00, atol, tol )

    status = 0
    t = dt1 ( p, q, df )
    fx = 0.0D+00

    call dinvr ( status, t, fx, qleft, qhi )

    do while ( status == 1 )

      call cumt ( t, df, cum, ccum )

      if ( p <= q ) then
        fx = cum - p
      else
        fx = ccum - q
      end if

      call dinvr ( status, t, fx, qleft, qhi )

    end do

    if ( status == -1 ) then
      if ( qleft )then
        status = 1
        bound = -inf
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'CDFT - Warning!'
        write ( *, '(a)' ) '  The desired answer appears to be lower than'
        write ( *, '(a,g14.6)' ) '  the search bound of ', bound
      else
        status = 2
        bound = inf
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'CDFT - Warning!'
        write ( *, '(a)' ) '  The desired answer appears to be higher than'
        write ( *, '(a,g14.6)' ) '  the search bound of ', bound
      end if
    end if
!
!  Calculate DF.
!
  else if ( which == 3 ) then

    call dstinv ( 1.0D+00, maxdf, 0.5D+00, 0.5D+00, 5.0D+00, atol, tol )

    status = 0
    df = 5.0D+00
    fx = 0.0D+00

    call dinvr ( status, df, fx, qleft, qhi )

    do while ( status == 1 )

      call cumt ( t, df, cum, ccum )

      if ( p <= q ) then
        fx = cum - p
      else
        fx = ccum - q
      end if

      call dinvr ( status, df, fx, qleft, qhi )

    end do

    if ( status == -1 ) then
      if ( qleft ) then
        status = 1
        bound = 0.0D+00
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'CDFT - Warning!'
        write ( *, '(a)' ) '  The desired answer appears to be lower than'
        write ( *, '(a,g14.6)' ) '  the search bound of ', bound
      else
        status = 2
        bound = maxdf
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'CDFT - Warning!'
        write ( *, '(a)' ) '  The desired answer appears to be higher than'
        write ( *, '(a,g14.6)' ) '  the search bound of ', bound
      end if
    end if

  end if

  return
end
subroutine chi_noncentral_cdf_values ( n_data, x, lambda, df, cdf )

!*****************************************************************************80
!
!! chi_noncentral_cdf_values() returns values of the noncentral chi CDF.
!
!  Discussion:
!
!    The CDF of the noncentral chi square distribution can be evaluated
!    within Mathematica by commands such as:
!
!      Needs["Statistics`ContinuousDistributions`"]
!      CDF [ NoncentralChiSquareDistribution [ DF, LAMBDA ], X ]
!
!  Licensing:
!
!    This code is distributed under the MIT license.
!
!  Modified:
!
!    12 June 2004
!
!  Author:
!
!    John Burkardt
!
!  Reference:
!
!    Stephen Wolfram,
!    The Mathematica Book,
!    Fourth Edition,
!    Wolfram Media / Cambridge University Press, 1999.
!
!  Parameters:
!
!    Input/output, integer N_DATA.  The user sets N_DATA to 0
!    before the first call.  On each call, the routine increments N_DATA by 1,
!    and returns the corresponding data; when there is no more data, the
!    output value of N_DATA will be 0 again.
!
!    Output, real ( kind = rk ) X, the argument of the function.
!
!    Output, real ( kind = rk ) LAMBDA, the noncentrality parameter.
!
!    Output, integer DF, the number of degrees of freedom.
!
!    Output, real ( kind = rk ) CDF, the noncentral chi CDF.
!
  implicit none

  integer, parameter :: rk = kind ( 1.0D+00 )

  integer, parameter :: n_max = 27

  real ( kind = rk ) cdf
  real ( kind = rk ), save, dimension ( n_max ) :: cdf_vec = (/ &
    0.839944D+00, 0.695906D+00, 0.535088D+00, &
    0.764784D+00, 0.620644D+00, 0.469167D+00, &
    0.307088D+00, 0.220382D+00, 0.150025D+00, &
    0.307116D-02, 0.176398D-02, 0.981679D-03, &
    0.165175D-01, 0.202342D-03, 0.498448D-06, &
    0.151325D-01, 0.209041D-02, 0.246502D-03, &
    0.263684D-01, 0.185798D-01, 0.130574D-01, &
    0.583804D-01, 0.424978D-01, 0.308214D-01, &
    0.105788D+00, 0.794084D-01, 0.593201D-01 /)
  integer df
  integer, save, dimension ( n_max ) :: df_vec = (/ &
      1,   2,   3, &
      1,   2,   3, &
      1,   2,   3, &
      1,   2,   3, &
     60,  80, 100, &
      1,   2,   3, &
     10,  10,  10, &
     10,  10,  10, &
     10,  10,  10 /)
  real ( kind = rk ) lambda
  real ( kind = rk ), save, dimension ( n_max ) :: lambda_vec = (/ &
     0.5D+00,  0.5D+00,  0.5D+00, &
     1.0D+00,  1.0D+00,  1.0D+00, &
     5.0D+00,  5.0D+00,  5.0D+00, &
    20.0D+00, 20.0D+00, 20.0D+00, &
    30.0D+00, 30.0D+00, 30.0D+00, &
     5.0D+00,  5.0D+00,  5.0D+00, &
     2.0D+00,  3.0D+00,  4.0D+00, &
     2.0D+00,  3.0D+00,  4.0D+00, &
     2.0D+00,  3.0D+00,  4.0D+00 /)
  integer n_data
  real ( kind = rk ) x
  real ( kind = rk ), save, dimension ( n_max ) :: x_vec = (/ &
     3.000D+00,  3.000D+00,  3.000D+00, &
     3.000D+00,  3.000D+00,  3.000D+00, &
     3.000D+00,  3.000D+00,  3.000D+00, &
     3.000D+00,  3.000D+00,  3.000D+00, &
    60.000D+00, 60.000D+00, 60.000D+00, &
     0.050D+00,  0.050D+00,  0.050D+00, &
     4.000D+00,  4.000D+00,  4.000D+00, &
     5.000D+00,  5.000D+00,  5.000D+00, &
     6.000D+00,  6.000D+00,  6.000D+00 /)

  if ( n_data < 0 ) then
    n_data = 0
  end if

  n_data = n_data + 1

  if ( n_max < n_data ) then
    n_data = 0
    x = 0.0D+00
    lambda = 0.0D+00
    df = 0
    cdf = 0.0D+00
  else
    x = x_vec(n_data)
    lambda = lambda_vec(n_data)
    df = df_vec(n_data)
    cdf = cdf_vec(n_data)
  end if

  return
end
subroutine chi_square_cdf_values ( n_data, a, x, fx )

!*****************************************************************************80
!
!! chi_square_cdf_values() returns some values of the Chi-Square CDF.
!
!  Discussion:
!
!    The value of CHI_CDF ( DF, X ) can be evaluated in Mathematica by
!    commands like:
!
!      Needs["Statistics`ContinuousDistributions`"]
!      CDF[ChiSquareDistribution[DF], X ]
!
!  Licensing:
!
!    This code is distributed under the MIT license.
!
!  Modified:
!
!    11 June 2004
!
!  Author:
!
!    John Burkardt
!
!  Reference:
!
!    Milton Abramowitz, Irene Stegun,
!    Handbook of Mathematical Functions,
!    US Department of Commerce, 1964.
!
!    Stephen Wolfram,
!    The Mathematica Book,
!    Fourth Edition,
!    Wolfram Media / Cambridge University Press, 1999.
!
!  Parameters:
!
!    Input/output, integer N_DATA.  The user sets N_DATA to 0
!    before the first call.  On each call, the routine increments N_DATA by 1,
!    and returns the corresponding data; when there is no more data, the
!    output value of N_DATA will be 0 again.
!
!    Output, integer A, real ( kind = rk ) X, the arguments of
!    the function.
!
!    Output, real ( kind = rk ) FX, the value of the function.
!
  implicit none

  integer, parameter :: rk = kind ( 1.0D+00 )

  integer, parameter :: n_max = 21

  integer a
  integer, save, dimension ( n_max ) :: a_vec = (/ &
     1,  2,  1,  2, &
     1,  2,  3,  4, &
     1,  2,  3,  4, &
     5,  3,  3,  3, &
     3,  3, 10, 10, &
    10 /)
  real ( kind = rk ) fx
  real ( kind = rk ), save, dimension ( n_max ) :: fx_vec = (/ &
    0.0796557D+00, 0.00498752D+00, 0.112463D+00,    0.00995017D+00, &
    0.472911D+00,  0.181269D+00,   0.0597575D+00,   0.0175231D+00, &
    0.682689D+00,  0.393469D+00,   0.198748D+00,    0.090204D+00, &
    0.0374342D+00, 0.427593D+00,   0.608375D+00,    0.738536D+00, &
    0.828203D+00,  0.88839D+00,    0.000172116D+00, 0.00365985D+00, &
    0.0185759D+00 /)
  integer n_data
  real ( kind = rk ) x
  real ( kind = rk ), save, dimension ( n_max ) :: x_vec = (/ &
    0.01D+00, 0.01D+00, 0.02D+00, 0.02D+00, &
    0.40D+00, 0.40D+00, 0.40D+00, 0.40D+00, &
    1.00D+00, 1.00D+00, 1.00D+00, 1.00D+00, &
    1.00D+00, 2.00D+00, 3.00D+00, 4.00D+00, &
    5.00D+00, 6.00D+00, 1.00D+00, 2.00D+00, &
    3.00D+00 /)

  if ( n_data < 0 ) then
    n_data = 0
  end if

  n_data = n_data + 1

  if ( n_max < n_data ) then
    n_data = 0
    a = 0
    x = 0.0D+00
    fx = 0.0D+00
  else
    a = a_vec(n_data)
    x = x_vec(n_data)
    fx = fx_vec(n_data)
  end if

  return
end
subroutine cumbet ( x, y, a, b, cum, ccum )

!*****************************************************************************80
!
!! cumbet() evaluates the cumulative incomplete beta distribution.
!
!  Discussion:
!
!    This routine calculates the CDF to X of the incomplete beta distribution
!    with parameters A and B.  This is the integral from 0 to x
!    of (1/B(a,b))*f(t)) where f(t) = t^(a-1) * (1-t)^(b-1)
!
!  Licensing:
!
!    This code is distributed under the MIT license.
!
!  Modified:
!
!    15 February 2021
!
!  Author:
!
!    Barry Brown, James Lovato, Kathy Russell
!
!  Parameters:
!
!    Input, real ( kind = rk ) X, the upper limit of integration.
!
!    Input, real ( kind = rk ) Y, the value of 1-X.
!
!    Input, real ( kind = rk ) A, B, the parameters of the distribution.
!
!    Output, real ( kind = rk ) CUM, CCUM, the values of the cumulative
!    density function and complementary cumulative density function.
!
  implicit none

  integer, parameter :: rk = kind ( 1.0D+00 )

  real ( kind = rk ) a
  real ( kind = rk ) b
  real ( kind = rk ) ccum
  real ( kind = rk ) cum
  integer ierr
  real ( kind = rk ) x
  real ( kind = rk ) y

  if ( x <= 0.0D+00 ) then

    cum = 0.0
    ccum = 1.0D+00

  else if ( y <= 0.0D+00 ) then

    cum = 1.0D+00
    ccum = 0.0

  else

    call beta_inc ( a, b, x, y, cum, ccum, ierr )

  end if

  return
end
subroutine cumbin ( s, xn, pr, ompr, cum, ccum )

!*****************************************************************************80
!
!! cumbin() evaluates the cumulative binomial distribution.
!
!  Discussion:
!
!    This routine returns the probability of 0 to S successes in XN binomial
!    trials, each of which has a probability of success, PR.
!
!  Licensing:
!
!    This code is distributed under the MIT license.
!
!  Modified:
!
!    15 February 2021
!
!  Author:
!
!    Barry Brown, James Lovato, Kathy Russell
!
!  Reference:
!
!    Milton Abramowitz, Irene Stegun,
!    Handbook of Mathematical Functions
!    1966, Formula 26.5.24.
!
!  Parameters:
!
!    Input, real ( kind = rk ) S, the upper limit of summation.
!
!    Input, real ( kind = rk ) XN, the number of trials.
!
!    Input, real ( kind = rk ) PR, the probability of success in one trial.
!
!    Input, real ( kind = rk ) OMPR, equals ( 1 - PR ).
!
!    Output, real ( kind = rk ) CUM, the cumulative binomial distribution.
!
!    Output, real ( kind = rk ) CCUM, the complement of the cumulative
!    binomial distribution.
!
  implicit none

  integer, parameter :: rk = kind ( 1.0D+00 )

  real ( kind = rk ) ccum
  real ( kind = rk ) cum
  real ( kind = rk ) ompr
  real ( kind = rk ) pr
  real ( kind = rk ) s
  real ( kind = rk ) xn

  if ( s < xn ) then

    call cumbet ( pr, ompr, s + 1.0D+00, xn - s, ccum, cum )

  else

    cum = 1.0D+00
    ccum = 0.0D+00

  end if

  return
end
subroutine cumchi ( x, df, cum, ccum )

!*****************************************************************************80
!
!! cumchi() evaluates the cumulative chi-square distribution.
!
!  Licensing:
!
!    This code is distributed under the MIT license.
!
!  Modified:
!
!    15 February 2021
!
!  Author:
!
!    Barry Brown, James Lovato, Kathy Russell
!
!  Parameters:
!
!    Input, real ( kind = rk ) X, the upper limit of integration.
!
!    Input, real ( kind = rk ) DF, the degrees of freedom of the
!    chi-square distribution.
!
!    Output, real ( kind = rk ) CUM, the cumulative chi-square distribution.
!
!    Output, real ( kind = rk ) CCUM, the complement of the cumulative
!    chi-square distribution.
!
  implicit none

  integer, parameter :: rk = kind ( 1.0D+00 )

  real ( kind = rk ) a
  real ( kind = rk ) ccum
  real ( kind = rk ) cum
  real ( kind = rk ) df
  real ( kind = rk ) x
  real ( kind = rk ) xx

  a = df * 0.5D+00
  xx = x * 0.5D+00

  call cumgam ( xx, a, cum, ccum )

  return
end
subroutine cumchn ( x, df, pnonc, cum, ccum )

!*****************************************************************************80
!
!! cumchn() evaluates the cumulative noncentral chi-square distribution.
!
!  Discussion:
!
!    This routine calculates the cumulative noncentral chi-square
!    distribution, i.e., the probability that a random variable
!    which follows the noncentral chi-square distribution, with
!    noncentrality parameter PNONC and continuous degrees of
!    freedom DF, is less than or equal to X.
!
!  Licensing:
!
!    This code is distributed under the MIT license.
!
!  Modified:
!
!    15 February 2021
!
!  Author:
!
!    Barry Brown, James Lovato, Kathy Russell
!
!  Reference:
!
!    Milton Abramowitz, Irene Stegun,
!    Handbook of Mathematical Functions
!    1966, Formula 26.4.25.
!
!  Parameters:
!
!    Input, real ( kind = rk ) X, the upper limit of integration.
!
!    Input, real ( kind = rk ) DF, the number of degrees of freedom.
!
!    Input, real ( kind = rk ) PNONC, the noncentrality parameter of
!    the noncentral chi-square distribution.
!
!    Output, real ( kind = rk ) CUM, CCUM, the CDF and complementary
!    CDF of the noncentral chi-square distribution.
!
!  Local:
!
!    Local, real ( kind = rk ) EPS, the convergence criterion.  The sum
!    stops when a term is less than EPS * SUM.
!
!    Local, integer NTIRED, the maximum number of terms to be evaluated
!    in each sum.
!
!    Local, logical QCONV, is TRUE if convergence was achieved, that is,
!    the program did not stop on NTIRED criterion.
!
  implicit none

  integer, parameter :: rk = kind ( 1.0D+00 )

  real ( kind = rk ) adj
  real ( kind = rk ) ccum
  real ( kind = rk ) centaj
  real ( kind = rk ) centwt
  real ( kind = rk ) chid2
  real ( kind = rk ) cum
  real ( kind = rk ) df
  real ( kind = rk ) dfd2
  real ( kind = rk ) dg
  real ( kind = rk ), parameter :: eps = 0.00001D+00
  real ( kind = rk ) gamma_log
  integer i
  integer icent
  integer iterb
  integer iterf
  real ( kind = rk ) lcntaj
  real ( kind = rk ) lcntwt
  real ( kind = rk ) lfact
  integer, parameter :: ntired = 1000
  real ( kind = rk ) pcent
  real ( kind = rk ) pnonc
  real ( kind = rk ) pterm
  logical qsmall
  real ( kind = rk ) sum1
  real ( kind = rk ) sumadj
  real ( kind = rk ) term
  real ( kind = rk ) wt
  real ( kind = rk ) x
  real ( kind = rk ) xnonc
  real ( kind = rk ) xx

  qsmall ( xx ) = sum1 < 1.0D-20 .or. xx < eps * sum1
  dg(i) = df +  2.0D+00  * real ( i, kind = rk )

  if ( x <= 0.0D+00 ) then
    cum = 0.0D+00
    ccum = 1.0D+00
    return
  end if
!
!  When the noncentrality parameter is (essentially) zero,
!  use cumulative chi-square distribution
!
  if ( pnonc <= 1.0D-10 ) then
    call cumchi ( x, df, cum, ccum )
    return
  end if

  xnonc = pnonc /  2.0D+00
!
!  The following code calculates the weight, chi-square, and
!  adjustment term for the central term in the infinite series.
!  The central term is the one in which the poisson weight is
!  greatest.  The adjustment term is the amount that must
!  be subtracted from the chi-square to move up two degrees
!  of freedom.
!
  icent = int ( xnonc )
  if ( icent == 0 ) then
    icent = 1
  end if

  chid2 = x /  2.0D+00
!
!  Calculate central weight term.
!
  lfact = gamma_log ( real ( icent + 1, kind = rk ) )
  lcntwt = - xnonc + icent * log ( xnonc ) - lfact
  centwt = exp ( lcntwt )
!
!  Calculate central chi-square.
!
  call cumchi ( x, dg(icent), pcent, ccum )
!
!  Calculate central adjustment term.
!
  dfd2 = dg(icent) /  2.0D+00
  lfact = gamma_log ( 1.0D+00 + dfd2 )
  lcntaj = dfd2 * log ( chid2 ) - chid2 - lfact
  centaj = exp ( lcntaj )
  sum1 = centwt * pcent
!
!  Sum backwards from the central term towards zero.
!  Quit whenever either
!  (1) the zero term is reached, or
!  (2) the term gets small relative to the sum, or
!  (3) More than NTIRED terms are totaled.
!
  iterb = 0
  sumadj = 0.0D+00
  adj = centaj
  wt = centwt
  i = icent
  term = 0.0D+00

  do

    dfd2 = dg(i) /  2.0D+00
!
!  Adjust chi-square for two fewer degrees of freedom.
!  The adjusted value ends up in PTERM.
!
    adj = adj * dfd2 / chid2
    sumadj = sumadj + adj
    pterm = pcent + sumadj
!
!  Adjust Poisson weight for J decreased by one.
!
    wt = wt * ( i / xnonc )
    term = wt * pterm
    sum1 = sum1 + term
    i = i - 1
    iterb = iterb + 1

    if ( ntired < iterb .or. qsmall ( term ) .or. i == 0 ) then
      exit
    end if

  end do

  iterf = 0
!
!  Now sum forward from the central term towards infinity.
!  Quit when either
!    (1) the term gets small relative to the sum, or
!    (2) More than NTIRED terms are totaled.
!
  sumadj = centaj
  adj = centaj
  wt = centwt
  i = icent
!
!  Update weights for next higher J.
!
  do

    wt = wt * ( xnonc / ( i + 1 ) )
!
!  Calculate PTERM and add term to sum.
!
    pterm = pcent - sumadj
    term = wt * pterm
    sum1 = sum1 + term
!
!  Update adjustment term for DF for next iteration.
!
    i = i + 1
    dfd2 = dg(i) /  2.0D+00
    adj = adj * chid2 / dfd2
    sumadj = sumadj + adj
    iterf = iterf + 1

    if ( ntired < iterf .or. qsmall ( term ) ) then
      exit
    end if

  end do

  cum = sum1
  ccum = 0.5D+00 + ( 0.5D+00 - cum )

  return
end
subroutine cumf ( f, dfn, dfd, cum, ccum )

!*****************************************************************************80
!
!! cumf() evaluates the cumulative F distribution.
!
!  Discussion:
!
!    This routine computes the integral from 0 to F of the F density with DFN
!    numerator and DFD denominator degrees of freedom.
!
!  Licensing:
!
!    This code is distributed under the MIT license.
!
!  Modified:
!
!    15 February 2021
!
!  Author:
!
!    Barry Brown, James Lovato, Kathy Russell
!
!  Reference:
!
!    Milton Abramowitz, Irene Stegun,
!    Handbook of Mathematical Functions
!    1966, Formula 26.5.28.
!
!  Parameters:
!
!    Input, real ( kind = rk ) F, the upper limit of integration.
!
!    Input, real ( kind = rk ) DFN, DFD, the number of degrees of
!    freedom for the numerator and denominator.
!
!    Output, real ( kind = rk ) CUM, CCUM, the value of the F CDF and
!    the complementary F CDF.
!
  implicit none

  integer, parameter :: rk = kind ( 1.0D+00 )

  real ( kind = rk ) ccum
  real ( kind = rk ) cum
  real ( kind = rk ) dfd
  real ( kind = rk ) dfn
  real ( kind = rk ) dsum
  real ( kind = rk ) f
  integer ierr
  real ( kind = rk ) prod
  real ( kind = rk ) xx
  real ( kind = rk ) yy

  if ( f <= 0.0D+00 ) then
    cum = 0.0D+00
    ccum = 1.0D+00
    return
  end if

  prod = dfn * f
!
!  XX is such that the incomplete beta with parameters
!  DFD/2 and DFN/2 evaluated at XX is 1 - CUM or CCUM
!
!  YY is 1 - XX
!
!  Calculate the smaller of XX and YY accurately.
!
  dsum = dfd + prod
  xx = dfd / dsum

  if ( 0.5D+00 < xx ) then
    yy = prod / dsum
    xx = 1.0D+00 - yy
  else
    yy = 1.0D+00 - xx
  end if

  call beta_inc ( 0.5D+00 * dfd, 0.5D+00 * dfn, xx, yy, ccum, cum, ierr )

  return
end
subroutine cumfnc ( f, dfn, dfd, pnonc, cum, ccum )

!*****************************************************************************80
!
!! cumfnc() evaluates the cumulative noncentral F distribution.
!
!  Discussion:
!
!    This routine computes the noncentral F distribution with DFN and DFD
!    degrees of freedom and noncentrality parameter PNONC.
!
!    The series is calculated backward and forward from J = LAMBDA/2
!    (this is the term with the largest Poisson weight) until
!    the convergence criterion is met.
!
!    The sum continues until a succeeding term is less than EPS
!    times the sum or the sum is very small.  EPS is
!    set to 1.0D-4 in a data statement which can be changed.
!
!    The original version of this routine allowed the input values
!    of DFN and DFD to be negative (nonsensical) or zero (which
!    caused numerical overflow.)  I have forced both these values
!    to be at least 1.
!
!  Licensing:
!
!    This code is distributed under the MIT license.
!
!  Modified:
!
!    15 February 2021
!
!  Author:
!
!    Barry Brown, James Lovato, Kathy Russell
!
!  Reference:
!
!    Milton Abramowitz, Irene Stegun,
!    Handbook of Mathematical Functions
!    1966, Formula 26.5.16, 26.6.17, 26.6.18, 26.6.20.
!
!  Parameters:
!
!    Input, real ( kind = rk ) F, the upper limit of integration.
!
!    Input, real ( kind = rk ) DFN, DFD, the number of degrees of freedom
!    in the numerator and denominator.  Both DFN and DFD must be positive,
!    and normally would be integers.  This routine requires that they
!    be no less than 1.
!
!    Input, real ( kind = rk ) PNONC, the noncentrality parameter.
!
!    Output, real ( kind = rk ) CUM, CCUM, the noncentral F CDF and
!    complementary CDF.
!
  implicit none

  integer, parameter :: rk = kind ( 1.0D+00 )

  real ( kind = rk ) adn
  real ( kind = rk ) arg1
  real ( kind = rk ) aup
  real ( kind = rk ) b
  real ( kind = rk ) betdn
  real ( kind = rk ) betup
  real ( kind = rk ) centwt
  real ( kind = rk ) ccum
  real ( kind = rk ) cum
  real ( kind = rk ) dfd
  real ( kind = rk ) dfn
  real ( kind = rk ) dnterm
  real ( kind = rk ) dsum
  real ( kind = rk ) dummy
  real ( kind = rk ), parameter :: eps = 0.0001D+00
  real ( kind = rk ) expon
  real ( kind = rk ) f
  real ( kind = rk ) gamma_log
  integer i
  integer icent
  integer ierr
  real ( kind = rk ) pnonc
  real ( kind = rk ) prod
  real ( kind = rk ) sum1
  real ( kind = rk ) upterm
  real ( kind = rk ) xmult
  real ( kind = rk ) xnonc
  real ( kind = rk ) xx
  real ( kind = rk ) yy

  if ( f <= 0.0D+00 ) then
    cum = 0.0D+00
    ccum = 1.0D+00
    return
  end if

  if ( dfn < 1.0D+00 ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'CUMFNC - Fatal error!'
    write ( *, '(a)' ) '  DFN < 1.'
    stop
  end if

  if ( dfd < 1.0D+00 ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'CUMFNC - Fatal error!'
    write ( *, '(a)' ) '  DFD < 1.'
    stop
  end if
!
!  Handle case in which the noncentrality parameter is essentially zero.
!
  if ( pnonc < 1.0D-10 ) then
    call cumf ( f, dfn, dfd, cum, ccum )
    return
  end if

  xnonc = pnonc /  2.0D+00
!
!  Calculate the central term of the Poisson weighting factor.
!
  icent = int ( xnonc )

  if ( icent == 0 ) then
    icent = 1
  end if
!
!  Compute central weight term.
!
  centwt = exp ( -xnonc + icent * log ( xnonc ) &
    - gamma_log ( real ( icent + 1, kind = rk  ) ) )
!
!  Compute central incomplete beta term.
!  Ensure that minimum of arg to beta and 1 - arg is computed accurately.
!
  prod = dfn * f
  dsum = dfd + prod
  yy = dfd / dsum

  if ( 0.5D+00 < yy ) then
    xx = prod / dsum
    yy = 1.0D+00 - xx
  else
    xx = 1.0D+00 - yy
  end if

  arg1 = 0.5D+00 * dfn + real ( icent, kind = rk )
  call beta_inc ( arg1, 0.5D+00*dfd, xx, yy, betdn, dummy, ierr )

  adn = dfn / 2.0D+00 + real ( icent, kind = rk )
  aup = adn
  b = dfd / 2.0D+00
  betup = betdn
  sum1 = centwt * betdn
!
!  Now sum terms backward from ICENT until convergence or all done.
!
  xmult = centwt
  i = icent
  dnterm = exp ( gamma_log ( adn + b ) &
    - gamma_log ( adn + 1.0D+00 ) &
    - gamma_log ( b ) + adn * log ( xx ) + b * log ( yy ) )

  do

    if ( i <= 0 ) then
      exit
    end if

    if ( sum1 < epsilon ( xmult * betdn ) .or. &
         xmult * betdn < eps * sum1 ) then
      exit
    end if

    xmult = xmult * ( real ( i, kind = rk ) / xnonc )
    i = i - 1
    adn = adn - 1.0D+00
    dnterm = ( adn + 1.0D+00 ) / ( ( adn + b ) * xx ) * dnterm
    betdn = betdn + dnterm
    sum1 = sum1 + xmult * betdn

  end do

  i = icent + 1
!
!  Now sum forward until convergence.
!
  xmult = centwt

  if ( ( aup - 1.0D+00 + b ) == 0 ) then

    expon = - gamma_log ( aup ) - gamma_log ( b ) &
      + ( aup - 1.0D+00 ) * log ( xx ) + b * log ( yy )

  else

    expon = gamma_log ( aup - 1.0D+00 + b ) - gamma_log ( aup ) &
      - gamma_log ( b ) + ( aup - 1.0D+00 ) * log ( xx ) + b * log ( yy )

  end if
!
!  The fact that DCDFLIB assumes that 1.0E+30 is a reasonable
!  value to plug into any function, and that G95 computes corresponding
!  function values of, say 1.0E-303, and then chokes with a floating point
!  error when asked to combine such a value with a reasonable floating
!  point quantity, has driven me to the following sort of check that
!  was last fashionable in the 1960's!
!
  if ( expon <= log ( epsilon ( expon ) ) ) then
    upterm = 0.0D+00
  else
    upterm = exp ( expon )
  end if

  do

    xmult = xmult * ( xnonc / real ( i, kind = rk ) )
    i = i + 1
    aup = aup + 1.0D+00
    upterm = ( aup + b -  2.0D+00  ) * xx / ( aup - 1.0D+00 ) * upterm
    betup = betup - upterm
    sum1 = sum1 + xmult * betup

    if ( sum1 < epsilon ( xmult * betup ) .or. xmult * betup < eps * sum1 ) then
      exit
    end if

  end do

  cum = sum1
  ccum = 0.5D+00 + ( 0.5D+00 - cum )

  return
end
subroutine cumgam ( x, a, cum, ccum )

!*****************************************************************************80
!
!! cumgam() evaluates the cumulative incomplete gamma distribution.
!
!  Discussion:
!
!    This routine computes the cumulative distribution function of the
!    incomplete gamma distribution, i.e., the integral from 0 to X of
!
!      (1/GAM(A))*EXP(-T)*T^(A-1) DT
!
!    where GAM(A) is the complete gamma function of A:
!
!      GAM(A) = integral from 0 to infinity of EXP(-T)*T^(A-1) DT
!
!  Licensing:
!
!    This code is distributed under the MIT license.
!
!  Modified:
!
!    15 February 2021
!
!  Author:
!
!    Barry Brown, James Lovato, Kathy Russell
!
!  Parameters:
!
!    Input, real ( kind = rk ) X, the upper limit of integration.
!
!    Input, real ( kind = rk ) A, the shape parameter of the incomplete
!    Gamma distribution.
!
!    Output, real ( kind = rk ) CUM, CCUM, the incomplete Gamma CDF and
!    complementary CDF.
!
  implicit none

  integer, parameter :: rk = kind ( 1.0D+00 )

  real ( kind = rk ) a
  real ( kind = rk ) ccum
  real ( kind = rk ) cum
  real ( kind = rk ) x

  if ( x <= 0.0D+00 ) then

    cum = 0.0D+00
    ccum = 1.0D+00

  else

    call gamma_inc ( a, x, cum, ccum, 0 )

  end if

  return
end
subroutine cumnbn ( f, s, pr, ompr, cum, ccum )

!*****************************************************************************80
!
!! cumnbn() evaluates the cumulative negative binomial distribution.
!
!  Discussion:
!
!    This routine returns the probability that there will be F or
!    fewer failures before there are S successes, with each binomial
!    trial having a probability of success PR.
!
!    Prob(# failures = F | S successes, PR)  =
!                        ( S + F - 1 )
!                        (            ) * PR^S * (1-PR)^F
!                        (      F     )
!
!  Licensing:
!
!    This code is distributed under the MIT license.
!
!  Modified:
!
!    15 February 2021
!
!  Author:
!
!    Barry Brown, James Lovato, Kathy Russell
!
!  Reference:
!
!    Milton Abramowitz, Irene Stegun,
!    Handbook of Mathematical Functions
!    1966, Formula 26.5.26.
!
!  Parameters:
!
!    Input, real ( kind = rk ) F, the number of failures.
!
!    Input, real ( kind = rk ) S, the number of successes.
!
!    Input, real ( kind = rk ) PR, OMPR, the probability of success on
!    each binomial trial, and the value of (1-PR).
!
!    Output, real ( kind = rk ) CUM, CCUM, the negative binomial CDF,
!    and the complementary CDF.
!
  implicit none

  integer, parameter :: rk = kind ( 1.0D+00 )

  real ( kind = rk ) ccum
  real ( kind = rk ) cum
  real ( kind = rk ) f
  real ( kind = rk ) ompr
  real ( kind = rk ) pr
  real ( kind = rk ) s

  call cumbet ( pr, ompr, s, f+1.D+00, cum, ccum )

  return
end
subroutine cumnor ( arg, cum, ccum )

!*****************************************************************************80
!
!! cumnor() computes the cumulative normal distribution.
!
!  Discussion:
!
!    This function evaluates the normal distribution function:
!
!                              / x
!                     1       |       -t*t/2
!          P(x) = ----------- |      e       dt
!                 sqrt(2 pi)  |
!                             /-oo
!
!    This transportable program uses rational functions that
!    theoretically approximate the normal distribution function to
!    at least 18 significant decimal digits.  The accuracy achieved
!    depends on the arithmetic system, the compiler, the intrinsic
!    functions, and proper selection of the machine dependent
!    constants.
!
!  Licensing:
!
!    This code is distributed under the MIT license.
!
!  Modified:
!
!    15 February 2021
!
!  Author:
!
!    William Cody
!
!  Reference:
!
!    William Cody,
!    Rational Chebyshev approximations for the error function,
!    Mathematics of Computation,
!    1969, pages 631-637.
!
!    William Cody,
!    Algorithm 715:
!    SPECFUN - A Portable Fortran Package of Special Function Routines
!    and Test Drivers,
!    ACM Transactions on Mathematical Software,
!    Volume 19, Number 1, 1993, pages 22-32.
!
!  Parameters:
!
!    Input, real ( kind = rk ) ARG, the upper limit of integration.
!
!    Output, real ( kind = rk ) CUM, CCUM, the Normal density CDF and
!    complementary CDF.
!
!  Local:
!
!    Local, real ( kind = rk ) EPS, the argument below which anorm(x)
!    may be represented by 0.5 and above which  x*x  will not underflow.
!    A conservative value is the largest machine number X
!    such that   1.0D+00 + X = 1.0D+00   to machine precision.
!
  implicit none

  integer, parameter :: rk = kind ( 1.0D+00 )

  real ( kind = rk ), parameter, dimension ( 5 ) :: a = (/ &
    2.2352520354606839287D+00, &
    1.6102823106855587881D+02, &
    1.0676894854603709582D+03, &
    1.8154981253343561249D+04, &
    6.5682337918207449113D-02 /)
  real ( kind = rk ) arg
  real ( kind = rk ), parameter, dimension ( 4 ) :: b = (/ &
    4.7202581904688241870D+01, &
    9.7609855173777669322D+02, &
    1.0260932208618978205D+04, &
    4.5507789335026729956D+04 /)
  real ( kind = rk ), parameter, dimension ( 9 ) :: c = (/ &
    3.9894151208813466764D-01, &
    8.8831497943883759412D+00, &
    9.3506656132177855979D+01, &
    5.9727027639480026226D+02, &
    2.4945375852903726711D+03, &
    6.8481904505362823326D+03, &
    1.1602651437647350124D+04, &
    9.8427148383839780218D+03, &
    1.0765576773720192317D-08 /)
  real ( kind = rk ) ccum
  real ( kind = rk ) cum
  real ( kind = rk ), parameter, dimension ( 8 ) :: d = (/ &
    2.2266688044328115691D+01, &
    2.3538790178262499861D+02, &
    1.5193775994075548050D+03, &
    6.4855582982667607550D+03, &
    1.8615571640885098091D+04, &
    3.4900952721145977266D+04, &
    3.8912003286093271411D+04, &
    1.9685429676859990727D+04 /)
  real ( kind = rk ) del
  real ( kind = rk ) eps
  integer i
  real ( kind = rk ), parameter, dimension ( 6 ) :: p = (/ &
    2.1589853405795699D-01, &
    1.274011611602473639D-01, &
    2.2235277870649807D-02, &
    1.421619193227893466D-03, &
    2.9112874951168792D-05, &
    2.307344176494017303D-02 /)
  real ( kind = rk ), parameter, dimension ( 5 ) :: q = (/ &
    1.28426009614491121D+00, &
    4.68238212480865118D-01, &
    6.59881378689285515D-02, &
    3.78239633202758244D-03, &
    7.29751555083966205D-05 /)
  real ( kind = rk ), parameter :: root32 = 5.656854248D+00
  real ( kind = rk ), parameter :: sixten = 16.0D+00
  real ( kind = rk ) temp
  real ( kind = rk ), parameter :: sqrpi = 3.9894228040143267794D-01
  real ( kind = rk ), parameter :: thrsh = 0.66291D+00
  real ( kind = rk ) x
  real ( kind = rk ) xden
  real ( kind = rk ) xnum
  real ( kind = rk ) y
  real ( kind = rk ) xsq
!
!  Machine dependent constants
!
  eps = epsilon ( 1.0D+00 ) * 0.5D+00

  x = arg
  y = abs ( x )

  if ( y <= thrsh ) then
!
!  Evaluate  anorm  for  |X| <= 0.66291
!
    if ( eps < y ) then
      xsq = x * x
    else
      xsq = 0.0D+00
    end if

    xnum = a(5) * xsq
    xden = xsq
    do i = 1, 3
      xnum = ( xnum + a(i) ) * xsq
      xden = ( xden + b(i) ) * xsq
    end do
    cum = x * ( xnum + a(4) ) / ( xden + b(4) )
    temp = cum
    cum = 0.5D+00 + temp
    ccum = 0.5D+00 - temp
!
!  Evaluate ANORM for 0.66291 <= |X| <= sqrt(32)
!
  else if ( y <= root32 ) then

    xnum = c(9) * y
    xden = y
    do i = 1, 7
      xnum = ( xnum + c(i) ) * y
      xden = ( xden + d(i) ) * y
    end do
    cum = ( xnum + c(8) ) / ( xden + d(8) )
    xsq = aint ( y * sixten ) / sixten
    del = ( y - xsq ) * ( y + xsq )
    cum = exp ( - xsq * xsq * 0.5D+00 ) * exp ( -del * 0.5D+00 ) * cum
    ccum = 1.0D+00 - cum

    if ( 0.0D+00 < x ) then
      call r8_swap ( cum, ccum )
    end if
!
!  Evaluate ANORM for sqrt(32) < |X|.
!
  else

    cum = 0.0D+00
    xsq = 1.0D+00 / ( x * x )
    xnum = p(6) * xsq
    xden = xsq
    do i = 1, 4
      xnum = ( xnum + p(i) ) * xsq
      xden = ( xden + q(i) ) * xsq
    end do

    cum = xsq * ( xnum + p(5) ) / ( xden + q(5) )
    cum = ( sqrpi - cum ) / y
    xsq = aint ( x * sixten ) / sixten
    del = ( x - xsq ) * ( x + xsq )
    cum = exp ( - xsq * xsq * 0.5D+00 ) &
      * exp ( - del * 0.5D+00 ) * cum
    ccum = 1.0D+00 - cum

    if ( 0.0D+00 < x ) then
      call r8_swap ( cum, ccum )
    end if

  end if

  if ( cum < tiny ( cum ) ) then
    cum = 0.0D+00
  end if

  if ( ccum < tiny ( ccum ) ) then
    ccum = 0.0D+00
  end if

  return
end
subroutine cumpoi ( s, xlam, cum, ccum )

!*****************************************************************************80
!
!! cumpoi() evaluates the cumulative Poisson distribution.
!
!  Discussion:
!
!    This routine returns the probability of S or fewer events in a Poisson
!    distribution with mean XLAM.
!
!  Licensing:
!
!    This code is distributed under the MIT license.
!
!  Modified:
!
!    15 February 2021
!
!  Author:
!
!    Barry Brown, James Lovato, Kathy Russell
!
!  Reference:
!
!    Milton Abramowitz, Irene Stegun,
!    Handbook of Mathematical Functions,
!    Formula 26.4.21.
!
!  Parameters:
!
!    Input, real ( kind = rk ) S, the upper limit of cumulation of the
!    Poisson density function.
!
!    Input, real ( kind = rk ) XLAM, the mean of the Poisson distribution.
!
!    Output, real ( kind = rk ) CUM, CCUM, the Poisson density CDF and
!    complementary CDF.
!
  implicit none

  integer, parameter :: rk = kind ( 1.0D+00 )

  real ( kind = rk ) ccum
  real ( kind = rk ) chi
  real ( kind = rk ) cum
  real ( kind = rk ) df
  real ( kind = rk ) s
  real ( kind = rk ) xlam

  df =  2.0D+00  * ( s + 1.0D+00 )
  chi =  2.0D+00  * xlam

  call cumchi ( chi, df, ccum, cum )

  return
end
subroutine cumt ( t, df, cum, ccum )

!*****************************************************************************80
!
!! cumt() evaluates the cumulative T distribution.
!
!  Licensing:
!
!    This code is distributed under the MIT license.
!
!  Modified:
!
!    15 February 2021
!
!  Author:
!
!    Barry Brown, James Lovato, Kathy Russell
!
!  Reference:
!
!    Milton Abramowitz, Irene Stegun,
!    Handbook of Mathematical Functions,
!    Formula 26.5.27.
!
!  Parameters:
!
!    Input, real ( kind = rk ) T, the upper limit of integration.
!
!    Input, real ( kind = rk ) DF, the number of degrees of freedom of
!    the T distribution.
!
!    Output, real ( kind = rk ) CUM, CCUM, the T distribution CDF and
!    complementary CDF.
!
  implicit none

  integer, parameter :: rk = kind ( 1.0D+00 )

  real ( kind = rk ) a
  real ( kind = rk ) ccum
  real ( kind = rk ) cum
  real ( kind = rk ) df
  real ( kind = rk ) oma
  real ( kind = rk ) t
  real ( kind = rk ) xx
  real ( kind = rk ) yy

  xx = df / ( df + t**2 )
  yy = t**2 / ( df + t**2 )

  call cumbet ( xx, yy, 0.5D+00*df, 0.5D+00, a, oma )

  if ( t <= 0.0D+00 ) then
    cum = 0.5D+00 * a
    ccum = oma + cum
  else
    ccum = 0.5D+00 * a
    cum = oma + ccum
  end if

  return
end
function dbetrm ( a, b )

!*****************************************************************************80
!
!! dbetrm() computes the Sterling remainder for the complete beta function.
!
!  Discussion:
!
!    Log(Beta(A,B)) = Lgamma(A) + Lgamma(B) - Lgamma(A+B)
!    where Lgamma is the log of the (complete) gamma function
!
!    Let ZZ be approximation obtained if each log gamma is approximated
!    by Sterling's formula, i.e.,
!
!      Sterling(Z) = log ( sqrt ( 2 * PI ) ) + ( Z - 0.5 ) * log ( Z ) - Z
!
!    The Sterling remainder is Log(Beta(A,B)) - ZZ.
!
!  Licensing:
!
!    This code is distributed under the MIT license.
!
!  Modified:
!
!    15 February 2021
!
!  Parameters:
!
!    Input, real ( kind = rk ) A, B, the parameters of the Beta function.
!
!    Output, real ( kind = rk ) DBETRM, the Sterling remainder.
!
  implicit none

  integer, parameter :: rk = kind ( 1.0D+00 )

  real ( kind = rk ) a
  real ( kind = rk ) b
  real ( kind = rk ) dbetrm
  real ( kind = rk ) dstrem
!
!  Try to sum from smallest to largest.
!
  dbetrm = -dstrem ( a + b )
  dbetrm = dbetrm + dstrem ( max ( a, b ) )
  dbetrm = dbetrm + dstrem ( min ( a, b ) )

  return
end
function dexpm1 ( x )

!*****************************************************************************80
!
!! DEXPM1 evaluates the function EXP(X) - 1.
!
!  Licensing:
!
!    This code is distributed under the MIT license.
!
!  Modified:
!
!    15 February 2021
!
!  Author:
!
!    Armido DiDinato, Alfred Morris
!
!  Reference:
!
!    Armido DiDinato, Alfred Morris,
!    Algorithm 708:
!    Significant Digit Computation of the Incomplete Beta Function Ratios,
!    ACM Transactions on Mathematical Software,
!    Volume 18, 1993, pages 360-373.
!
!  Parameters:
!
!    Input, real ( kind = rk ) X, the value at which exp(X)-1 is desired.
!
!    Output, real ( kind = rk ) DEXPM1, the value of exp(X)-1.
!
  implicit none

  integer, parameter :: rk = kind ( 1.0D+00 )

  real ( kind = rk ) bot
  real ( kind = rk ) dexpm1
  real ( kind = rk ), parameter :: p1 =  0.914041914819518D-09
  real ( kind = rk ), parameter :: p2 =  0.238082361044469D-01
  real ( kind = rk ), parameter :: q1 = -0.499999999085958D+00
  real ( kind = rk ), parameter :: q2 =  0.107141568980644D+00
  real ( kind = rk ), parameter :: q3 = -0.119041179760821D-01
  real ( kind = rk ), parameter :: q4 =  0.595130811860248D-03
  real ( kind = rk ) top
  real ( kind = rk ) w
  real ( kind = rk ) x

  if ( abs ( x ) <= 0.15D+00 ) then

    top = ( p2 * x + p1 ) * x + 1.0D+00
    bot = ((( q4 * x + q3 ) * x + q2 ) * x + q1 ) * x + 1.0D+00
    dexpm1 = x * ( top / bot )

  else

    w = exp ( x )

    if ( x <= 0.0D+00 ) then
      dexpm1 = ( w - 0.5D+00 ) - 0.5D+00
    else
      dexpm1 = w * ( 0.5D+00 &
        + ( 0.5D+00 - 1.0D+00 / w ))
    end if

  end if

  return
end
function dinvnr ( p, q )

!*****************************************************************************80
!
!! DINVNR computes the inverse of the normal distribution.
!
!  Discussion:
!
!    This routine returns X such that
!
!      CUMNOR(X) = P,
!
!    that is, so that
!
!      P = integral ( -oo <= T <= X ) exp(-U*U/2)/sqrt(2*PI) dU
!
!    The rational function on page 95 of Kennedy and Gentle is used as a
!    starting value for the Newton method of finding roots.
!
!  Licensing:
!
!    This code is distributed under the MIT license.
!
!  Modified:
!
!    15 February 2021
!
!  Reference:
!
!    William Kennedy, James Gentle,
!    Statistical Computing,
!    Marcel Dekker, NY, 1980,
!    QA276.4 K46
!
!  Parameters:
!
!    Input, real ( kind = rk ) P, Q, the probability, and the complementary
!    probability.
!
!    Output, real ( kind = rk ) DINVNR, the argument X for which the
!    Normal CDF has the value P.
!
  implicit none

  integer, parameter :: rk = kind ( 1.0D+00 )

  real ( kind = rk ) ccum
  real ( kind = rk ) cum
  real ( kind = rk ) dinvnr
  real ( kind = rk ) dx
  real ( kind = rk ), parameter :: eps = 1.0D-13
  integer i
  integer, parameter :: maxit = 100
  real ( kind = rk ) p
  real ( kind = rk ) pp
  real ( kind = rk ) q
  real ( kind = rk ), parameter :: r2pi = 0.3989422804014326D+00
  real ( kind = rk ) strtx
  real ( kind = rk ) stvaln
  real ( kind = rk ) xcur

  pp = min ( p, q )
  strtx = stvaln ( pp )
  xcur = strtx
!
!  Newton iterations.
!
  do i = 1, maxit

    call cumnor ( xcur, cum, ccum )
    dx = ( cum - pp ) / ( r2pi * exp ( -0.5D+00 * xcur * xcur ) )
    xcur = xcur - dx

    if ( abs ( dx / xcur ) < eps ) then
      if ( p <= q ) then
        dinvnr = xcur
      else
        dinvnr = -xcur
      end if
      return
    end if

  end do

  if ( p <= q ) then
    dinvnr = strtx
  else
    dinvnr = -strtx
  end if

  return
end
subroutine dinvr ( status, x, fx, qleft, qhi )

!*****************************************************************************80
!
!! DINVR bounds the zero of the function and invokes DZROR.
!
!  Discussion:
!
!    This routine seeks to find bounds on a root of the function and
!    invokes DZROR to perform the zero finding.  DSTINV must have been
!    called before this routine in order to set its parameters.
!
!  Licensing:
!
!    This code is distributed under the MIT license.
!
!  Modified:
!
!    15 February 2021
!
!  Reference:
!
!    JCP Bus, TJ Dekker,
!    Two Efficient Algorithms with Guaranteed Convergence for
!    Finding a Zero of a Function,
!    ACM Transactions on Mathematical Software,
!    Volume 1, Number 4, pages 330-345, 1975.
!
!  Parameters:
!
!    Input/output, integer STATUS.  At the beginning of a zero
!    finding problem, STATUS should be set to 0 and this routine invoked.
!    The value of parameters other than X will be ignored on this call.
!    If this routine needs the function to be evaluated, it will set STATUS
!    to 1 and return.  The value of the function should be set in FX and
!    this routine again called without changing any of its other parameters.
!    If this routine finishes without error, it returns with STATUS 0,
!    and X an approximate root of F(X).
!    If this routine cannot bound the function, it returns a negative STATUS and
!    sets QLEFT and QHI.
!
!    Output, real ( kind = rk ) X, the value at which F(X) is to be evaluated.
!
!    Input, real ( kind = rk ) FX, the value of F(X) calculated by the user
!    on the previous call, when this routine returned with STATUS = 1.
!
!    Output, logical QLEFT, is defined only if QMFINV returns FALSE.  In that
!    case, QLEFT is TRUE if the stepping search terminated unsucessfully
!    at SMALL, and FALSE if the search terminated unsucessfully at BIG.
!
!    Output, logical QHI, is defined only if QMFINV returns FALSE.  In that
!    case, it is TRUE if Y < F(X) at the termination of the search and FALSE
!    if F(X) < Y.
!
  implicit none

  integer, parameter :: rk = kind ( 1.0D+00 )

  real ( kind = rk ) :: absstp
  real ( kind = rk ) :: abstol
  real ( kind = rk ) :: big
  real ( kind = rk ) fbig
  real ( kind = rk ) fsmall
  real ( kind = rk ) fx
  integer i99999
  logical qbdd
  logical qcond
  logical qdum1
  logical qdum2
  logical qhi
  logical qincr
  logical qleft
  logical qlim
  logical qup
  real ( kind = rk ) :: relstp
  real ( kind = rk ) :: reltol
  real ( kind = rk ) :: small
  integer status
  real ( kind = rk ) step
  real ( kind = rk ) :: stpmul
  real ( kind = rk ) x
  real ( kind = rk ) xhi
  real ( kind = rk ) xlb
  real ( kind = rk ) xlo
  real ( kind = rk ) xsave
  real ( kind = rk ) xub
  real ( kind = rk ) yy
  real ( kind = rk ) zabsst
  real ( kind = rk ) zabsto
  real ( kind = rk ) zbig
  real ( kind = rk ) zrelst
  real ( kind = rk ) zrelto
  real ( kind = rk ) zsmall
  real ( kind = rk ) zstpmu

  save

  if ( 0 < status ) then
    if ( i99999 == 10 ) then
      go to 10
    else if ( i99999 == 20 ) then
      go to 20
    else if ( i99999 == 90 ) then
      go to 90
    else if ( i99999 == 130 ) then
      go to 130
    else if ( i99999 == 200 ) then
      go to 200
    else if ( i99999 == 270 ) then
      go to 270
    else
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'DINVR - Fatal error!'
      write ( *, '(a)' ) '  Illegal value of I99999.'
      stop 1
    end if
  end if

  qcond = .not. ( small <= x .and. x <= big )

  if ( .not. ( small <= x .and. x <= big ) ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'DINVR - Fatal error!'
    write ( *, '(a)' ) '  The values SMALL, X, BIG are not monotone.'
    stop 1
  end if

  xsave = x
!
!  See that SMALL and BIG bound the zero and set QINCR.
!
  x = small
!
!  GET-function-VALUE
!
  i99999 = 10
  status = 1
  return

   10 continue

  fsmall = fx
  x = big
!
!  GET-function-VALUE
!
  i99999 = 20
  status = 1
  return

20 continue

  fbig = fx

  qincr = ( fsmall < fbig )

  if ( fsmall <= fbig ) then

    if ( 0.0D+00 < fsmall ) then
      status = -1
      qleft = .true.
      qhi = .true.
      return
    end if

    if ( fbig < 0.0D+00 ) then
      status = -1
      qleft = .false.
      qhi = .false.
      return
    end if

  else if ( fbig < fsmall ) then

    if ( fsmall < 0.0D+00 ) then
      status = -1
      qleft = .true.
      qhi = .false.
      return
    end if

    if ( 0.0D+00 < fbig ) then
      status = -1
      qleft = .false.
      qhi = .true.
      return
    end if

  end if

  x = xsave
  step = max ( absstp, relstp * abs ( x ) )
!
!  YY = F(X) - Y
!  GET-function-VALUE
!
  i99999 = 90
  status = 1
  return

90 continue

  yy = fx

  if ( yy == 0.0D+00 ) then
    status = 0
    return
  end if

! 100 continue

  qup = ( qincr .and. ( yy < 0.0D+00 ) ) .or. &
        ( .not. qincr .and. ( 0.0D+00 < yy ) )
!
!  Handle case in which we must step higher.
!
  if (.not. qup ) then
    go to 170
  end if

  xlb = xsave
  xub = min ( xlb + step, big )
  go to 120

  110 continue

  if ( qcond ) then
    go to 150
  end if
!
!  YY = F(XUB) - Y
!
  120 continue

  x = xub
!
!  GET-function-VALUE
!
  i99999 = 130
  status = 1
  return

130 continue

  yy = fx
  qbdd = ( qincr .and. ( 0.0D+00 <= yy ) ) .or. &
    ( .not. qincr .and. ( yy <= 0.0D+00 ) )
  qlim = ( big <= xub )
  qcond = qbdd .or. qlim

  if ( .not. qcond ) then
    step = stpmul * step
    xlb = xub
    xub = min ( xlb + step, big )
  end if

  go to 110

  150 continue

  if ( qlim .and. .not. qbdd ) then
    status = -1
    qleft = .false.
    qhi = .not. qincr
    x = big
    return
  end if

  go to 240
!
!  Handle the case in which we must step lower.
!
  170 continue

  xub = xsave
  xlb = max ( xub - step, small )
  go to 190

  180 continue

  if ( qcond ) then
    go to 220
  end if
!
!  YY = F(XLB) - Y
!
  190 continue

  x = xlb
!
!  GET-function-VALUE
!
  i99999 = 200
  status = 1
  return

  200 continue

  yy = fx
  qbdd = ( qincr .and. ( yy <= 0.0D+00 ) ) .or. &
    ( .not. qincr .and. ( 0.0D+00 <= yy ) )
  qlim = xlb <= small
  qcond = qbdd .or. qlim

  if ( .not. qcond ) then
    step = stpmul * step
    xub = xlb
    xlb = max ( xub - step, small )
  end if

  go to 180

  220 continue

  if ( qlim .and. ( .not. qbdd ) ) then
    status = -1
    qleft = .true.
    qhi = qincr
    x = small
    return
  end if

  240 continue

  call dstzr ( xlb, xub, abstol, reltol )
!
!  If we reach here, XLB and XUB bound the zero of F.
!
  status = 0
  go to 260

  250 continue

    if ( status /= 1 ) then
      x = xlo
      status = 0
      return
    end if

  260 continue

  call dzror ( status, x, fx, xlo, xhi, qdum1, qdum2 )

  if ( status /= 1 ) then
    go to 250
  end if
!
!  GET-function-VALUE
!
  i99999 = 270
  status = 1
  return

  270 continue
  go to 250

entry dstinv ( zsmall, zbig, zabsst, zrelst, zstpmu, zabsto, zrelto )

!*****************************************************************************80
!
!! DSTINV SeT INverse finder - Reverse Communication
!
!  Discussion:
!
!    This routine is given a monotone function F, and a value Y,
!    and seeks an argument value X such that F(X) = Y.
!
!    This routine uses reverse communication -- see DINVR.
!    This routine sets quantities needed by DINVR.
!
!    F must be a monotone function, the results of QMFINV are
!    otherwise undefined.  QINCR must be TRUE if F is nondecreasing
!    and FALSE if F is nonincreasing.
!
!    QMFINV will return TRUE if and only if F(SMALL) and
!    F(BIG) bracket Y, i. e.,
!      QINCR is TRUE and F(SMALL) <= Y <= F(BIG) or
!      QINCR is FALSE and F(BIG) <= Y <= F(SMALL)
!
!    If QMFINV returns TRUE, then the X returned satisfies
!    the following condition.  Let
!      TOL(X) = MAX ( ABSTOL, RELTOL * ABS ( X ) )
!    then if QINCR is TRUE,
!      F(X-TOL(X)) <= Y <= F(X+TOL(X))
!    and if QINCR is FALSE
!      F(X-TOL(X)) .GE. Y .GE. F(X+TOL(X))
!
!    Compares F(X) with Y for the input value of X then uses QINCR
!    to determine whether to step left or right to bound the
!    desired X.  The initial step size is
!
!      max ( ABSSTP, RELSTP * ABS ( S ) )
!
!    for the input value of X.
!
!    Iteratively steps right or left until it bounds X.
!    At each step which doesn't bound X, the step size is doubled.
!    The routine is careful never to step beyond SMALL or BIG.  If
!    it hasn't bounded X at SMALL or BIG, QMFINV returns FALSE
!    after setting QLEFT and QHI.
!
!    If X is successfully bounded then Algorithm R of the paper
!    Bus and Dekker is employed to find the zero of the function F(X)-Y.
!    This is routine QRZERO.
!
!  Licensing:
!
!    This code is distributed under the MIT license.
!
!  Modified:
!
!    15 February 2021
!
!  Reference:
!
!    JCP Bus, TJ Dekker,
!    Two Efficient Algorithms with Guaranteed Convergence for
!    Finding a Zero of a Function,
!    ACM Transactions on Mathematical Software,
!    Volume 1, Number 4, pages 330-345, 1975.
!
!  Parameters:
!
!    Input, real ( kind = rk ) ZSMALL, ZBIG, the left and right endpoints
!    of the interval to be searched for a solution.
!
!    Input, real ( kind = rk ) ZABSST, ZRELSTP, the initial step size in
!    the search is max ( ZABSST, ZRELST * abs ( X ) ).
!
!    Input, real ( kind = rk ) STPMUL.  When a step doesn't bound the zero,
!    the stepsize is multiplied by STPMUL and another step taken.  A
!    popular value is 2.0.
!
!    Input, real ( kind = rk ) ABSTOL, RELTOL, two numbers that determine
!    the accuracy of the solution
!
  small = zsmall
  big = zbig
  absstp = zabsst
  relstp = zrelst
  stpmul = zstpmu
  abstol = zabsto
  reltol = zrelto

  return
end
function dlanor ( x )

!*****************************************************************************80
!
!! DLANOR evaluates the logarithm of the asymptotic Normal CDF.
!
!  Discussion:
!
!    This routine computes the logarithm of the cumulative normal distribution
!    from abs ( x ) to infinity for  5 <= abs ( X ).
!
!    The relative error at X = 5 is about 0.5D-5.
!
!  Licensing:
!
!    This code is distributed under the MIT license.
!
!  Modified:
!
!    15 February 2021
!
!  Reference:
!
!    Milton Abramowitz, Irene Stegun,
!    Handbook of Mathematical Functions
!    1966, Formula 26.2.12.
!
!  Parameters:
!
!    Input, real ( kind = rk ) X, the value at which the Normal CDF is to be
!    evaluated.  It is assumed that 5 <= abs ( X ).
!
!    Output, real ( kind = rk ) DLANOR, the logarithm of the asymptotic
!    Normal CDF.
!
  implicit none

  integer, parameter :: rk = kind ( 1.0D+00 )

  real ( kind = rk ) alnrel
  real ( kind = rk ) approx
  real ( kind = rk ), save, dimension ( 0:11 ) :: coef = (/ &
    -1.0D+00,  3.0D+00,  -15.0D+00,  105.0D+00,  -945.0D+00,  &
    10395.0D+00, -135135.0D+00,  2027025.0D+00,  -34459425.0D+00, &
    654729075.0D+00, -13749310575D+00,  316234143225.0D+00 /)
  real ( kind = rk ) correc
  real ( kind = rk ), parameter :: dlsqpi = 0.91893853320467274177D+00
  real ( kind = rk ) eval_pol
  real ( kind = rk ) dlanor
  real ( kind = rk ) x
  real ( kind = rk ) xx
  real ( kind = rk ) xx2

  xx = abs ( x )

  if ( abs ( x ) < 5.0D+00 ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'DLANOR - Fatal error!'
    write ( *, '(a)' ) '  The argument X is too small.'
  end if

  approx = - dlsqpi - 0.5D+00 * x * x - log ( abs ( x ) )

  xx2 = xx * xx
  correc = eval_pol ( coef, 11, 1.0D+00 / xx2 ) / xx2
  correc = alnrel ( correc )

  dlanor = approx + correc

  return
end
function dstrem ( z )

!*****************************************************************************80
!
!! DSTREM computes the Sterling remainder ln ( Gamma ( Z ) ) - Sterling ( Z ).
!
!  Discussion:
!
!    This routine returns
!
!      ln ( Gamma ( Z ) ) - Sterling ( Z )
!
!    where Sterling(Z) is Sterling's approximation to ln ( Gamma ( Z ) ).
!
!    Sterling(Z) = ln ( sqrt ( 2 * PI ) ) + ( Z - 0.5 ) * ln ( Z ) - Z
!
!    If 6 <= Z, the routine uses 9 terms of a series in Bernoulli numbers,
!    with values calculated using Maple.
!
!    Otherwise, the difference is computed explicitly.
!
!  Licensing:
!
!    This code is distributed under the MIT license.
!
!  Modified:
!
!    15 February 2021
!
!  Parameters:
!
!    Input, real ( kind = rk ) Z, the value at which the Sterling
!    remainder is to be calculated.  Z must be positive.
!
!    Output, real ( kind = rk ) DSTREM, the Sterling remainder.
!
  implicit none

  integer, parameter :: rk = kind ( 1.0D+00 )

  integer, parameter :: ncoef = 9

  real ( kind = rk ), parameter, dimension ( 0:ncoef ) :: coef = (/ &
    0.0D+00, &
    0.0833333333333333333333333333333D+00, &
    -0.00277777777777777777777777777778D+00, &
    0.000793650793650793650793650793651D+00, &
    -0.000595238095238095238095238095238D+00, &
    0.000841750841750841750841750841751D+00, &
    -0.00191752691752691752691752691753D+00, &
    0.00641025641025641025641025641026D+00, &
    -0.0295506535947712418300653594771D+00, &
    0.179644372368830573164938490016D+00 /)
  real ( kind = rk ) dstrem
  real ( kind = rk ) eval_pol
  real ( kind = rk ) gamma_log
  real ( kind = rk ), parameter :: hln2pi = 0.91893853320467274178D+00
  real ( kind = rk ) sterl
  real ( kind = rk ) z

  if ( z <= 0.0D+00 ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'DSTREM - Fatal error!'
    write ( *, '(a)' ) '  Zero or negative argument Z.'
    stop
  end if

  if ( 6.0D+00 < z ) then
    dstrem = eval_pol ( coef, ncoef, 1.0D+00 / z**2 ) * z
  else
    sterl = hln2pi + ( z - 0.5D+00 ) * log ( z ) - z
    dstrem = gamma_log ( z ) - sterl
  end if

  return
end
function dt1 ( p, q, df )

!*****************************************************************************80
!
!! DT1 computes an approximate inverse of the cumulative T distribution.
!
!  Discussion:
!
!    This routine returns the inverse of the T distribution function, that is,
!    the integral from 0 to INVT of the T density is P.  This is an
!    initial approximation.
!
!    Thanks to Charles Katholi for pointing out that the RESHAPE
!    function should not use a range in the "SHAPE" field (0:4,4),
!    but simply the number of rows and columns (5,4), JVB, 04 May 2006.
!
!  Licensing:
!
!    This code is distributed under the MIT license.
!
!  Modified:
!
!    15 February 2021
!
!  Parameters:
!
!    Input, real ( kind = rk ) P, Q, the value whose inverse from the
!    T distribution CDF is desired, and the value (1-P).
!
!    Input, real ( kind = rk ) DF, the number of degrees of freedom of the
!    T distribution.
!
!    Output, real ( kind = rk ) DT1, the approximate value of X for which
!    the T density CDF with DF degrees of freedom has value P.
!
  implicit none

  integer, parameter :: rk = kind ( 1.0D+00 )

  real ( kind = rk ), dimension(0:4,4) :: coef = reshape ( (/ &
       1.0D+00,     1.0D+00,    0.0D+00,   0.0D+00,  0.0D+00, &
       3.0D+00,    16.0D+00,    5.0D+00,   0.0D+00,  0.0D+00, &
     -15.0D+00,    17.0D+00,   19.0D+00,   3.0D+00,  0.0D+00, &
    -945.0D+00, -1920.0D+00, 1482.0D+00, 776.0D+00, 79.0D+00/), (/ 5, 4 /) )
  real ( kind = rk ), parameter, dimension ( 4 ) :: denom = (/ &
    4.0D+00, 96.0D+00, 384.0D+00, 92160.0D+00 /)
  real ( kind = rk ) denpow
  real ( kind = rk ) eval_pol
  real ( kind = rk ) df
  real ( kind = rk ) dinvnr
  real ( kind = rk ) dt1
  integer i
  integer, parameter, dimension ( 4 ) :: ideg = (/ 1, 2, 3, 4 /)
  real ( kind = rk ) p
  real ( kind = rk ) q
  real ( kind = rk ) sum1
  real ( kind = rk ) term
  real ( kind = rk ) x
  real ( kind = rk ) xp
  real ( kind = rk ) xx

  x = abs ( dinvnr ( p, q ) )
  xx = x * x

  sum1 = x
  denpow = 1.0D+00
  do i = 1, 4
    term = eval_pol ( coef(0,i), ideg(i), xx ) * x
    denpow = denpow * df
    sum1 = sum1 + term / ( denpow * denom(i) )
  end do

  if ( 0.5D+00 <= p ) then
    xp = sum1
  else
    xp = -sum1
  end if

  dt1 = xp

  return
end
subroutine dzror ( status, x, fx, xlo, xhi, qleft, qhi )

!*****************************************************************************80
!
!! DZROR seeks a zero of a function, using reverse communication.
!
!  Discussion:
!
!    This routine performs the zero finding.  STZROR must have been called
!    before this routine in order to set its parameters.
!
!  Licensing:
!
!    This code is distributed under the MIT license.
!
!  Modified:
!
!    15 February 2021
!
!  Reference:
!
!    JCP Bus, TJ Dekker,
!    Two Efficient Algorithms with Guaranteed Convergence for
!    Finding a Zero of a Function,
!    ACM Transactions on Mathematical Software,
!    Volume 1, Number 4, pages 330-345, 1975.
!
!  Parameters:
!
!    Input/output, integer STATUS.  At the beginning of a zero
!    finding problem, STATUS should be set to 0 and ZROR invoked.  The value
!    of other parameters will be ignored on this call.
!    When ZROR needs the function evaluated, it will set
!    STATUS to 1 and return.  The value of the function
!    should be set in FX and ZROR again called without
!    changing any of its other parameters.
!    When ZROR has finished without error, it will return
!    with STATUS 0.  In that case (XLO,XHI) bound the answe
!    If ZROR finds an error (which implies that F(XLO)-Y an
!    F(XHI)-Y have the same sign, it returns STATUS -1.  In
!    this case, XLO and XHI are undefined.
!
!    Output, real ( kind = rk ) X, the value of X at which F(X) is to
!    be evaluated.
!
!    Input, real ( kind = rk ) FX, the value of F(X), which must be calculated
!    by the user when ZROR has returned on the previous call with STATUS = 1.
!
!    Output, real ( kind = rk ) XLO, XHI, are lower and upper bounds for the
!    solution when ZROR returns with STATUS = 0.
!
!    Output, logical QLEFT,is TRUE if the stepping search terminated
!    unsucessfully at XLO.  If it is FALSE, the search terminated
!    unsucessfully at XHI.
!
!    Output, logical QHI, is TRUE if Y < F(X) at the termination of the
!    search and FALSE if F(X) < Y at the termination of the search.
!
  implicit none

  integer, parameter :: rk = kind ( 1.0D+00 )

  real ( kind = rk ) a
  real ( kind = rk ) abstol
  real ( kind = rk ) b
  real ( kind = rk ) c
  real ( kind = rk ) d
  integer ext
  real ( kind = rk ) fa
  real ( kind = rk ) fb
  real ( kind = rk ) fc
  real ( kind = rk ) fd
  real ( kind = rk ) fda
  real ( kind = rk ) fdb
  logical first
  real ( kind = rk ) ftol
  real ( kind = rk ) fx
  integer i99999
  real ( kind = rk ) m
  real ( kind = rk ) mb
  real ( kind = rk ) p
  real ( kind = rk ) q
  logical qhi
  logical qleft
  logical qrzero
  real ( kind = rk ) reltol
  integer status
  real ( kind = rk ) tol
  real ( kind = rk ) w
  real ( kind = rk ) x
  real ( kind = rk ) xhi
  real ( kind = rk ) xlo
  real ( kind = rk ) :: xxhi = 0.0D+00
  real ( kind = rk ) :: xxlo = 0.0D+00
  real ( kind = rk ) zabstl
  real ( kind = rk ) zreltl
  real ( kind = rk ) zx
  real ( kind = rk ) zxhi
  real ( kind = rk ) zxlo

  save

  ftol(zx) = 0.5D+00 * max ( abstol, reltol * abs ( zx ) )

  if ( 0 < status ) then
    go to 280
  end if

  xlo = xxlo
  xhi = xxhi
  b = xlo
  x = xlo
!
!  GET-function-VALUE
!
  i99999 = 10
  go to 270

10 continue

  fb = fx
  xlo = xhi
  a = xlo
  x = xlo
!
!  GET-function-VALUE
!
  i99999 = 20
  go to 270
!
!  Check that F(ZXLO) < 0 < F(ZXHI)  or F(ZXLO) > 0 > F(ZXHI)
!
20 continue

  if ( fb < 0.0D+00 ) then
    if ( fx < 0.0D+00 ) then
      status = -1
      qleft = ( fx < fb )
      qhi = .false.
      return
    end if
  end if

  if ( 0.0D+00 < fb ) then
    if ( 0.0D+00 < fx ) then
      status = -1
      qleft = ( fb < fx )
      qhi = .true.
      return
    end if
  end if

  fa = fx
  first = .true.

70 continue

  c = a
  fc = fa
  ext = 0

80 continue

  if ( abs ( fc ) < abs ( fb ) ) then

    if ( c == a ) then
      d = a
      fd = fa
    end if

    a = b
    fa = fb
    xlo = c
    b = xlo
    fb = fc
    c = a
    fc = fa

  end if

  tol = ftol ( xlo )
  m = ( c + b ) * 0.5D+00
  mb = m - b

  if ( .not. ( tol < abs ( mb ) ) ) then
    go to 240
  end if

  if ( 3 < ext ) then
    w = mb
    go to 190
  end if

! 110 continue

  tol = sign ( tol, mb )
  p = ( b - a ) * fb
!
!  I had to insert a rudimentary check on the divisions here
!  to avoid ninny errors, JVB, 09 June 2004.
!
  if ( first ) then

    q = fa - fb
    first = .false.

  else

    if ( d == b ) then
      fdb = 1.0D+00
    else
      fdb = ( fd - fb ) / ( d - b )
    end if

    if ( d == a ) then
      fda = 1.0D+00
    else
      fda = ( fd - fa ) / ( d - a )
    end if

    p = fda * p
    q = fdb * fa - fda * fb

  end if

! 130 continue

  if ( p < 0.0D+00 ) then
    p = -p
    q = -q
  end if

!  140 continue

  if ( ext == 3 ) then
    p = p *  2.0D+00
  end if

  if (.not. ( ( p * 1.0D+00 ) == 0.0D+00 .or. p <= ( q * tol ) ) ) then
    go to 150
  end if

  w = tol
  go to 180

  150 continue

  if ( p < mb * q ) then
    w = p / q
  else
    w = mb
  end if

  180 continue
  190 continue

  d = a
  fd = fa
  a = b
  fa = fb
  b = b + w
  xlo = b
  x = xlo
!
!  GET-function-VALUE
!
  i99999 = 200
  go to 270

  200 continue

  fb = fx

  if ( 0.0D+00 <= fc * fb ) then

    go to 70

  else

    if ( w == mb ) then
      ext = 0
    else
      ext = ext + 1
    end if

    go to 80

  end if

  240 continue

  xhi = c
  qrzero = ( 0.0D+00 <= fc .and. fb <= 0.0D+00 ) .or. &
    ( fc < 0.0D+00 .and. fb >= 0.0D+00 )

  if ( qrzero ) then
    status = 0
  else
    status = -1
  end if

  return

entry dstzr ( zxlo, zxhi, zabstl, zreltl )

!*****************************************************************************80
!
!! DSTZR - SeT ZeRo finder - Reverse communication version
!
!  Discussion:
!
!    This routine sets quantities needed by ZROR.  The function of ZROR
!    and the quantities set is given here.
!
!    Given a function F, find XLO such that F(XLO) = 0.
!
!     Input condition. F is a real ( kind = rk ) function of a single
!     real ( kind = rk ) argument and XLO and XHI are such that
!          F(XLO)*F(XHI)  <=  0.0
!
!     If the input condition is met, QRZERO returns .TRUE.
!     and output values of XLO and XHI satisfy the following
!          F(XLO)*F(XHI)  <= 0.
!          ABS ( F(XLO) ) <= ABS ( F(XHI) )
!          ABS ( XLO - XHI ) <= TOL(X)
!     where
!          TOL(X) = MAX ( ABSTOL, RELTOL * ABS ( X ) )
!
!     If this algorithm does not find XLO and XHI satisfying
!     these conditions then QRZERO returns .FALSE.  This
!     implies that the input condition was not met.
!
!  Licensing:
!
!    This code is distributed under the MIT license.
!
!  Modified:
!
!    15 February 2021
!
!  Reference:
!
!    JCP Bus, TJ Dekker,
!    Two Efficient Algorithms with Guaranteed Convergence for
!    Finding a Zero of a Function,
!    ACM Transactions on Mathematical Software,
!    Volume 1, Number 4, pages 330-345, 1975.
!
!  Parameters:
!
!    Input, real ( kind = rk ) XLO, XHI, the left and right endpoints of the
!    interval to be searched for a solution.
!
!    Input, real ( kind = rk ) ABSTOL, RELTOL, two numbers that determine
!    the accuracy of the solution.
!
  xxlo = zxlo
  xxhi = zxhi
  abstol = zabstl
  reltol = zreltl
  return
!
!     TO GET-function-VALUE
!
  270 status = 1
  return

  280 continue

  if ( i99999 == 10 ) then
    go to 10
  else if ( i99999 == 20 ) then
    go to 20
  else if ( i99999 == 200 ) then
    go to 200
  else
    write ( *, '(a)' ) ''
    write ( *, '(a)' ) 'DSTZR - Fatal error!'
    write ( *, '(a)' ) '  Illegal value of I99999.'
    stop 1
  end if

end
subroutine erf_values ( n_data, x, fx )

!*****************************************************************************80
!
!! ERF_VALUES returns some values of the ERF or "error" function.
!
!  Discussion:
!
!    ERF(X) = ( 2 / sqrt ( PI ) * integral ( 0 <= T <= X ) exp ( - T^2 ) dT
!
!  Licensing:
!
!    This code is distributed under the MIT license.
!
!  Modified:
!
!    17 April 2001
!
!  Author:
!
!    John Burkardt
!
!  Reference:
!
!    Milton Abramowitz, Irene Stegun,
!    Handbook of Mathematical Functions,
!    US Department of Commerce, 1964.
!
!  Parameters:
!
!    Input/output, integer N_DATA.  The user sets N_DATA to 0
!    before the first call.  On each call, the routine increments N_DATA by 1,
!    and returns the corresponding data; when there is no more data, the
!    output value of N_DATA will be 0 again.
!
!    Output, real ( kind = rk ) X, the argument of the function.
!
!    Output, real ( kind = rk ) FX, the value of the function.
!
  implicit none

  integer, parameter :: rk = kind ( 1.0D+00 )

  integer, parameter :: n_max = 21

  real ( kind = rk ) fx
  real ( kind = rk ), save, dimension ( n_max ) :: fx_vec = (/ &
    0.0000000000D+00, 0.1124629160D+00, 0.2227025892D+00, 0.3286267595D+00, &
    0.4283923550D+00, 0.5204998778D+00, 0.6038560908D+00, 0.6778011938D+00, &
    0.7421009647D+00, 0.7969082124D+00, 0.8427007929D+00, 0.8802050696D+00, &
    0.9103139782D+00, 0.9340079449D+00, 0.9522851198D+00, 0.9661051465D+00, &
    0.9763483833D+00, 0.9837904586D+00, 0.9890905016D+00, 0.9927904292D+00, &
    0.9953222650D+00 /)
  integer n_data
  real ( kind = rk ) x
  real ( kind = rk ), save, dimension ( n_max ) :: x_vec = (/ &
    0.0D+00, 0.1D+00, 0.2D+00, 0.3D+00, &
    0.4D+00, 0.5D+00, 0.6D+00, 0.7D+00, &
    0.8D+00, 0.9D+00, 1.0D+00, 1.1D+00, &
    1.2D+00, 1.3D+00, 1.4D+00, 1.5D+00, &
    1.6D+00, 1.7D+00, 1.8D+00, 1.9D+00, &
    2.0D+00 /)

  if ( n_data < 0 ) then
    n_data = 0
  end if

  n_data = n_data + 1

  if ( n_max < n_data ) then
    n_data = 0
    x = 0.0D+00
    fx = 0.0D+00
  else
    x = x_vec(n_data)
    fx = fx_vec(n_data)
  end if

  return
end
function error_f ( x )

!*****************************************************************************80
!
!! ERROR_F evaluates the error function.
!
!  Discussion:
!
!    Since some compilers already supply a routine named ERF which evaluates
!    the error function, this routine has been given a distinct, if
!    somewhat unnatural, name.
!
!    The function is defined by:
!
!      ERF(X) = ( 2 / sqrt ( PI ) )
!        * Integral ( 0 <= T <= X ) EXP ( - T^2 ) dT.
!
!    Properties of the function include:
!
!      Limit ( X -> -Infinity ) ERF(X) =          -1.0;
!                               ERF(0) =           0.0;
!                               ERF(0.476936...) = 0.5;
!      Limit ( X -> +Infinity ) ERF(X) =          +1.0.
!
!      0.5 * ( ERF(X/sqrt(2)) + 1 ) = Normal_01_CDF(X)
!
!  Licensing:
!
!    This code is distributed under the MIT license.
!
!  Modified:
!
!    15 February 2021
!
!  Author:
!
!    Armido DiDinato, Alfred Morris
!
!  Reference:
!
!    Armido DiDinato, Alfred Morris,
!    Algorithm 708:
!    Significant Digit Computation of the Incomplete Beta Function Ratios,
!    ACM Transactions on Mathematical Software,
!    Volume 18, 1993, pages 360-373.
!
!  Parameters:
!
!    Input, real ( kind = rk ) X, the argument.
!
!    Output, real ( kind = rk ) ERF, the value of the error function at X.
!
  implicit none

  integer, parameter :: rk = kind ( 1.0D+00 )

  real ( kind = rk ), parameter, dimension ( 5 ) :: a = (/ &
    0.771058495001320D-04, &
    -0.133733772997339D-02, &
    0.323076579225834D-01, &
    0.479137145607681D-01, &
    0.128379167095513D+00 /)
  real ( kind = rk ) ax
  real ( kind = rk ), parameter, dimension ( 3 ) :: b = (/ &
    0.301048631703895D-02, &
    0.538971687740286D-01, &
    0.375795757275549D+00 /)
  real ( kind = rk ) bot
  real ( kind = rk ), parameter :: c = 0.564189583547756D+00
  real ( kind = rk ) error_f
  real ( kind = rk ), dimension ( 8 ) :: p = (/   &
   -1.36864857382717D-07, 5.64195517478974D-01, &
    7.21175825088309D+00, 4.31622272220567D+01, &
    1.52989285046940D+02, 3.39320816734344D+02, &
    4.51918953711873D+02, 3.00459261020162D+02 /)
  real ( kind = rk ), dimension ( 8 ) :: q = (/ &
    1.00000000000000D+00, 1.27827273196294D+01, &
    7.70001529352295D+01, 2.77585444743988D+02, &
    6.38980264465631D+02, 9.31354094850610D+02, &
    7.90950925327898D+02, 3.00459260956983D+02 /)
  real ( kind = rk ), dimension ( 5 ) :: r = (/ &
    2.10144126479064D+00, 2.62370141675169D+01, &
    2.13688200555087D+01, 4.65807828718470D+00, &
    2.82094791773523D-01 /)
  real ( kind = rk ), parameter, dimension ( 4 ) :: s = (/ &
    9.41537750555460D+01, 1.87114811799590D+02, &
    9.90191814623914D+01, 1.80124575948747D+01 /)
  real ( kind = rk ) t
  real ( kind = rk ) top
  real ( kind = rk ) x
  real ( kind = rk ) x2

  ax = abs ( x )

  if ( ax <= 0.5D+00 ) then

    t = x * x

    top = (((( a(1)   * t &
             + a(2) ) * t &
             + a(3) ) * t &
             + a(4) ) * t &
             + a(5) ) + 1.0D+00

    bot = (( b(1) * t + b(2) ) * t + b(3) ) * t + 1.0D+00
    error_f = ax * ( top / bot )

  else if ( ax <= 4.0D+00 ) then

    top = (((((( p(1)   * ax &
               + p(2) ) * ax &
               + p(3) ) * ax &
               + p(4) ) * ax &
               + p(5) ) * ax &
               + p(6) ) * ax &
               + p(7) ) * ax &
               + p(8)

    bot = (((((( q(1) * ax + q(2) ) * ax + q(3) ) * ax + q(4) ) * ax &
      + q(5) ) * ax + q(6) ) * ax + q(7) ) * ax + q(8)

    error_f = 0.5D+00 &
      + ( 0.5D+00 - exp ( - x * x ) * top / bot )

  else if ( ax < 5.8D+00 ) then

    x2 = x * x
    t = 1.0D+00 / x2

    top = ((( r(1) * t + r(2) ) * t + r(3) ) * t + r(4) ) * t + r(5)

    bot = ((( s(1) * t + s(2) ) * t + s(3) ) * t + s(4) ) * t &
      + 1.0D+00

    error_f = ( c - top / ( x2 * bot )) / ax
    error_f = 0.5D+00 &
      + ( 0.5D+00 - exp ( - x2 ) * error_f )

  else

    error_f = 1.0D+00

  end if

  if ( x < 0.0D+00 ) then
    error_f = -error_f
  end if

  return
end
function error_fc ( ind, x )

!*****************************************************************************80
!
!! ERROR_FC evaluates the complementary error function.
!
!  Licensing:
!
!    This code is distributed under the MIT license.
!
!  Modified:
!
!    15 February 2021
!
!  Author:
!
!    Armido DiDinato, Alfred Morris
!
!  Reference:
!
!    Armido DiDinato, Alfred Morris,
!    Algorithm 708:
!    Significant Digit Computation of the Incomplete Beta Function Ratios,
!    ACM Transactions on Mathematical Software,
!    Volume 18, 1993, pages 360-373.
!
!  Parameters:
!
!    Input, integer IND, chooses the scaling.
!    If IND is nonzero, then the value returned has been multiplied by
!    EXP(X*X).
!
!    Input, real ( kind = rk ) X, the argument of the function.
!
!    Output, real ( kind = rk ) ERROR_FC, the value of the complementary
!    error function.
!
  implicit none

  integer, parameter :: rk = kind ( 1.0D+00 )

  real ( kind = rk ), dimension ( 5 ) :: a = (/ &
     0.771058495001320D-04,  -0.133733772997339D-02, &
     0.323076579225834D-01,   0.479137145607681D-01, &
     0.128379167095513D+00 /)
  real ( kind = rk ) ax
  real ( kind = rk ), dimension(3) :: b = (/ &
    0.301048631703895D-02, &
    0.538971687740286D-01, &
    0.375795757275549D+00 /)
  real ( kind = rk ) bot
  real ( kind = rk ), parameter :: c = 0.564189583547756D+00
  real ( kind = rk ) e
  real ( kind = rk ) error_fc
  real ( kind = rk ) exparg
  integer ind
  real ( kind = rk ), dimension ( 8 ) :: p = (/ &
    -1.36864857382717D-07, 5.64195517478974D-01, &
     7.21175825088309D+00, 4.31622272220567D+01, &
     1.52989285046940D+02, 3.39320816734344D+02, &
     4.51918953711873D+02, 3.00459261020162D+02 /)
  real ( kind = rk ), dimension ( 8 ) :: q = (/  &
    1.00000000000000D+00, 1.27827273196294D+01, &
    7.70001529352295D+01, 2.77585444743988D+02, &
    6.38980264465631D+02, 9.31354094850610D+02, &
    7.90950925327898D+02, 3.00459260956983D+02 /)
  real ( kind = rk ), dimension ( 5 ) :: r = (/ &
    2.10144126479064D+00, 2.62370141675169D+01, &
    2.13688200555087D+01, 4.65807828718470D+00, &
    2.82094791773523D-01 /)
  real ( kind = rk ), dimension ( 4 ) :: s = (/ &
    9.41537750555460D+01, 1.87114811799590D+02, &
    9.90191814623914D+01, 1.80124575948747D+01 /)
  real ( kind = rk ) t
  real ( kind = rk ) top
  real ( kind = rk ) w
  real ( kind = rk ) x
!
!  ABS ( X ) <= 0.5
!
  ax = abs ( x )

  if ( ax <= 0.5D+00 ) then

    t = x * x

    top = (((( a(1) * t + a(2) ) * t + a(3) ) * t + a(4) ) * t + a(5) ) &
      + 1.0D+00

    bot = (( b(1) * t + b(2) ) * t + b(3) ) * t + 1.0D+00

    error_fc = 0.5D+00 + ( 0.5D+00 &
      - x * ( top / bot ) )

    if ( ind /= 0 ) then
      error_fc = exp ( t ) * error_fc
    end if

    return

  end if
!
!  0.5 < abs ( X ) <= 4
!
  if ( ax <= 4.0D+00 ) then

    top = (((((( p(1) * ax + p(2)) * ax + p(3)) * ax + p(4)) * ax &
      + p(5)) * ax + p(6)) * ax + p(7)) * ax + p(8)

    bot = (((((( q(1) * ax + q(2)) * ax + q(3)) * ax + q(4)) * ax &
      + q(5)) * ax + q(6)) * ax + q(7)) * ax + q(8)

    error_fc = top / bot
!
!  4 < ABS ( X )
!
  else

    if ( x <= -5.6D+00 ) then

      if ( ind == 0 ) then
        error_fc =  2.0D+00
      else
        error_fc =  2.0D+00  * exp ( x * x )
      end if

      return

    end if

    if ( ind == 0 ) then

      if ( 100.0D+00 < x ) then
        error_fc = 0.0D+00
        return
      end if

      if ( -exparg ( 1 ) < x * x ) then
        error_fc = 0.0D+00
        return
      end if

    end if

    t = ( 1.0D+00 / x )**2

    top = ((( r(1) * t + r(2) ) * t + r(3) ) * t + r(4) ) * t + r(5)

    bot = ((( s(1) * t + s(2) ) * t + s(3) ) * t + s(4) ) * t &
      + 1.0D+00

    error_fc = ( c - t * top / bot ) / ax

  end if
!
!  Final assembly.
!
  if ( ind /= 0 ) then

    if ( x < 0.0D+00 ) then
      error_fc =  2.0D+00  * exp ( x * x ) - error_fc
    end if

  else

    w = x * x
    t = w
    e = w - t
    error_fc = (( 0.5D+00 &
      + ( 0.5D+00 - e ) ) * exp ( - t ) ) * error_fc

    if ( x < 0.0D+00 ) then
      error_fc =  2.0D+00  - error_fc
    end if

  end if

  return
end
function esum ( mu, x )

!*****************************************************************************80
!
!! ESUM evaluates exp ( MU + X ).
!
!  Licensing:
!
!    This code is distributed under the MIT license.
!
!  Modified:
!
!    15 February 2021
!
!  Author:
!
!    Armido DiDinato, Alfred Morris
!
!  Reference:
!
!    Armido DiDinato, Alfred Morris,
!    Algorithm 708:
!    Significant Digit Computation of the Incomplete Beta Function Ratios,
!    ACM Transactions on Mathematical Software,
!    Volume 18, 1993, pages 360-373.
!
!  Input:
!
!    integer MU, part of the argument.
!
!    real ( kind = rk ) X, part of the argument.
!
!  Output:
!
!    real ( kind = rk ) ESUM, the value of exp ( MU + X ).
!
  implicit none

  integer, parameter :: rk = kind ( 1.0D+00 )

  real ( kind = rk ) esum
  integer mu
  real ( kind = rk ) w
  real ( kind = rk ) x

  if ( x <= 0.0D+00 ) then
    if ( 0 <= mu ) then
      w = mu + x
      if ( w <= 0.0D+00 ) then
        esum = exp ( w )
        return
      end if
    end if
  else if ( 0.0D+00 < x ) then
    if ( mu <= 0 ) then
      w = mu + x
      if ( 0.0D+00 <= w ) then
        esum = exp ( w )
        return
      end if
    end if
  end if

  w = mu
  esum = exp ( w ) * exp ( x )

  return
end
function eval_pol ( a, n, x )

!*****************************************************************************80
!
!! EVAL_POL evaluates a polynomial at X.
!
!  Discussion:
!
!    EVAL_POL = A(0) + A(1)*X + ... + A(N)*X^N
!
!  Licensing:
!
!    This code is distributed under the MIT license.
!
!  Modified:
!
!    15 February 2021
!
!  Input:
!
!    real ( kind = rk ) A(0:N), coefficients of the polynomial.
!
!    integer N, length of A.
!
!    real ( kind = rk ) X, the point at which the polynomial
!    is to be evaluated.
!
!  Output:
!
!    real ( kind = rk ) EVAL_POL, the value of the polynomial at X.
!
  implicit none

  integer, parameter :: rk = kind ( 1.0D+00 )

  integer n

  real ( kind = rk ) a(0:n)
  real ( kind = rk ) eval_pol
  integer i
  real ( kind = rk ) term
  real ( kind = rk ) x

  term = a(n)
  do i = n - 1, 0, -1
    term = term * x + a(i)
  end do

  eval_pol = term

  return
end
function exparg ( l )

!*****************************************************************************80
!
!! EXPARG returns the largest or smallest legal argument for EXP.
!
!  Discussion:
!
!    Only an approximate limit for the argument of EXP is desired.
!
!  Licensing:
!
!    This code is distributed under the MIT license.
!
!  Modified:
!
!    15 February 2021
!
!  Author:
!
!    Armido DiDinato, Alfred Morris
!
!  Reference:
!
!    Armido DiDinato, Alfred Morris,
!    Algorithm 708:
!    Significant Digit Computation of the Incomplete Beta Function Ratios,
!    ACM Transactions on Mathematical Software,
!    Volume 18, 1993, pages 360-373.
!
!  Parameters:
!
!    Input, integer L, indicates which limit is desired.
!    If L = 0, then the largest positive argument for EXP is desired.
!    Otherwise, the largest negative argument for EXP for which the
!    result is nonzero is desired.
!
!    Output, real ( kind = rk ) EXPARG, the desired value.
!
  implicit none

  integer, parameter :: rk = kind ( 1.0D+00 )

  integer b
  real ( kind = rk ) exparg
  integer ipmpar
  integer l
  real ( kind = rk ) lnb
  integer m
!
!  Get the arithmetic base.
!
  b = ipmpar(4)
!
!  Compute the logarithm of the arithmetic base.
!
  if ( b == 2 ) then
    lnb = 0.69314718055995D+00
  else if ( b == 8 ) then
    lnb = 2.0794415416798D+00
  else if ( b == 16 ) then
    lnb = 2.7725887222398D+00
  else
    lnb = log ( real ( b, kind = rk ) )
  end if

  if ( l /= 0 ) then
    m = ipmpar(9) - 1
    exparg = 0.99999D+00 * ( m * lnb )
  else
    m = ipmpar(10)
    exparg = 0.99999D+00 * ( m * lnb )
  end if

  return
end
subroutine f_cdf_values ( n_data, a, b, x, fx )

!*****************************************************************************80
!
!! F_CDF_VALUES returns some values of the F CDF test function.
!
!  Discussion:
!
!    The value of F_CDF ( DFN, DFD, X ) can be evaluated in Mathematica by
!    commands like:
!
!      Needs["Statistics`ContinuousDistributions`"]
!      CDF[FRatioDistribution[ DFN, DFD ], X ]
!
!  Licensing:
!
!    This code is distributed under the MIT license.
!
!  Modified:
!
!    11 June 2004
!
!  Author:
!
!    John Burkardt
!
!  Reference:
!
!    Milton Abramowitz, Irene Stegun,
!    Handbook of Mathematical Functions,
!    US Department of Commerce, 1964.
!
!    Stephen Wolfram,
!    The Mathematica Book,
!    Fourth Edition,
!    Wolfram Media / Cambridge University Press, 1999.
!
!  Parameters:
!
!    Input/output, integer N_DATA.  The user sets N_DATA to 0
!    before the first call.  On each call, the routine increments N_DATA by 1,
!    and returns the corresponding data; when there is no more data, the
!    output value of N_DATA will be 0 again.
!
!    Output, integer A, integer B, real ( kind = rk ) X, the
!    arguments of the function.
!
!    Output, real ( kind = rk ) FX, the value of the function.
!
  implicit none

  integer, parameter :: rk = kind ( 1.0D+00 )

  integer, parameter :: n_max = 20

  integer a
  integer, save, dimension ( n_max ) :: a_vec = (/ &
    1, 1, 5, 1, &
    2, 4, 1, 6, &
    8, 1, 3, 6, &
    1, 1, 1, 1, &
    2, 3, 4, 5 /)
  integer b
  integer, save, dimension ( n_max ) :: b_vec = (/ &
     1,  5,  1,  5, &
    10, 20,  5,  6, &
    16,  5, 10, 12, &
     5,  5,  5,  5, &
     5,  5,  5,  5 /)
  real ( kind = rk ) fx
  real ( kind = rk ), save, dimension ( n_max ) :: fx_vec = (/ &
    0.500000D+00, 0.499971D+00, 0.499603D+00, 0.749699D+00, &
    0.750466D+00, 0.751416D+00, 0.899987D+00, 0.899713D+00, &
    0.900285D+00, 0.950025D+00, 0.950057D+00, 0.950193D+00, &
    0.975013D+00, 0.990002D+00, 0.994998D+00, 0.999000D+00, &
    0.568799D+00, 0.535145D+00, 0.514343D+00, 0.500000D+00 /)
  integer n_data
  real ( kind = rk ) x
  real ( kind = rk ), save, dimension ( n_max ) :: x_vec = (/ &
    1.00D+00,  0.528D+00, 1.89D+00,  1.69D+00, &
    1.60D+00,  1.47D+00,  4.06D+00,  3.05D+00, &
    2.09D+00,  6.61D+00,  3.71D+00,  3.00D+00, &
   10.01D+00, 16.26D+00, 22.78D+00, 47.18D+00, &
    1.00D+00,  1.00D+00,  1.00D+00,  1.00D+00 /)

  if ( n_data < 0 ) then
    n_data = 0
  end if

  n_data = n_data + 1

  if ( n_max < n_data ) then
    n_data = 0
    a = 0
    b = 0
    x = 0.0D+00
    fx = 0.0D+00
  else
    a = a_vec(n_data)
    b = b_vec(n_data)
    x = x_vec(n_data)
    fx = fx_vec(n_data)
  end if

  return
end
subroutine f_noncentral_cdf_values ( n_data, a, b, lambda, x, fx )

!*****************************************************************************80
!
!! F_NONCENTRAL_CDF_VALUES returns some values of the F CDF test function.
!
!  Discussion:
!
!    The value of NONCENTRAL_F_CDF ( DFN, DFD, LAMDA, X ) can be evaluated
!    in Mathematica by commands like:
!
!      Needs["Statistics`ContinuousDistributions`"]
!      CDF[NoncentralFRatioDistribution[ DFN, DFD, LAMBDA ], X ]
!
!  Licensing:
!
!    This code is distributed under the MIT license.
!
!  Modified:
!
!    12 June 2004
!
!  Author:
!
!    John Burkardt
!
!  Reference:
!
!    Milton Abramowitz, Irene Stegun,
!    Handbook of Mathematical Functions,
!    US Department of Commerce, 1964.
!
!    Stephen Wolfram,
!    The Mathematica Book,
!    Fourth Edition,
!    Wolfram Media / Cambridge University Press, 1999.
!
!  Parameters:
!
!    Input/output, integer N_DATA.  The user sets N_DATA to 0
!    before the first call.  On each call, the routine increments N_DATA by 1,
!    and returns the corresponding data; when there is no more data, the
!    output value of N_DATA will be 0 again.
!
!    Output, integer A, B, real ( kind = rk ) LAMBDA, the
!    parameters of the function.
!
!    Output, real ( kind = rk ) X, the argument of the function.
!
!    Output, real ( kind = rk ) FX, the value of the function.
!
  implicit none

  integer, parameter :: rk = kind ( 1.0D+00 )

  integer, parameter :: n_max = 22

  integer a
  integer, save, dimension ( n_max ) :: a_vec = (/ &
     1,  1,  1,  1, &
     1,  1,  1,  1, &
     1,  1,  2,  2, &
     3,  3,  4,  4, &
     5,  5,  6,  6, &
     8, 16 /)
  integer b
  integer, save, dimension ( n_max ) :: b_vec = (/ &
     1,  5,  5,  5, &
     5,  5,  5,  5, &
     5,  5,  5, 10, &
     5,  5,  5,  5, &
     1,  5,  6, 12, &
    16,  8 /)
  real ( kind = rk ) fx
  real ( kind = rk ), save, dimension ( n_max ) :: fx_vec = (/ &
    0.500000D+00, 0.636783D+00, 0.584092D+00, 0.323443D+00, &
    0.450119D+00, 0.607888D+00, 0.705928D+00, 0.772178D+00, &
    0.819105D+00, 0.317035D+00, 0.432722D+00, 0.450270D+00, &
    0.426188D+00, 0.337744D+00, 0.422911D+00, 0.692767D+00, &
    0.363217D+00, 0.421005D+00, 0.426667D+00, 0.446402D+00, &
    0.844589D+00, 0.816368D+00 /)
  real ( kind = rk ) lambda
  real ( kind = rk ), save, dimension ( n_max ) :: lambda_vec = (/ &
    0.00D+00,  0.000D+00, 0.25D+00,  1.00D+00, &
    1.00D+00,  1.00D+00,  1.00D+00,  1.00D+00, &
    1.00D+00,  2.00D+00,  1.00D+00,  1.00D+00, &
    1.00D+00,  2.00D+00,  1.00D+00,  1.00D+00, &
    0.00D+00,  1.00D+00,  1.00D+00,  1.00D+00, &
    1.00D+00,  1.00D+00 /)
  integer n_data
  real ( kind = rk ) x
  real ( kind = rk ), save, dimension ( n_max ) :: x_vec = (/ &
    1.00D+00,  1.00D+00, 1.00D+00,  0.50D+00, &
    1.00D+00,  2.00D+00, 3.00D+00,  4.00D+00, &
    5.00D+00,  1.00D+00, 1.00D+00,  1.00D+00, &
    1.00D+00,  1.00D+00, 1.00D+00,  2.00D+00, &
    1.00D+00,  1.00D+00, 1.00D+00,  1.00D+00, &
    2.00D+00,  2.00D+00 /)

  if ( n_data < 0 ) then
    n_data = 0
  end if

  n_data = n_data + 1

  if ( n_max < n_data ) then
    n_data = 0
    a = 0
    b = 0
    lambda = 0.0D+00
    x = 0.0D+00
    fx = 0.0D+00
  else
    a = a_vec(n_data)
    b = b_vec(n_data)
    lambda = lambda_vec(n_data)
    x = x_vec(n_data)
    fx = fx_vec(n_data)
  end if

  return
end
function fpser ( a, b, x, eps )

!*****************************************************************************80
!
!! FPSER evaluates IX(A,B)(X) for very small B.
!
!  Discussion:
!
!    This routine is appropriate for use when
!
!      B < min ( EPS, EPS * A )
!
!    and
!
!      X <= 0.5.
!
!  Licensing:
!
!    This code is distributed under the MIT license.
!
!  Modified:
!
!    15 February 2021
!
!  Author:
!
!    Armido DiDinato, Alfred Morris
!
!  Reference:
!
!    Armido DiDinato, Alfred Morris,
!    Algorithm 708:
!    Significant Digit Computation of the Incomplete Beta Function Ratios,
!    ACM Transactions on Mathematical Software,
!    Volume 18, 1993, pages 360-373.
!
!  Parameters:
!
!    Input, real ( kind = rk ) A, B, parameters of the function.
!
!    Input, real ( kind = rk ) X, the point at which the function is to
!    be evaluated.
!
!    Input, real ( kind = rk ) EPS, a tolerance.
!
!    Output, real ( kind = rk ) FPSER, the value of IX(A,B)(X).
!
  implicit none

  integer, parameter :: rk = kind ( 1.0D+00 )

  real ( kind = rk ) a
  real ( kind = rk ) an
  real ( kind = rk ) b
  real ( kind = rk ) c
  real ( kind = rk ) eps
  real ( kind = rk ) exparg
  real ( kind = rk ) fpser
  real ( kind = rk ) s
  real ( kind = rk ) t
  real ( kind = rk ) tol
  real ( kind = rk ) x

  fpser = 1.0D+00

  if ( 1.0D-03 * eps < a ) then
    fpser = 0.0D+00
    t = a * log ( x )
    if ( t < exparg ( 1 ) ) then
      return
    end if
    fpser = exp ( t )
  end if
!
!  1/B(A,B) = B
!
  fpser = ( b / a ) * fpser
  tol = eps / a
  an = a + 1.0D+00
  t = x
  s = t / an

  do

    an = an + 1.0D+00
    t = x * t
    c = t / an
    s = s + c

    if ( abs ( c ) <= tol ) then
      exit
    end if

  end do

  fpser = fpser * ( 1.0D+00 + a * s )

  return
end
function gam1 ( a )

!*****************************************************************************80
!
!! GAM1 computes 1 / GAMMA(A+1) - 1 for -0.5 <= A <= 1.5
!
!  Licensing:
!
!    This code is distributed under the MIT license.
!
!  Modified:
!
!    15 February 2021
!
!  Author:
!
!    Armido DiDinato, Alfred Morris
!
!  Reference:
!
!    Armido DiDinato, Alfred Morris,
!    Algorithm 708:
!    Significant Digit Computation of the Incomplete Beta Function Ratios,
!    ACM Transactions on Mathematical Software,
!    Volume 18, 1993, pages 360-373.
!
!  Parameters:
!
!    Input, real ( kind = rk ) A, forms the argument of the Gamma function.
!
!    Output, real ( kind = rk ) GAM1, the value of 1 / GAMMA ( A + 1 ) - 1.
!
  implicit none

  integer, parameter :: rk = kind ( 1.0D+00 )

  real ( kind = rk ) a
  real ( kind = rk ) bot
  real ( kind = rk ) d
  real ( kind = rk ) gam1
  real ( kind = rk ), parameter, dimension ( 7 ) :: p = (/ &
     0.577215664901533D+00, -0.409078193005776D+00, &
    -0.230975380857675D+00,  0.597275330452234D-01, &
     0.766968181649490D-02, -0.514889771323592D-02, &
     0.589597428611429D-03 /)
  real ( kind = rk ), dimension ( 5 ) :: q = (/ &
    0.100000000000000D+01, 0.427569613095214D+00, &
    0.158451672430138D+00, 0.261132021441447D-01, &
    0.423244297896961D-02 /)
  real ( kind = rk ), dimension ( 9 ) :: r = (/ &
    -0.422784335098468D+00, -0.771330383816272D+00, &
    -0.244757765222226D+00,  0.118378989872749D+00, &
     0.930357293360349D-03, -0.118290993445146D-01, &
     0.223047661158249D-02,  0.266505979058923D-03, &
    -0.132674909766242D-03 /)
  real ( kind = rk ), parameter :: s1 = 0.273076135303957D+00
  real ( kind = rk ), parameter :: s2 = 0.559398236957378D-01
  real ( kind = rk ) t
  real ( kind = rk ) top
  real ( kind = rk ) w

  d = a - 0.5D+00

  if ( 0.0D+00 < d ) then
    t = d - 0.5D+00
  else
    t = a
  end if

  if ( t == 0.0D+00 ) then

    gam1 = 0.0D+00

  else if ( 0.0D+00 < t ) then

    top = (((((    &
            p(7)   &
      * t + p(6) ) &
      * t + p(5) ) &
      * t + p(4) ) &
      * t + p(3) ) &
      * t + p(2) ) &
      * t + p(1)

    bot = ((( q(5) * t + q(4) ) * t + q(3) ) * t + q(2) ) * t &
      + 1.0D+00

    w = top / bot

    if ( d <= 0.0D+00 ) then
      gam1 = a * w
    else
      gam1 = ( t / a ) * ( ( w - 0.5D+00 ) &
        - 0.5D+00 )
    end if

  else if ( t < 0.0D+00 ) then

    top = (((((((  &
            r(9)   &
      * t + r(8) ) &
      * t + r(7) ) &
      * t + r(6) ) &
      * t + r(5) ) &
      * t + r(4) ) &
      * t + r(3) ) &
      * t + r(2) ) &
      * t + r(1)

    bot = ( s2 * t + s1 ) * t + 1.0D+00
    w = top / bot

    if ( d <= 0.0D+00 ) then
      gam1 = a * ( ( w + 0.5D+00 ) + 0.5D+00 )
    else
      gam1 = t * w / a
    end if

  end if

  return
end
function gamma_user ( a )

!*****************************************************************************80
!
!! gamma_user evaluates the gamma function.
!
!  Licensing:
!
!    This code is distributed under the MIT license.
!
!  Modified:
!
!    15 February 2021
!
!  Author:
!
!    Alfred Morris,
!    Naval Surface Weapons Center,
!    Dahlgren, Virginia.
!
!  Reference:
!
!    Armido DiDinato, Alfred Morris,
!    Algorithm 708:
!    Significant Digit Computation of the Incomplete Beta Function Ratios,
!    ACM Transactions on Mathematical Software,
!    Volume 18, 1993, pages 360-373.
!
!  Parameters:
!
!    Input, real ( kind = rk ) A, the argument of the Gamma function.
!
!    Output, real ( kind = rk ) gamma_user, the value of the Gamma function.
!
  implicit none

  integer, parameter :: rk = kind ( 1.0D+00 )

  real ( kind = rk ) a
  real ( kind = rk ) bot
  real ( kind = rk ), parameter :: d = 0.41893853320467274178D+00
  real ( kind = rk ) exparg
  real ( kind = rk ) g
  real ( kind = rk ) gamma_user
  integer i
  integer j
  real ( kind = rk ) lnx
  integer m
  integer n
  real ( kind = rk ), dimension ( 7 ) :: p = (/ &
    0.539637273585445D-03, 0.261939260042690D-02, &
    0.204493667594920D-01, 0.730981088720487D-01, &
    0.279648642639792D+00, 0.553413866010467D+00, &
    1.0D+00 /)
  real ( kind = rk ), parameter :: pi = 3.1415926535898D+00
  real ( kind = rk ), dimension ( 7 ) :: q = (/ &
    -0.832979206704073D-03,  0.470059485860584D-02, &
     0.225211131035340D-01, -0.170458969313360D+00, &
    -0.567902761974940D-01,  0.113062953091122D+01, &
     1.0D+00 /)
  real ( kind = rk ), parameter :: r1 =  0.820756370353826D-03
  real ( kind = rk ), parameter :: r2 = -0.595156336428591D-03
  real ( kind = rk ), parameter :: r3 =  0.793650663183693D-03
  real ( kind = rk ), parameter :: r4 = -0.277777777770481D-02
  real ( kind = rk ), parameter :: r5 =  0.833333333333333D-01
  real ( kind = rk ) s
  real ( kind = rk ) t
  real ( kind = rk ) top
  real ( kind = rk ) w
  real ( kind = rk ) x
  real ( kind = rk ) z

  gamma_user = 0.0D+00
  x = a

  if ( abs ( a ) < 15.0D+00 ) then
!
!  Evaluation of GAMMA(A) for |A| < 15
!
    t = 1.0D+00
    m = int ( a ) - 1
!
!  Let T be the product of A-J when 2 <= A.
!
    if ( 0 <= m ) then

      do j = 1, m
        x = x - 1.0D+00
        t = x * t
      end do

      x = x - 1.0D+00
!
!  Let T be the product of A+J WHEN A < 1
!
    else

      t = a

      if ( a <= 0.0D+00 ) then

        m = - m - 1

        do j = 1, m
          x = x + 1.0D+00
          t = x * t
        end do

        x = ( x + 0.5D+00 ) + 0.5D+00
        t = x * t
        if ( t == 0.0D+00 ) then
          return
        end if

      end if
!
!  Check if 1/T can overflow.
!
      if ( abs ( t ) < 1.0D-30 ) then
        if ( 1.0001D+00 < abs ( t ) * huge ( t ) ) then
          gamma_user = 1.0D+00 / t
        end if
        return
      end if

    end if
!
!  Compute Gamma(1 + X) for 0 <= X < 1.
!
    top = p(1)
    bot = q(1)
    do i = 2, 7
      top = top * x + p(i)
      bot = bot * x + q(i)
    end do

    gamma_user = top / bot
!
!  Termination.
!
    if ( 1.0D+00 <= a ) then
      gamma_user = gamma_user * t
    else
      gamma_user = gamma_user / t
    end if
!
!  Evaluation of Gamma(A) FOR 15 <= ABS ( A ).
!
  else

    if ( 1000.0D+00 <= abs ( a ) ) then
      return
    end if

    if ( a <= 0.0D+00 ) then

      x = -a
      n = int ( x )
       t = x - n

      if ( 0.9D+00 < t ) then
        t = 1.0D+00 - t
      end if

      s = sin ( pi * t ) / pi

      if ( mod ( n, 2 ) == 0 ) then
        s = -s
      end if

      if ( s == 0.0D+00 ) then
        return
      end if

    end if
!
!  Compute the modified asymptotic sum.
!
    t = 1.0D+00 / ( x * x )

    g = (((( r1 * t + r2 ) * t + r3 ) * t + r4 ) * t + r5 ) / x

    lnx = log ( x )
!
!  Final assembly.
!
    z = x
    g = ( d + g ) + ( z - 0.5D+00 ) &
      * ( lnx - 1.0D+00 )
    w = g
    t = g - real ( w, kind = rk )

    if ( 0.99999D+00 * exparg ( 0 ) < w ) then
      return
    end if

    gamma_user = exp ( w )* ( 1.0D+00 + t )

    if ( a < 0.0D+00 ) then
      gamma_user = ( 1.0D+00 / ( gamma_user * s ) ) / x
    end if

  end if

  return
end
subroutine gamma_inc ( a, x, ans, qans, ind )

!*****************************************************************************80
!
!! GAMMA_INC evaluates the incomplete gamma ratio functions P(A,X) and Q(A,X).
!
!  Licensing:
!
!    This code is distributed under the MIT license.
!
!  Modified:
!
!    15 February 2021
!
!  Author:
!
!    Alfred Morris
!
!  Parameters:
!
!    Input, real ( kind = rk ) A, X, the arguments of the incomplete
!    gamma ratio.  A and X must be nonnegative.  A and X cannot
!    both be zero.
!
!    Output, real ( kind = rk ) ANS, QANS.  On normal output,
!    ANS = P(A,X) and QANS = Q(A,X).  However, ANS is set to 2 if
!    A or X is negative, or both are 0, or when the answer is
!    computationally indeterminate because A is extremely large
!    and X is very close to A.
!
!    Input, integer IND, indicates the accuracy request:
!    0, as much accuracy as possible.
!    1, to within 1 unit of the 6-th significant digit,
!    otherwise, to within 1 unit of the 3rd significant digit.
!
!  Local:
!
!     ALOG10 = LN(10)
!     RT2PIN = 1/SQRT(2*PI)
!     RTPI   = SQRT(PI)
!
  implicit none

  integer, parameter :: rk = kind ( 1.0D+00 )

  real ( kind = rk ) a
  real ( kind = rk ) a2n
  real ( kind = rk ) a2nm1
  real ( kind = rk ) acc
  real ( kind = rk ), dimension ( 3 ) :: acc0 = (/ &
    5.0D-15, 5.0D-07, 5.0D-04 /)
  real ( kind = rk ), parameter :: alog10 = 2.30258509299405D+00
  real ( kind = rk ) am0
  real ( kind = rk ) amn
  real ( kind = rk ) an
  real ( kind = rk ) an0
  real ( kind = rk ) ans
  real ( kind = rk ) apn
  real ( kind = rk ) b2n
  real ( kind = rk ) b2nm1
  real ( kind = rk ) big(3)
  real ( kind = rk ) c
  real ( kind = rk ) c0
  real ( kind = rk ) c1
  real ( kind = rk ) c2
  real ( kind = rk ) c3
  real ( kind = rk ) c4
  real ( kind = rk ) c5
  real ( kind = rk ) c6
  real ( kind = rk ) cma
  real ( kind = rk ) d0(13)
  real ( kind = rk ) d1(12)
  real ( kind = rk ) d2(10)
  real ( kind = rk ) d3(8)
  real ( kind = rk ) d4(6)
  real ( kind = rk ) d5(4)
  real ( kind = rk ) d6(2)
  real ( kind = rk ) d10
  real ( kind = rk ) d20
  real ( kind = rk ) d30
  real ( kind = rk ) d40
  real ( kind = rk ) d50
  real ( kind = rk ) d60
  real ( kind = rk ) d70
  real ( kind = rk ) e
  real ( kind = rk ) e0
  real ( kind = rk ) e00(3)
  real ( kind = rk ) error_f
  real ( kind = rk ) error_fc
  real ( kind = rk ) g
  real ( kind = rk ) gam1
  real ( kind = rk ) gamma
  real ( kind = rk ) h
  integer i
  integer ind
  integer iop
  real ( kind = rk ) j
  real ( kind = rk ) l
  integer m
  integer n
  integer n_max
  real ( kind = rk ) qans
  real ( kind = rk ) r
  real ( kind = rk ) rexp
  real ( kind = rk ) rlog
  real ( kind = rk ), parameter :: rt2pin = 0.398942280401433D+00
  real ( kind = rk ) rta
  real ( kind = rk ), parameter :: rtpi = 1.77245385090552D+00
  real ( kind = rk ) rtx
  real ( kind = rk ) s
  real ( kind = rk ) sum1
  real ( kind = rk ) t
  real ( kind = rk ) t1
  real ( kind = rk ) tol
  real ( kind = rk ) twoa
  real ( kind = rk ) u
  real ( kind = rk ) w
  real ( kind = rk ) wk(20)
  real ( kind = rk ) x
  real ( kind = rk ) x0
  real ( kind = rk ) x00(3)
  real ( kind = rk ) y
  real ( kind = rk ) z

  data big(1)/20.0D+00/,big(2)/14.0D+00/,big(3)/10.0D+00/
  data e00(1)/0.25D-03/,e00(2)/0.25D-01/,e00(3)/0.14D+00/
  data x00(1)/31.0D+00/,x00(2)/17.0D+00/,x00(3)/9.7D+00/
  data d0(1)/0.833333333333333D-01/
  data d0(2)/-0.148148148148148D-01/
  data d0(3)/0.115740740740741D-02/,d0(4)/0.352733686067019D-03/
  data d0(5)/-0.178755144032922D-03/,d0(6)/0.391926317852244D-04/
  data d0(7)/-0.218544851067999D-05/,d0(8)/-0.185406221071516D-05/
  data d0(9)/0.829671134095309D-06/,d0(10)/-0.176659527368261D-06/
  data d0(11)/0.670785354340150D-08/,d0(12)/0.102618097842403D-07/
  data d0(13)/-0.438203601845335D-08/
  data d10/-0.185185185185185D-02/,d1(1)/-0.347222222222222D-02/
  data d1(2)/0.264550264550265D-02/,d1(3)/-0.990226337448560D-03/
  data d1(4)/0.205761316872428D-03/,d1(5)/-0.401877572016461D-06/
  data d1(6)/-0.180985503344900D-04/,d1(7)/0.764916091608111D-05/
  data d1(8)/-0.161209008945634D-05/,d1(9)/0.464712780280743D-08/
  data d1(10)/0.137863344691572D-06/,d1(11)/-0.575254560351770D-07/
  data d1(12)/0.119516285997781D-07/
  data d20/0.413359788359788D-02/,d2(1)/-0.268132716049383D-02/
  data d2(2)/0.771604938271605D-03/,d2(3)/0.200938786008230D-05/
  data d2(4)/-0.107366532263652D-03/,d2(5)/0.529234488291201D-04/
  data d2(6)/-0.127606351886187D-04/,d2(7)/0.342357873409614D-07/
  data d2(8)/0.137219573090629D-05/,d2(9)/-0.629899213838006D-06/
  data d2(10)/0.142806142060642D-06/
  data d30/0.649434156378601D-03/,d3(1)/0.229472093621399D-03/
  data d3(2)/-0.469189494395256D-03/,d3(3)/0.267720632062839D-03/
  data d3(4)/-0.756180167188398D-04/,d3(5)/-0.239650511386730D-06/
  data d3(6)/0.110826541153473D-04/,d3(7)/-0.567495282699160D-05/
  data d3(8)/0.142309007324359D-05/
  data d40/-0.861888290916712D-03/,d4(1)/0.784039221720067D-03/
  data d4(2)/-0.299072480303190D-03/,d4(3)/-0.146384525788434D-05/
  data d4(4)/0.664149821546512D-04/,d4(5)/-0.396836504717943D-04/
  data d4(6)/0.113757269706784D-04/
  data d50/-0.336798553366358D-03/,d5(1)/-0.697281375836586D-04/
  data d5(2)/0.277275324495939D-03/,d5(3)/-0.199325705161888D-03/
  data d5(4)/0.679778047793721D-04/
  data d60/0.531307936463992D-03/,d6(1)/-0.592166437353694D-03/
  data d6(2)/0.270878209671804D-03/
  data d70 / 0.344367606892378D-03/

  e = epsilon ( 1.0D+00 )

  if ( a < 0.0D+00 .or. x < 0.0D+00 ) then
    ans = 2.0D+00
    return
  end if

  if ( a == 0.0D+00 .and. x == 0.0D+00 ) then
    ans = 2.0D+00
    return
  end if

  if ( a * x == 0.0D+00 ) then
    if ( x <= a ) then
      ans = 0.0D+00
      qans = 1.0D+00
    else
      ans = 1.0D+00
      qans = 0.0D+00
    end if
    return
  end if

  iop = ind + 1
  if ( iop /= 1 .and. iop /= 2 ) iop = 3
  acc = max ( acc0(iop), e )
  e0 = e00(iop)
  x0 = x00(iop)
!
!  Select the appropriate algorithm.
!
  if ( 1.0D+00 <= a ) then
    go to 10
  end if

  if ( a == 0.5D+00 ) then
    go to 390
  end if

  if ( x < 1.1D+00 ) then
    go to 160
  end if

  t1 = a * log ( x ) - x
  u = a * exp ( t1 )

  if ( u == 0.0D+00 ) then
    ans = 1.0D+00
    qans = 0.0D+00
    return
  end if

  r = u * ( 1.0D+00 + gam1 ( a ) )
  go to 250

   10 continue

  if ( big(iop) <= a ) then
    go to 30
  end if

  if ( x < a .or. x0 <= x ) then
    go to 20
  end if

  twoa = a + a
  m = int ( twoa )

  if ( twoa == real ( m, kind = rk ) ) then
    i = m / 2
    if ( a == real ( i, kind = rk ) ) then
      go to 210
    end if
    go to 220
  end if

   20 continue

  t1 = a * log ( x ) - x
  r = exp ( t1 ) / gamma ( a )
  go to 40

   30 continue

  l = x / a

  if ( l == 0.0D+00 ) then
    ans = 0.0D+00
    qans = 1.0D+00
    return
  end if

  s = 0.5D+00 + ( 0.5D+00 - l )
  z = rlog ( l )
  if ( 700.0D+00 / a <= z ) then
    go to 410
  end if

  y = a * z
  rta = sqrt ( a )

  if ( abs ( s ) <= e0 / rta ) then
    go to 330
  end if

  if ( abs ( s ) <= 0.4D+00 ) then
    go to 270
  end if

  t = ( 1.0D+00 / a )**2
  t1 = ((( 0.75D+00 * t - 1.0D+00 ) * t + 3.5D+00 ) &
    * t - 105.0D+00 ) / ( a * 1260.0D+00 )
  t1 = t1 - y
  r = rt2pin * rta * exp ( t1 )

40    continue

  if ( r == 0.0D+00 ) then
    if ( x <= a ) then
      ans = 0.0D+00
      qans = 1.0D+00
    else
      ans = 1.0D+00
      qans = 0.0D+00
    end if
    return
  end if

  if ( x <= max ( a, alog10 ) ) then
    go to 50
  end if

  if ( x < x0 ) then
    go to 250
  end if

  go to 100
!
!  Taylor series for P/R.
!
50    continue

  apn = a + 1.0D+00
  t = x / apn
  wk(1) = t

  n = 20

  do i = 2, 20
    apn = apn + 1.0D+00
    t = t * ( x / apn )
    if ( t <= 1.0D-03 ) then
      n = i
      exit
    end if
    wk(i) = t
  end do

  sum1 = t

  tol = 0.5D+00 * acc

  do

    apn = apn + 1.0D+00
    t = t * ( x / apn )
    sum1 = sum1 + t

    if ( t <= tol ) then
      exit
    end if

  end do

  n_max = n - 1
  do m = 1, n_max
    n = n - 1
    sum1 = sum1 + wk(n)
  end do

  ans = ( r / a ) * ( 1.0D+00 + sum1 )
  qans = 0.5D+00 + ( 0.5D+00 - ans )
  return
!
!  Asymptotic expansion.
!
  100 continue

  amn = a - 1.0D+00
  t = amn / x
  wk(1) = t

  n = 20

  do i = 2, 20
    amn = amn - 1.0D+00
    t = t * ( amn / x )
    if ( abs ( t ) <= 1.0D-03 ) then
      n = i
      exit
    end if
    wk(i) = t
  end do

  sum1 = t

  do

    if ( abs ( t ) <= acc ) then
      exit
    end if

    amn = amn - 1.0D+00
    t = t * ( amn / x )
    sum1 = sum1 + t

  end do

  n_max = n - 1
  do m = 1, n_max
    n = n - 1
    sum1 = sum1 + wk(n)
  end do
  qans = ( r / x ) * ( 1.0D+00 + sum1 )
  ans = 0.5D+00 + ( 0.5D+00 - qans )
  return
!
!  Taylor series for P(A,X)/X^A
!
  160 continue

  an = 3.0D+00
  c = x
  sum1 = x / ( a + 3.0D+00 )
  tol = 3.0D+00 * acc / ( a + 1.0D+00 )

  do

    an = an + 1.0D+00
    c = -c * ( x / an )
    t = c / ( a + an )
    sum1 = sum1 + t

    if ( abs ( t ) <= tol ) then
      exit
    end if

  end do

  j = a * x * ( ( sum1 / 6.0D+00 - 0.5D+00 / &
    ( a +  2.0D+00  ) ) * x + 1.0D+00 &
    / ( a + 1.0D+00 ) )

  z = a * log ( x )
  h = gam1 ( a )
  g = 1.0D+00 + h

  if ( x < 0.25D+00 ) then
    go to 180
  end if

  if ( a < x / 2.59D+00 ) then
    go to 200
  end if

  go to 190

  180 continue

  if ( -0.13394D+00 < z ) then
    go to 200
  end if

  190 continue

  w = exp ( z )
  ans = w * g * ( 0.5D+00 + ( 0.5D+00 - j ))
  qans = 0.5D+00 + ( 0.5D+00 - ans )
  return

200   continue

  l = rexp ( z )
  w = 0.5D+00 + ( 0.5D+00 + l )
  qans = ( w * j - l ) * g - h

  if ( qans < 0.0D+00 ) then
    ans = 1.0D+00
    qans = 0.0D+00
    return
  end if

  ans = 0.5D+00 + ( 0.5D+00 - qans )
  return
!
!  Finite sums for Q when 1 <= A and 2*A is an integer.
!
210   continue

  sum1 = exp ( - x )
  t = sum1
  n = 1
  c = 0.0D+00
  go to 230

220   continue

  rtx = sqrt ( x )
  sum1 = error_fc ( 0, rtx )
  t = exp ( -x ) / ( rtpi * rtx )
  n = 0
  c = -0.5D+00

  230 continue

  do while ( n /= i )
    n = n + 1
    c = c + 1.0D+00
    t = ( x * t ) / c
    sum1 = sum1 + t
  end do

  qans = sum1
  ans = 0.5D+00 + ( 0.5D+00 - qans )
  return
!
!  Continued fraction expansion.
!
250   continue

  tol = max ( 5.0D+00 * e, acc )
  a2nm1 = 1.0D+00
  a2n = 1.0D+00
  b2nm1 = x
  b2n = x + ( 1.0D+00 - a )
  c = 1.0D+00

  do

    a2nm1 = x * a2n + c * a2nm1
    b2nm1 = x * b2n + c * b2nm1
    am0 = a2nm1 / b2nm1
    c = c + 1.0D+00
    cma = c - a
    a2n = a2nm1 + cma * a2n
    b2n = b2nm1 + cma * b2n
    an0 = a2n / b2n

    if ( abs ( an0 - am0 ) < tol * an0 ) then
      exit
    end if

  end do

  qans = r * an0
  ans = 0.5D+00 + ( 0.5D+00 - qans )
  return
!
!  General Temme expansion.
!
270   continue

  if ( abs ( s ) <= 2.0D+00 * e .and. 3.28D-03 < a * e * e ) then
    ans =  2.0D+00
    return
  end if

  c = exp ( - y )
  w = 0.5D+00 * error_fc ( 1, sqrt ( y ) )
  u = 1.0D+00 / a
  z = sqrt ( z + z )

  if ( l < 1.0D+00 ) then
    z = -z
  end if

  if ( iop < 2 ) then

    if ( abs ( s ) <= 1.0D-03 ) then

      c0 = ((((((     &
              d0(7)   &
        * z + d0(6) ) &
        * z + d0(5) ) &
        * z + d0(4) ) &
        * z + d0(3) ) &
        * z + d0(2) ) &
        * z + d0(1) ) &
        * z - 1.0D+00 / 3.0D+00

      c1 = (((((      &
              d1(6)   &
        * z + d1(5) ) &
        * z + d1(4) ) &
        * z + d1(3) ) &
        * z + d1(2) ) &
        * z + d1(1) ) &
        * z + d10

      c2 = ((((d2(5)*z+d2(4))*z+d2(3))*z+d2(2))*z+d2(1))*z + d20

      c3 = (((d3(4)*z+d3(3))*z+d3(2))*z+d3(1))*z + d30

      c4 = ( d4(2) * z + d4(1) ) * z + d40
      c5 = ( d5(2) * z + d5(1) ) * z + d50
      c6 = d6(1) * z + d60

      t = (((((( d70 &
        * u + c6 ) &
        * u + c5 ) &
        * u + c4 ) &
        * u + c3 ) &
        * u + c2 ) &
        * u + c1 ) &
        * u + c0

    else

      c0 = (((((((((((( &
              d0(13)   &
        * z + d0(12) ) &
        * z + d0(11) ) &
        * z + d0(10) ) &
        * z + d0(9)  ) &
        * z + d0(8)  ) &
        * z + d0(7)  ) &
        * z + d0(6)  ) &
        * z + d0(5)  ) &
        * z + d0(4)  ) &
        * z + d0(3)  ) &
        * z + d0(2)  ) &
        * z + d0(1)  ) &
        * z - 1.0D+00 / 3.0D+00

      c1 = ((((((((((( &
                d1(12) &
          * z + d1(11) &
        ) * z + d1(10) &
        ) * z + d1(9)  &
        ) * z + d1(8)  &
        ) * z + d1(7)  &
        ) * z + d1(6)  &
        ) * z + d1(5)  &
        ) * z + d1(4)  &
        ) * z + d1(3)  &
        ) * z + d1(2)  &
        ) * z + d1(1)  &
        ) * z + d10

      c2 = ((((((((( &
                d2(10) &
          * z + d2(9) &
        ) * z + d2(8) &
        ) * z + d2(7) &
        ) * z + d2(6) &
        ) * z + d2(5) &
        ) * z + d2(4) &
        ) * z + d2(3) &
        ) * z + d2(2) &
        ) * z + d2(1) &
        ) * z + d20

      c3 = ((((((( &
                d3(8) &
          * z + d3(7) &
        ) * z + d3(6) &
        ) * z + d3(5) &
        ) * z + d3(4) &
        ) * z + d3(3) &
        ) * z + d3(2) &
        ) * z + d3(1) &
        ) * z + d30

      c4 = ((((( d4(6)*z+d4(5))*z+d4(4))*z+d4(3))*z+d4(2))*z+d4(1))*z + d40

      c5 = (((d5(4)*z+d5(3))*z+d5(2))*z+d5(1))*z + d50

      c6 = ( d6(2) * z + d6(1) ) * z + d60

      t = ((((((   &
            d70    &
        * u + c6 ) &
        * u + c5 ) &
        * u + c4 ) &
        * u + c3 ) &
        * u + c2 ) &
        * u + c1 ) &
        * u + c0

    end if

  else if ( iop == 2 ) then

    c0 = (((((      &
            d0(6)   &
      * z + d0(5) ) &
      * z + d0(4) ) &
      * z + d0(3) ) &
      * z + d0(2) ) &
      * z + d0(1) ) &
      * z - 1.0D+00 / 3.0D+00

    c1 = ((( d1(4) * z + d1(3) ) * z + d1(2) ) * z + d1(1) ) * z + d10
    c2 = d2(1) * z + d20
    t = ( c2 * u + c1 ) * u + c0

  else if ( 2 < iop ) then

    t = (( d0(3) * z + d0(2) ) * z + d0(1) ) * z - 1.0D+00 / 3.0D+00

  end if

310   continue

  if ( 1.0D+00 <= l ) then
    qans = c * ( w + rt2pin * t / rta )
    ans = 0.5D+00 + ( 0.5D+00 - qans )
  else
    ans = c * ( w - rt2pin * t / rta )
    qans = 0.5D+00 + ( 0.5D+00 - ans )
  end if

  return
!
!  Temme expansion for L = 1
!
  330 continue

  if ( 3.28D-03 < a * e * e ) then
    ans =  2.0D+00
    return
  end if

  c = 0.5D+00 + ( 0.5D+00 - y )
  w = ( 0.5D+00 - sqrt ( y ) &
    * ( 0.5D+00 &
    + ( 0.5D+00 - y / 3.0D+00 ) ) / rtpi ) / c
  u = 1.0D+00 / a
  z = sqrt ( z + z )

  if ( l < 1.0D+00 ) then
    z = -z
  end if

  if ( iop < 2 ) then

    c0 = ((((((     &
            d0(7)   &
      * z + d0(6) ) &
      * z + d0(5) ) &
      * z + d0(4) ) &
      * z + d0(3) ) &
      * z + d0(2) ) &
      * z + d0(1) ) &
      * z - 1.0D+00 / 3.0D+00

    c1 = (((((      &
            d1(6)   &
      * z + d1(5) ) &
      * z + d1(4) ) &
      * z + d1(3) ) &
      * z + d1(2) ) &
      * z + d1(1) ) &
      * z + d10

    c2 = ((((d2(5)*z+d2(4))*z+d2(3))*z+d2(2))*z+d2(1))*z + d20

    c3 = (((d3(4)*z+d3(3))*z+d3(2))*z+d3(1))*z + d30

    c4 = ( d4(2) * z + d4(1) ) * z + d40
    c5 = ( d5(2) * z + d5(1) ) * z + d50
    c6 = d6(1) * z + d60

    t = (((((( d70 &
      * u + c6 ) &
      * u + c5 ) &
      * u + c4 ) &
      * u + c3 ) &
      * u + c2 ) &
      * u + c1 ) &
      * u + c0

  else if ( iop == 2 ) then

    c0 = ( d0(2) * z + d0(1) ) * z - 1.0D+00 / 3.0D+00
    c1 = d1(1) * z + d10
    t = ( d20 * u + c1 ) * u + c0

  else if ( 2 < iop ) then

    t = d0(1) * z - 1.0D+00 / 3.0D+00

  end if

  go to 310
!
!  Special cases
!
  390 continue

  if ( x < 0.25D+00 ) then
    ans = error_f ( sqrt ( x ) )
    qans = 0.5D+00 + ( 0.5D+00 - ans )
  else
    qans = error_fc ( 0, sqrt ( x ) )
    ans = 0.5D+00 + ( 0.5D+00 - qans )
  end if

  return

  410 continue

  if ( abs ( s ) <= 2.0D+00 * e ) then
    ans =  2.0D+00
    return
  end if

  if ( x <= a ) then
    ans = 0.0D+00
    qans = 1.0D+00
  else
    ans = 1.0D+00
    qans = 0.0D+00
  end if

  return
end
subroutine gamma_inc_inv ( a, x, x0, p, q, ierr )

!*****************************************************************************80
!
!! GAMMA_INC_INV computes the inverse incomplete gamma ratio function.
!
!  Discussion:
!
!    The routine is given positive A, and nonnegative P and Q where P + Q = 1.
!    The value X is computed with the property that P(A,X) = P and Q(A,X) = Q.
!    Schroder iteration is employed.  The routine attempts to compute X
!    to 10 significant digits if this is possible for the particular computer
!    arithmetic being used.
!
!  Licensing:
!
!    This code is distributed under the MIT license.
!
!  Modified:
!
!    15 February 2021
!
!  Author:
!
!    Alfred Morris
!
!  Parameters:
!
!    Input, real ( kind = rk ) A, the parameter in the incomplete gamma
!    ratio.  A must be positive.
!
!    Output, real ( kind = rk ) X, the computed point for which the
!    incomplete gamma functions have the values P and Q.
!
!    Input, real ( kind = rk ) X0, an optional initial approximation
!    for the solution X.  If the user does not want to supply an
!    initial approximation, then X0 should be set to 0, or a negative
!    value.
!
!    Input, real ( kind = rk ) P, Q, the values of the incomplete gamma
!    functions, for which the corresponding argument is desired.
!
!    Output, integer IERR, error flag.
!    0, the solution was obtained. Iteration was not used.
!    0 < K, The solution was obtained. IERR iterations were performed.
!    -2, A <= 0
!    -3, No solution was obtained. The ratio Q/A is too large.
!    -4, P + Q /= 1
!    -6, 20 iterations were performed. The most recent value obtained
!        for X is given.  This cannot occur if X0 <= 0.
!    -7, Iteration failed. No value is given for X.
!        This may occur when X is approximately 0.
!    -8, A value for X has been obtained, but the routine is not certain
!        of its accuracy.  Iteration cannot be performed in this
!        case. If X0 <= 0, this can occur only when P or Q is
!        approximately 0. If X0 is positive then this can occur when A is
!        exceedingly close to X and A is extremely large (say A .GE. 1.E20).
!
  implicit none

  integer, parameter :: rk = kind ( 1.0D+00 )

  real ( kind = rk ) a
  real ( kind = rk ), parameter :: a0 = 3.31125922108741D+00
  real ( kind = rk ), parameter :: a1 = 11.6616720288968D+00
  real ( kind = rk ), parameter :: a2 = 4.28342155967104D+00
  real ( kind = rk ), parameter :: a3 = 0.213623493715853D+00
  real ( kind = rk ) alnrel
  real ( kind = rk ) am1
  real ( kind = rk ) amax
  real ( kind = rk ), dimension(2) :: amin = (/ &
    500.0D+00, 100.0D+00 /)
  real ( kind = rk ) ap1
  real ( kind = rk ) ap2
  real ( kind = rk ) ap3
  real ( kind = rk ) apn
  real ( kind = rk ) b
  real ( kind = rk ), parameter :: b1 = 6.61053765625462D+00
  real ( kind = rk ), parameter :: b2 = 6.40691597760039D+00
  real ( kind = rk ), parameter :: b3 = 1.27364489782223D+00
  real ( kind = rk ), parameter :: b4 = .036117081018842D+00
  real ( kind = rk ), dimension ( 2 ) :: bmin = (/ &
    1.0D-28, 1.0D-13 /)
  real ( kind = rk ), parameter :: c = 0.577215664901533D+00
  real ( kind = rk ) c1
  real ( kind = rk ) c2
  real ( kind = rk ) c3
  real ( kind = rk ) c4
  real ( kind = rk ) c5
  real ( kind = rk ) d
  real ( kind = rk ), dimension ( 2 ) :: dmin = (/ &
    1.0D-06, 1.0D-04 /)
  real ( kind = rk ) e
  real ( kind = rk ) e2
  real ( kind = rk ), dimension ( 2 ) :: emin = (/ &
    2.0D-03, 6.0D-03 /)
  real ( kind = rk ) eps
  real ( kind = rk ), dimension ( 2 ) :: eps0 = (/ &
    1.0D-10, 1.0D-08 /)
  real ( kind = rk ) g
  real ( kind = rk ) gamma_log
  real ( kind = rk ) gamma_ln1
  real ( kind = rk ) gamma
  real ( kind = rk ) h
  real ( kind = rk ), parameter :: half = 0.5D+00
  integer ierr
  integer iop
  real ( kind = rk ), parameter :: ln10 = 2.302585D+00
  real ( kind = rk ) p
  real ( kind = rk ) pn
  real ( kind = rk ) q
  real ( kind = rk ) qg
  real ( kind = rk ) qn
  real ( kind = rk ) r
  real ( kind = rk ) rcomp
  real ( kind = rk ) rta
  real ( kind = rk ) s
  real ( kind = rk ) s2
  real ( kind = rk ) sum1
  real ( kind = rk ) t
  real ( kind = rk ), parameter :: tol = 1.0D-05
  real ( kind = rk ), parameter :: two =  2.0D+00
  real ( kind = rk ) u
  real ( kind = rk ) w
  real ( kind = rk ) x
  real ( kind = rk ) x0
  real ( kind = rk ) xn
  real ( kind = rk ) y
  real ( kind = rk ) z

  e = epsilon ( e )

  x = 0.0D+00

  if ( a <= 0.0D+00 ) then
    ierr = -2
    return
  end if

  t = p + q - 1.0D+00

  if ( e < abs ( t ) ) then
    ierr = -4
    return
  end if

  ierr = 0

  if ( p == 0.0D+00 ) then
    return
  end if

  if ( q == 0.0D+00 ) then
    x = huge ( x )
    return
  end if

  if ( a == 1.0D+00 ) then
    if ( 0.9D+00 <= q ) then
      x = -alnrel ( - p )
    else
      x = -log ( q )
    end if
    return
  end if

  e2 = two * e
  amax = 0.4D-10 / ( e * e )

  if ( 1.0D-10 < e ) then
    iop = 2
  else
    iop = 1
  end if

  eps = eps0(iop)
  xn = x0

  if ( 0.0D+00 < x0 ) then
    go to 160
  end if
!
!  Selection of the initial approximation XN of X when A < 1.
!
  if ( 1.0D+00 < a ) then
    go to 80
  end if

  g = gamma ( a + 1.0D+00 )
  qg = q * g

  if ( qg == 0.0D+00 ) then
    x = huge ( x )
    ierr = -8
    return
  end if

  b = qg / a

  if ( 0.6D+00 * a < qg ) then
    go to 40
  end if

  if ( a < 0.30D+00 .and. 0.35D+00 <= b ) then
    t = exp ( - ( b + c ) )
    u = t * exp ( t )
    xn = t * exp ( u )
    go to 160
  end if

  if ( 0.45D+00 <= b ) then
    go to 40
  end if

  if ( b == 0.0D+00 ) then
    x = huge ( x )
    ierr = -8
    return
  end if

  y = -log ( b )
  s = half + ( half - a )
  z = log ( y )
  t = y - s * z

  if ( 0.15D+00 <= b ) then
    xn = y - s * log ( t ) - log ( 1.0D+00 + s / ( t + 1.0D+00 ) )
    go to 220
  end if

  if ( 0.01D+00 < b ) then
    u = ( ( t + two * ( 3.0D+00 - a ) ) * t &
      + ( two - a ) * ( 3.0D+00 - a )) / &
      ( ( t + ( 5.0D+00 - a ) ) * t + two )
    xn = y - s * log ( t ) - log ( u )
    go to 220
  end if

30 continue

  c1 = -s * z
  c2 = -s * ( 1.0D+00 + c1 )

  c3 = s * (( half * c1 &
    + ( two - a ) ) * c1 + ( 2.5D+00 - 1.5D+00 * a ) )

  c4 = -s * ((( c1 / 3.0D+00 + ( 2.5D+00 - 1.5D+00 * a ) ) * c1 &
    + ( ( a - 6.0D+00 ) * a + 7.0D+00 ) ) &
    * c1 + ( ( 11.0D+00 * a - 46.0D+00 ) * a + 47.0D+00 ) / 6.0D+00 )

  c5 = -s * (((( - c1 / 4.0D+00 + ( 11.0D+00 * a - 17.0D+00 ) / 6.0D+00 ) * c1 &
     + ( ( -3.0D+00 * a + 13.0D+00 ) * a - 13.0D+00 ) ) * c1 &
     + half &
     * ( ( ( two * a - 25.0D+00 ) * a + 72.0D+00 ) &
     * a - 61.0D+00 ) ) * c1 &
     + ( ( ( 25.0D+00 * a - 195.0D+00 ) * a &
     + 477.0D+00 ) * a - 379.0D+00 ) / 12.0D+00 )

  xn = (((( c5 / y + c4 ) / y + c3 ) / y + c2 ) / y + c1 ) + y

  if ( 1.0D+00 < a ) then
    go to 220
  end if

  if ( bmin(iop) < b ) then
    go to 220
  end if

  x = xn
  return

   40 continue

  if ( b * q <= 1.0D-08 ) then
    xn = exp ( - ( q / a + c ))
  else if ( 0.9D+00 < p ) then
    xn = exp ( ( alnrel ( - q ) + gamma_ln1 ( a )) / a )
  else
    xn = exp ( log ( p * g ) / a )
  end if

  if ( xn == 0.0D+00 ) then
    ierr = -3
    return
  end if

  t = half + ( half - xn / ( a + 1.0D+00 ))
  xn = xn / t
  go to 160
!
!  Selection of the initial approximation XN of X when 1 < A.
!
   80 continue

  if ( 0.5D+00 < q ) then
    w = log ( p )
  else
    w = log ( q )
  end if

  t = sqrt ( - two * w )

  s = t - ((( a3 * t + a2 ) * t + a1 ) * t + a0 ) / (((( &
    b4 * t + b3 ) * t + b2 ) * t + b1 ) * t + 1.0D+00 )

  if ( 0.5D+00 < q ) then
    s = -s
  end if

  rta = sqrt ( a )
  s2 = s * s

  xn = a + s * rta + ( s2 - 1.0D+00 ) / 3.0D+00 + s * ( s2 - 7.0D+00 ) &
    / ( 36.0D+00 * rta ) - ( ( 3.0D+00 * s2 + 7.0D+00 ) * s2 - 16.0D+00 ) &
    / ( 810.0D+00 * a ) + s * (( 9.0D+00 * s2 + 256.0D+00 ) * s2 - 433.0D+00 ) &
    / ( 38880.0D+00 * a * rta )

  xn = max ( xn, 0.0D+00 )

  if ( amin(iop) <= a ) then

    x = xn
    d = half + ( half - x / a )

    if ( abs ( d ) <= dmin(iop) ) then
      return
    end if

  end if

  if ( p <= 0.5D+00 ) then
    go to 130
  end if

  if ( xn < 3.0D+00 * a ) then
    go to 220
  end if

  y = - ( w + gamma_log ( a ) )
  d = max ( two, a * ( a - 1.0D+00 ) )

  if ( ln10 * d <= y ) then
    s = 1.0D+00 - a
    z = log ( y )
    go to 30
  end if

  t = a - 1.0D+00
  xn = y + t * log ( xn ) - alnrel ( -t / ( xn + 1.0D+00 ) )
  xn = y + t * log ( xn ) - alnrel ( -t / ( xn + 1.0D+00 ) )
  go to 220

  130 continue

  ap1 = a + 1.0D+00

  if ( 0.70D+00 * ap1 < xn ) then
    go to 170
  end if

  w = w + gamma_log ( ap1 )

  if ( xn <= 0.15 * ap1 ) then
    ap2 = a + two
    ap3 = a + 3.0D+00
    x = exp ( ( w + x ) / a )
    x = exp ( ( w + x - log ( 1.0D+00 + ( x / ap1 ) &
      * ( 1.0D+00 + x / ap2 ) ) ) / a )
    x = exp ( ( w + x - log ( 1.0D+00 + ( x / ap1 ) &
      * ( 1.0D+00 + x / ap2 ) ) ) / a )
    x = exp ( ( w + x - log ( 1.0D+00 + ( x / ap1 ) &
      * ( 1.0D+00 + ( x / ap2 ) &
      * ( 1.0D+00 + x / ap3 ) ) ) ) / a )
    xn = x

    if ( xn <= 1.0D-02 * ap1 ) then
      if ( xn <= emin(iop) * ap1 ) then
        return
      end if
      go to 170
    end if

  end if

  apn = ap1
  t = xn / apn
  sum1 = 1.0D+00 + t

  do

    apn = apn + 1.0D+00
    t = t * ( xn / apn )
    sum1 = sum1 + t

    if ( t <= 1.0D-04 ) then
      exit
    end if

  end do

  t = w - log ( sum1 )
  xn = exp ( ( xn + t ) / a )
  xn = xn * ( 1.0D+00 - ( a * log ( xn ) - xn - t ) / ( a - xn ) )
  go to 170
!
!  Schroder iteration using P.
!
  160 continue

  if ( 0.5D+00 < p ) then
    go to 220
  end if

  170 continue

  if ( p <= 1.0D+10 * tiny ( p ) ) then
    x = xn
    ierr = -8
    return
  end if

  am1 = ( a - half ) - half

  180 continue

  if ( amax < a ) then
    d = half + ( half - xn / a )
    if ( abs ( d ) <= e2 ) then
      x = xn
      ierr = -8
      return
    end if
  end if

  if ( 20 <= ierr ) then
    ierr = -6
    return
  end if

  ierr = ierr + 1
  call gamma_inc ( a, xn, pn, qn, 0 )

  if ( pn == 0.0D+00 .or. qn == 0.0D+00 ) then
    x = xn
    ierr = -8
    return
  end if

  r = rcomp ( a, xn )

  if ( r == 0.0D+00 ) then
    x = xn
    ierr = -8
    return
  end if

  t = ( pn - p ) / r
  w = half * ( am1 - xn )

  if ( abs ( t ) <= 0.1D+00 .and. abs ( w * t ) <= 0.1D+00 ) then
    go to 200
  end if

  x = xn * ( 1.0D+00 - t )

  if ( x <= 0.0D+00 ) then
    ierr = -7
    return
  end if

  d = abs ( t )
  go to 210

  200 continue

  h = t * ( 1.0D+00 + w * t )
  x = xn * ( 1.0D+00 - h )

  if ( x <= 0.0D+00 ) then
    ierr = -7
    return
  end if

  if ( 1.0D+00 <= abs ( w ) .and. abs ( w ) * t * t <= eps ) then
    return
  end if

  d = abs ( h )

  210 continue

  xn = x

  if ( d <= tol ) then

    if ( d <= eps ) then
      return
    end if

    if ( abs ( p - pn ) <= tol * p ) then
      return
    end if

  end if

  go to 180
!
!  Schroder iteration using Q.
!
  220 continue

  if ( q <= 1.0D+10 * tiny ( q ) ) then
    x = xn
    ierr = -8
    return
  end if

  am1 = ( a - half ) - half

  230 continue

  if ( amax < a ) then
    d = half + ( half - xn / a )
    if ( abs ( d ) <= e2 ) then
      x = xn
      ierr = -8
      return
    end if
  end if

  if ( 20 <= ierr ) then
    ierr = -6
    return
  end if

  ierr = ierr + 1
  call gamma_inc ( a, xn, pn, qn, 0 )

  if ( pn == 0.0D+00 .or. qn == 0.0D+00 ) then
    x = xn
    ierr = -8
    return
  end if

  r = rcomp ( a, xn )

  if ( r == 0.0D+00 ) then
    x = xn
    ierr = -8
    return
  end if

  t = ( q - qn ) / r
  w = half * ( am1 - xn )

  if ( abs ( t ) <= 0.1 .and. abs ( w * t ) <= 0.1 ) then
    go to 250
  end if

  x = xn * ( 1.0D+00 - t )

  if ( x <= 0.0D+00 ) then
    ierr = -7
    return
  end if

  d = abs ( t )
  go to 260

  250 continue

  h = t * ( 1.0D+00 + w * t )
  x = xn * ( 1.0D+00 - h )

  if ( x <= 0.0D+00 ) then
    ierr = -7
    return
  end if

  if ( 1.0D+00 <= abs ( w ) .and. abs ( w ) * t * t <= eps ) then
    return
  end if

  d = abs ( h )

  260 continue

  xn = x

  if ( tol < d ) then
    go to 230
  end if

  if ( d <= eps ) then
    return
  end if

  if ( abs ( q - qn ) <= tol * q ) then
    return
  end if

  go to 230
end
subroutine gamma_inc_values ( n_data, a, x, fx )

!*****************************************************************************80
!
!! GAMMA_INC_VALUES returns some values of the incomplete Gamma function.
!
!  Discussion:
!
!    The (normalized) incomplete Gamma function P(A,X) is defined as:
!
!      PN(A,X) = 1/GAMMA(A) * Integral ( 0 <= T <= X ) T**(A-1) * exp(-T) dT.
!
!    With this definition, for all A and X,
!
!      0 <= PN(A,X) <= 1
!
!    and
!
!      PN(A,INFINITY) = 1.0
!
!    Mathematica can compute this value as
!
!      1 - GammaRegularized[A,X]
!
!  Licensing:
!
!    This code is distributed under the MIT license.
!
!  Modified:
!
!    08 May 2001
!
!  Author:
!
!    John Burkardt
!
!  Reference:
!
!    Milton Abramowitz, Irene Stegun,
!    Handbook of Mathematical Functions,
!    US Department of Commerce, 1964.
!
!  Parameters:
!
!    Input/output, integer N_DATA.  The user sets N_DATA to 0
!    before the first call.  On each call, the routine increments N_DATA by 1,
!    and returns the corresponding data; when there is no more data, the
!    output value of N_DATA will be 0 again.
!
!    Output, real ( kind = rk ) A, X, the arguments of the function.
!
!    Output, real ( kind = rk ) FX, the value of the function.
!
  implicit none

  integer, parameter :: rk = kind ( 1.0D+00 )

  integer, parameter :: n_max = 20

  real ( kind = rk ) a
  real ( kind = rk ), save, dimension ( n_max ) :: a_vec = (/ &
    0.1D+00,  0.1D+00,  0.1D+00,  0.5D+00, &
    0.5D+00,  0.5D+00,  1.0D+00,  1.0D+00, &
    1.0D+00,  1.1D+00,  1.1D+00,  1.1D+00, &
    2.0D+00,  2.0D+00,  2.0D+00,  6.0D+00, &
    6.0D+00, 11.0D+00, 26.0D+00, 41.0D+00 /)
  real ( kind = rk ) fx
  real ( kind = rk ), save, dimension ( n_max ) :: fx_vec = (/ &
    0.7420263D+00, 0.9119753D+00, 0.9898955D+00, 0.2931279D+00, &
    0.7656418D+00, 0.9921661D+00, 0.0951626D+00, 0.6321206D+00, &
    0.9932621D+00, 0.0757471D+00, 0.6076457D+00, 0.9933425D+00, &
    0.0091054D+00, 0.4130643D+00, 0.9931450D+00, 0.0387318D+00, &
    0.9825937D+00, 0.9404267D+00, 0.4863866D+00, 0.7359709D+00 /)
  integer n_data
  real ( kind = rk ) x
  real ( kind = rk ), save, dimension ( n_max ) :: x_vec = (/ &
    3.1622777D-02, 3.1622777D-01, 1.5811388D+00, 7.0710678D-02, &
    7.0710678D-01, 3.5355339D+00, 0.1000000D+00, 1.0000000D+00, &
    5.0000000D+00, 1.0488088D-01, 1.0488088D+00, 5.2440442D+00, &
    1.4142136D-01, 1.4142136D+00, 7.0710678D+00, 2.4494897D+00, &
    1.2247449D+01, 1.6583124D+01, 2.5495098D+01, 4.4821870D+01 /)

  if ( n_data < 0 ) then
    n_data = 0
  end if

  n_data = n_data + 1

  if ( n_max < n_data ) then
    n_data = 0
    a = 0.0D+00
    x = 0.0D+00
    fx = 0.0D+00
  else
    a = a_vec(n_data)
    x = x_vec(n_data)
    fx = fx_vec(n_data)
  end if

  return
end
function gamma_ln1 ( a )

!*****************************************************************************80
!
!! GAMMA_LN1 evaluates ln ( Gamma ( 1 + A ) ), for -0.2 <= A <= 1.25.
!
!  Licensing:
!
!    This code is distributed under the MIT license.
!
!  Modified:
!
!    15 February 2021
!
!  Author:
!
!    Armido DiDinato, Alfred Morris
!
!  Reference:
!
!    Armido DiDinato, Alfred Morris,
!    Algorithm 708:
!    Significant Digit Computation of the Incomplete Beta Function Ratios,
!    ACM Transactions on Mathematical Software,
!    Volume 18, 1993, pages 360-373.
!
!  Parameters:
!
!    Input, real ( kind = rk ) A, defines the argument of the function.
!
!    Output, real ( kind = rk ) GAMMA_LN1, the value of ln ( Gamma ( 1 + A ) ).
!
  implicit none

  integer, parameter :: rk = kind ( 1.0D+00 )

  real ( kind = rk ) a
  real ( kind = rk ) bot
  real ( kind = rk ) gamma_ln1
  real ( kind = rk ), parameter :: p0 =  0.577215664901533D+00
  real ( kind = rk ), parameter :: p1 =  0.844203922187225D+00
  real ( kind = rk ), parameter :: p2 = -0.168860593646662D+00
  real ( kind = rk ), parameter :: p3 = -0.780427615533591D+00
  real ( kind = rk ), parameter :: p4 = -0.402055799310489D+00
  real ( kind = rk ), parameter :: p5 = -0.673562214325671D-01
  real ( kind = rk ), parameter :: p6 = -0.271935708322958D-02
  real ( kind = rk ), parameter :: q1 =  0.288743195473681D+01
  real ( kind = rk ), parameter :: q2 =  0.312755088914843D+01
  real ( kind = rk ), parameter :: q3 =  0.156875193295039D+01
  real ( kind = rk ), parameter :: q4 =  0.361951990101499D+00
  real ( kind = rk ), parameter :: q5 =  0.325038868253937D-01
  real ( kind = rk ), parameter :: q6 =  0.667465618796164D-03
  real ( kind = rk ), parameter :: r0 = 0.422784335098467D+00
  real ( kind = rk ), parameter :: r1 = 0.848044614534529D+00
  real ( kind = rk ), parameter :: r2 = 0.565221050691933D+00
  real ( kind = rk ), parameter :: r3 = 0.156513060486551D+00
  real ( kind = rk ), parameter :: r4 = 0.170502484022650D-01
  real ( kind = rk ), parameter :: r5 = 0.497958207639485D-03
  real ( kind = rk ), parameter :: s1 = 0.124313399877507D+01
  real ( kind = rk ), parameter :: s2 = 0.548042109832463D+00
  real ( kind = rk ), parameter :: s3 = 0.101552187439830D+00
  real ( kind = rk ), parameter :: s4 = 0.713309612391000D-02
  real ( kind = rk ), parameter :: s5 = 0.116165475989616D-03
  real ( kind = rk ) top
  real ( kind = rk ) x

  if ( a < 0.6D+00 ) then

    top = (((((  &
            p6   &
      * a + p5 ) &
      * a + p4 ) &
      * a + p3 ) &
      * a + p2 ) &
      * a + p1 ) &
      * a + p0

    bot = (((((  &
            q6   &
      * a + q5 ) &
      * a + q4 ) &
      * a + q3 ) &
      * a + q2 ) &
      * a + q1 ) &
      * a + 1.0D+00

    gamma_ln1 = -a * ( top / bot )

  else

    x = ( a - 0.5D+00 ) - 0.5D+00

    top = ((((( r5 * x + r4 ) * x + r3 ) * x + r2 ) * x + r1 ) * x + r0 )

    bot = ((((( s5 * x + s4 ) * x + s3 ) * x + s2 ) * x + s1 ) * x + 1.0D+00 )

    gamma_ln1 = x * ( top / bot )

  end if

  return
end
function gamma_log ( a )

!*****************************************************************************80
!
!! GAMMA_LOG evaluates ln ( Gamma ( A ) ) for positive A.
!
!  Licensing:
!
!    This code is distributed under the MIT license.
!
!  Modified:
!
!    15 February 2021
!
!  Author:
!
!    Alfred Morris
!
!  Reference:
!
!    Armido DiDinato, Alfred Morris,
!    Algorithm 708:
!    Significant Digit Computation of the Incomplete Beta Function Ratios,
!    ACM Transactions on Mathematical Software,
!    Volume 18, 1993, pages 360-373.
!
!  Parameters:
!
!    Input, real ( kind = rk ) A, the argument of the function.
!    A should be positive.
!
!    Output, real ( kind = rk ), GAMMA_LOG, the value of ln ( Gamma ( A ) ).
!
  implicit none

  integer, parameter :: rk = kind ( 1.0D+00 )

  real ( kind = rk ) a
  real ( kind = rk ), parameter :: c0 =  0.833333333333333D-01
  real ( kind = rk ), parameter :: c1 = -0.277777777760991D-02
  real ( kind = rk ), parameter :: c2 =  0.793650666825390D-03
  real ( kind = rk ), parameter :: c3 = -0.595202931351870D-03
  real ( kind = rk ), parameter :: c4 =  0.837308034031215D-03
  real ( kind = rk ), parameter :: c5 = -0.165322962780713D-02
  real ( kind = rk ), parameter :: d  =  0.418938533204673D+00
  real ( kind = rk ) gamma_log
  real ( kind = rk ) gamma_ln1
  integer i
  integer n
  real ( kind = rk ) t
  real ( kind = rk ) w

  if ( a <= 0.8D+00 ) then

    gamma_log = gamma_ln1 ( a ) - log ( a )

  else if ( a <= 2.25D+00 ) then

    t = ( a - 0.5D+00 ) - 0.5D+00
    gamma_log = gamma_ln1 ( t )

  else if ( a < 10.0D+00 ) then

    n = int ( a - 1.25D+00 )
    t = a
    w = 1.0D+00
    do i = 1, n
      t = t - 1.0D+00
      w = t * w
    end do

    gamma_log = gamma_ln1 ( t - 1.0D+00 ) + log ( w )

  else

    t = ( 1.0D+00 / a )**2

    w = ((((( c5 * t + c4 ) * t + c3 ) * t + c2 ) * t + c1 ) * t + c0 ) / a

    gamma_log = ( d + w ) + ( a - 0.5D+00 ) &
      * ( log ( a ) - 1.0D+00 )

  end if

  return
end
subroutine gamma_rat1 ( a, x, r, p, q, eps )

!*****************************************************************************80
!
!! GAMMA_RAT1 evaluates the incomplete gamma ratio functions P(A,X) and Q(A,X).
!
!  Licensing:
!
!    This code is distributed under the MIT license.
!
!  Modified:
!
!    15 February 2021
!
!  Author:
!
!    Armido DiDinato, Alfred Morris
!
!  Reference:
!
!    Armido DiDinato, Alfred Morris,
!    Algorithm 708:
!    Significant Digit Computation of the Incomplete Beta Function Ratios,
!    ACM Transactions on Mathematical Software,
!    Volume 18, 1993, pages 360-373.
!
!  Parameters:
!
!    Input, real ( kind = rk ) A, X, the parameters of the functions.
!    It is assumed that A <= 1.
!
!    Input, real ( kind = rk ) R, the value exp(-X) * X^A / Gamma(A).
!
!    Output, real ( kind = rk ) P, Q, the values of P(A,X) and Q(A,X).
!
!    Input, real ( kind = rk ) EPS, the tolerance.
!
  implicit none

  integer, parameter :: rk = kind ( 1.0D+00 )

  real ( kind = rk ) a
  real ( kind = rk ) a2n
  real ( kind = rk ) a2nm1
  real ( kind = rk ) am0
  real ( kind = rk ) an
  real ( kind = rk ) an0
  real ( kind = rk ) b2n
  real ( kind = rk ) b2nm1
  real ( kind = rk ) c
  real ( kind = rk ) cma
  real ( kind = rk ) eps
  real ( kind = rk ) error_f
  real ( kind = rk ) error_fc
  real ( kind = rk ) g
  real ( kind = rk ) gam1
  real ( kind = rk ) h
  real ( kind = rk ) j
  real ( kind = rk ) l
  real ( kind = rk ) p
  real ( kind = rk ) q
  real ( kind = rk ) r
  real ( kind = rk ) rexp
  real ( kind = rk ) sum1
  real ( kind = rk ) t
  real ( kind = rk ) tol
  real ( kind = rk ) w
  real ( kind = rk ) x
  real ( kind = rk ) z

  if ( a * x == 0.0D+00 ) then

    if ( x <= a ) then
      p = 0.0D+00
      q = 1.0D+00
    else
      p = 1.0D+00
      q = 0.0D+00
    end if

    return
  end if

  if ( a == 0.5D+00 ) then

    if ( x < 0.25D+00 ) then
      p = error_f ( sqrt ( x ) )
      q = 0.5D+00 + ( 0.5D+00 - p )
    else
      q = error_fc ( 0, sqrt ( x ) )
      p = 0.5D+00 + ( 0.5D+00 - q )
    end if

    return

  end if
!
!  Taylor series for P(A,X)/X^A
!
  if ( x < 1.1D+00 ) then

    an = 3.0
    c = x
    sum1 = x / ( a + 3.0D+00 )
    tol = 0.1D+00 * eps / ( a + 1.0D+00 )

    do

      an = an + 1.0D+00
      c = -c * ( x / an )
      t = c / ( a + an )
      sum1 = sum1 + t

      if ( abs ( t ) <= tol ) then
        exit
      end if

    end do

    j = a * x * ( ( sum1 / 6.0D+00 - 0.5D+00 &
      / ( a +  2.0D+00  ) ) &
      * x + 1.0D+00 / ( a + 1.0D+00 ) )

    z = a * log ( x )
    h = gam1 ( a )
    g = 1.0D+00 + h

    if ( x < 0.25D+00 ) then
      go to 30
    end if

    if ( a < x / 2.59D+00 ) then
      go to 50
    else
      go to 40
    end if

30 continue

    if ( -0.13394D+00 < z ) then
      go to 50
    end if

40 continue

    w = exp ( z )
    p = w * g * ( 0.5D+00 + ( 0.5D+00 - j ))
    q = 0.5D+00 + ( 0.5D+00 - p )
    return

50 continue

    l = rexp ( z )
    w = 0.5D+00 + ( 0.5D+00 + l )
    q = ( w * j - l ) * g - h

    if  ( q < 0.0D+00 ) then
      p = 1.0D+00
      q = 0.0D+00
    else
      p = 0.5D+00 + ( 0.5D+00 - q )
    end if
!
!  Continued fraction expansion.
!
  else

    a2nm1 = 1.0D+00
    a2n = 1.0D+00
    b2nm1 = x
    b2n = x + ( 1.0D+00 - a )
    c = 1.0D+00

    do

      a2nm1 = x * a2n + c * a2nm1
      b2nm1 = x * b2n + c * b2nm1
      am0 = a2nm1 / b2nm1
      c = c + 1.0D+00
      cma = c - a
      a2n = a2nm1 + cma * a2n
      b2n = b2nm1 + cma * b2n
      an0 = a2n / b2n

      if ( abs ( an0 - am0 ) < eps * an0 ) then
        exit
      end if

    end do

    q = r * an0
    p = 0.5D+00 + ( 0.5D+00 - q )

  end if

  return
end
subroutine gamma_values ( n_data, x, fx )

!*****************************************************************************80
!
!! GAMMA_VALUES returns some values of the Gamma function.
!
!  Definition:
!
!    Gamma(Z) = Integral ( 0 <= T < Infinity) T^(Z-1) exp(-T) dT
!
!  Licensing:
!
!    This code is distributed under the MIT license.
!
!  Modified:
!
!    17 April 2001
!
!  Author:
!
!    John Burkardt
!
!  Reference:
!
!    Milton Abramowitz, Irene Stegun,
!    Handbook of Mathematical Functions,
!    US Department of Commerce, 1964.
!
!  Parameters:
!
!    Input/output, integer N_DATA.  The user sets N_DATA to 0
!    before the first call.  On each call, the routine increments N_DATA by 1,
!    and returns the corresponding data; when there is no more data, the
!    output value of N_DATA will be 0 again.
!
!    Output, real ( kind = rk ) X, the argument of the function.
!
!    Output, real ( kind = rk ) FX, the value of the function.
!
  implicit none

  integer, parameter :: rk = kind ( 1.0D+00 )

  integer, parameter :: n_max = 18

  real ( kind = rk ) fx
  real ( kind = rk ), save, dimension ( n_max ) :: fx_vec = (/ &
    4.590845D+00,     2.218160D+00,     1.489192D+00,     1.164230D+00, &
    1.0000000000D+00, 0.9513507699D+00, 0.9181687424D+00, 0.8974706963D+00, &
    0.8872638175D+00, 0.8862269255D+00, 0.8935153493D+00, 0.9086387329D+00, &
    0.9313837710D+00, 0.9617658319D+00, 1.0000000000D+00, 3.6288000D+05, &
    1.2164510D+17,    8.8417620D+30 /)
  integer n_data
  real ( kind = rk ) x
  real ( kind = rk ), save, dimension ( n_max ) :: x_vec = (/ &
    0.2D+00,  0.4D+00,  0.6D+00,  0.8D+00, &
    1.0D+00,  1.1D+00,  1.2D+00,  1.3D+00, &
    1.4D+00,  1.5D+00,  1.6D+00,  1.7D+00, &
    1.8D+00,  1.9D+00,  2.0D+00, 10.0D+00, &
   20.0D+00, 30.0D+00 /)

  if ( n_data < 0 ) then
    n_data = 0
  end if

  n_data = n_data + 1

  if ( n_max < n_data ) then
    n_data = 0
    x = 0.0D+00
    fx = 0.0D+00
  else
    x = x_vec(n_data)
    fx = fx_vec(n_data)
  end if

  return
end
function gsumln ( a, b )

!*****************************************************************************80
!
!! GSUMLN evaluates the function ln(Gamma(A + B)).
!
!  Discussion:
!
!    GSUMLN is used for 1 <= A <= 2 and 1 <= B <= 2
!
!  Licensing:
!
!    This code is distributed under the MIT license.
!
!  Modified:
!
!    15 February 2021
!
!  Author:
!
!    Armido DiDinato, Alfred Morris
!
!  Reference:
!
!    Armido DiDinato, Alfred Morris,
!    Algorithm 708:
!    Significant Digit Computation of the Incomplete Beta Function Ratios,
!    ACM Transactions on Mathematical Software,
!    Volume 18, 1993, pages 360-373.
!
!  Parameters:
!
!    Input, real ( kind = rk ) A, B, values whose sum is the argument of
!    the Gamma function.
!
!    Output, real ( kind = rk ) GSUMLN, the value of ln(Gamma(A+B)).
!
  implicit none

  integer, parameter :: rk = kind ( 1.0D+00 )

  real ( kind = rk ) a
  real ( kind = rk ) alnrel
  real ( kind = rk ) b
  real ( kind = rk ) gamma_ln1
  real ( kind = rk ) gsumln
  real ( kind = rk ) x

  x = a + b - 2.0D+00

  if ( x <= 0.25D+00 ) then
    gsumln = gamma_ln1 ( 1.0D+00 + x )
  else if ( x <= 1.25D+00 ) then
    gsumln = gamma_ln1 ( x ) + alnrel ( x )
  else
    gsumln = gamma_ln1 ( x - 1.0D+00 ) + log ( x * ( 1.0D+00 + x ) )
  end if

  return
end
function ipmpar ( i )

!*****************************************************************************80
!
!! IPMPAR returns integer machine constants.
!
!  Discussion:
!
!    Input arguments 1 through 3 are queries about integer arithmetic.
!    We assume integers are represented in the N-digit, base A form
!
!      sign * ( X(N-1)*A^(N-1) + ... + X(1)*A + X(0) )
!
!    where 0 <= X(0:N-1) < A.
!
!    Then:
!
!      IPMPAR(1) = A, the base of integer arithmetic;
!      IPMPAR(2) = N, the number of base A digits;
!      IPMPAR(3) = A^N - 1, the largest magnitude.
!
!    It is assumed that the single and real ( kind = rk ) floating
!    point arithmetics have the same base, say B, and that the
!    nonzero numbers are represented in the form
!
!      sign * (B^E) * (X(1)/B + ... + X(M)/B^M)
!
!    where X(1:M) is one of { 0, 1,..., B-1 }, and 1 <= X(1) and
!    EMIN <= E <= EMAX.
!
!    Input argument 4 is a query about the base of real arithmetic:
!
!      IPMPAR(4) = B, the base of single and real ( kind = rk ) arithmetic.
!
!    Input arguments 5 through 7 are queries about single precision
!    floating point arithmetic:
!
!     IPMPAR(5) = M, the number of base B digits for single precision.
!     IPMPAR(6) = EMIN, the smallest exponent E for single precision.
!     IPMPAR(7) = EMAX, the largest exponent E for single precision.
!
!    Input arguments 8 through 10 are queries about real ( kind = rk )
!    floating point arithmetic:
!
!     IPMPAR(8) = M, the number of base B digits for real ( kind = rk ).
!     IPMPAR(9) = EMIN, the smallest exponent E for real ( kind = rk ).
!     IPMPAR(10) = EMAX, the largest exponent E for real ( kind = rk ).
!
!  Licensing:
!
!    This code is distributed under the MIT license.
!
!  Modified:
!
!    15 February 2021
!
!  Reference:
!
!    Phyllis Fox, Andrew Hall, Norman Schryer,
!    Algorithm 528:
!    Framework for a Portable Fortran Subroutine Library,
!    ACM Transactions on Mathematical Software,
!    Volume 4, 1978, pages 176-188.
!
!  Parameters:
!
!    Input, integer I, the index of the desired constant.
!
!    Output, integer IPMPAR, the value of the desired constant.
!
  implicit none

  integer i
  integer imach(10)
  integer ipmpar
!
!     MACHINE CONSTANTS FOR AMDAHL MACHINES.
!
!     data imach( 1) /   2 /
!     data imach( 2) /  31 /
!     data imach( 3) / 2147483647 /
!     data imach( 4) /  16 /
!     data imach( 5) /   6 /
!     data imach( 6) / -64 /
!     data imach( 7) /  63 /
!     data imach( 8) /  14 /
!     data imach( 9) / -64 /
!     data imach(10) /  63 /
!
!     Machine constants for the AT&T 3B SERIES, AT&T
!     PC 7300, AND AT&T 6300.
!
!     data imach( 1) /     2 /
!     data imach( 2) /    31 /
!     data imach( 3) / 2147483647 /
!     data imach( 4) /     2 /
!     data imach( 5) /    24 /
!     data imach( 6) /  -125 /
!     data imach( 7) /   128 /
!     data imach( 8) /    53 /
!     data imach( 9) / -1021 /
!     data imach(10) /  1024 /
!
!     Machine constants for the BURROUGHS 1700 SYSTEM.
!
!     data imach( 1) /    2 /
!     data imach( 2) /   33 /
!     data imach( 3) / 8589934591 /
!     data imach( 4) /    2 /
!     data imach( 5) /   24 /
!     data imach( 6) / -256 /
!     data imach( 7) /  255 /
!     data imach( 8) /   60 /
!     data imach( 9) / -256 /
!     data imach(10) /  255 /
!
!     Machine constants for the BURROUGHS 5700 SYSTEM.
!
!     data imach( 1) /    2 /
!     data imach( 2) /   39 /
!     data imach( 3) / 549755813887 /
!     data imach( 4) /    8 /
!     data imach( 5) /   13 /
!     data imach( 6) /  -50 /
!     data imach( 7) /   76 /
!     data imach( 8) /   26 /
!     data imach( 9) /  -50 /
!     data imach(10) /   76 /
!
!     Machine constants for the BURROUGHS 6700/7700 SYSTEMS.
!
!     data imach( 1) /      2 /
!     data imach( 2) /     39 /
!     data imach( 3) / 549755813887 /
!     data imach( 4) /      8 /
!     data imach( 5) /     13 /
!     data imach( 6) /    -50 /
!     data imach( 7) /     76 /
!     data imach( 8) /     26 /
!     data imach( 9) / -32754 /
!     data imach(10) /  32780 /
!
!     Machine constants for the CDC 6000/7000 SERIES
!     60 BIT ARITHMETIC, AND THE CDC CYBER 995 64 BIT
!     ARITHMETIC (NOS OPERATING SYSTEM).
!
!     data imach( 1) /    2 /
!     data imach( 2) /   48 /
!     data imach( 3) / 281474976710655 /
!     data imach( 4) /    2 /
!     data imach( 5) /   48 /
!     data imach( 6) / -974 /
!     data imach( 7) / 1070 /
!     data imach( 8) /   95 /
!     data imach( 9) / -926 /
!     data imach(10) / 1070 /
!
!     Machine constants for the CDC CYBER 995 64 BIT
!     ARITHMETIC (NOS/VE OPERATING SYSTEM).
!
!     data imach( 1) /     2 /
!     data imach( 2) /    63 /
!     data imach( 3) / 9223372036854775807 /
!     data imach( 4) /     2 /
!     data imach( 5) /    48 /
!     data imach( 6) / -4096 /
!     data imach( 7) /  4095 /
!     data imach( 8) /    96 /
!     data imach( 9) / -4096 /
!     data imach(10) /  4095 /
!
!     Machine constants for the CRAY 1, XMP, 2, AND 3.
!
!     data imach( 1) /     2 /
!     data imach( 2) /    63 /
!     data imach( 3) / 9223372036854775807 /
!     data imach( 4) /     2 /
!     data imach( 5) /    47 /
!     data imach( 6) / -8189 /
!     data imach( 7) /  8190 /
!     data imach( 8) /    94 /
!     data imach( 9) / -8099 /
!     data imach(10) /  8190 /
!
!     Machine constants for the data GENERAL ECLIPSE S/200.
!
!     data imach( 1) /    2 /
!     data imach( 2) /   15 /
!     data imach( 3) / 32767 /
!     data imach( 4) /   16 /
!     data imach( 5) /    6 /
!     data imach( 6) /  -64 /
!     data imach( 7) /   63 /
!     data imach( 8) /   14 /
!     data imach( 9) /  -64 /
!     data imach(10) /   63 /
!
!     Machine constants for the HARRIS 220.
!
!     data imach( 1) /    2 /
!     data imach( 2) /   23 /
!     data imach( 3) / 8388607 /
!     data imach( 4) /    2 /
!     data imach( 5) /   23 /
!     data imach( 6) / -127 /
!     data imach( 7) /  127 /
!     data imach( 8) /   38 /
!     data imach( 9) / -127 /
!     data imach(10) /  127 /
!
!     Machine constants for the HONEYWELL 600/6000
!     AND DPS 8/70 SERIES.
!
!     data imach( 1) /    2 /
!     data imach( 2) /   35 /
!     data imach( 3) / 34359738367 /
!     data imach( 4) /    2 /
!     data imach( 5) /   27 /
!     data imach( 6) / -127 /
!     data imach( 7) /  127 /
!     data imach( 8) /   63 /
!     data imach( 9) / -127 /
!     data imach(10) /  127 /
!
!     Machine constants for the HP 2100
!     3 WORD real ( kind = rk ) OPTION WITH FTN4
!
!     data imach( 1) /    2 /
!     data imach( 2) /   15 /
!     data imach( 3) / 32767 /
!     data imach( 4) /    2 /
!     data imach( 5) /   23 /
!     data imach( 6) / -128 /
!     data imach( 7) /  127 /
!     data imach( 8) /   39 /
!     data imach( 9) / -128 /
!     data imach(10) /  127 /
!
!     Machine constants for the HP 2100
!     4 WORD real ( kind = rk ) OPTION WITH FTN4
!
!     data imach( 1) /    2 /
!     data imach( 2) /   15 /
!     data imach( 3) / 32767 /
!     data imach( 4) /    2 /
!     data imach( 5) /   23 /
!     data imach( 6) / -128 /
!     data imach( 7) /  127 /
!     data imach( 8) /   55 /
!     data imach( 9) / -128 /
!     data imach(10) /  127 /
!
!     Machine constants for the HP 9000.
!
!     data imach( 1) /     2 /
!     data imach( 2) /    31 /
!     data imach( 3) / 2147483647 /
!     data imach( 4) /     2 /
!     data imach( 5) /    24 /
!     data imach( 6) /  -126 /
!     data imach( 7) /   128 /
!     data imach( 8) /    53 /
!     data imach( 9) / -1021 /
!     data imach(10) /  1024 /
!
!     Machine constants for the IBM 360/370 SERIES,
!     THE ICL 2900, THE ITEL AS/6, THE XEROX SIGMA
!     5/7/9 AND THE SEL SYSTEMS 85/86.
!
!     data imach( 1) /    2 /
!     data imach( 2) /   31 /
!     data imach( 3) / 2147483647 /
!     data imach( 4) /   16 /
!     data imach( 5) /    6 /
!     data imach( 6) /  -64 /
!     data imach( 7) /   63 /
!     data imach( 8) /   14 /
!     data imach( 9) /  -64 /
!     data imach(10) /   63 /
!
!     Machine constants for the IBM PC.
!
!      data imach(1)/2/
!      data imach(2)/31/
!      data imach(3)/2147483647/
!      data imach(4)/2/
!      data imach(5)/24/
!      data imach(6)/-125/
!      data imach(7)/128/
!      data imach(8)/53/
!      data imach(9)/-1021/
!      data imach(10)/1024/
!
!     Machine constants for the MACINTOSH II - ABSOFT
!     MACFortran II.
!
!     data imach( 1) /     2 /
!     data imach( 2) /    31 /
!     data imach( 3) / 2147483647 /
!     data imach( 4) /     2 /
!     data imach( 5) /    24 /
!     data imach( 6) /  -125 /
!     data imach( 7) /   128 /
!     data imach( 8) /    53 /
!     data imach( 9) / -1021 /
!     data imach(10) /  1024 /
!
!     Machine constants for the MICROVAX - VMS Fortran.
!
!     data imach( 1) /    2 /
!     data imach( 2) /   31 /
!     data imach( 3) / 2147483647 /
!     data imach( 4) /    2 /
!     data imach( 5) /   24 /
!     data imach( 6) / -127 /
!     data imach( 7) /  127 /
!     data imach( 8) /   56 /
!     data imach( 9) / -127 /
!     data imach(10) /  127 /
!
!     Machine constants for the PDP-11 Fortran SUPPORTING
!     32-BIT integer ARITHMETIC.
!
!     data imach( 1) /    2 /
!     data imach( 2) /   31 /
!     data imach( 3) / 2147483647 /
!     data imach( 4) /    2 /
!     data imach( 5) /   24 /
!     data imach( 6) / -127 /
!     data imach( 7) /  127 /
!     data imach( 8) /   56 /
!     data imach( 9) / -127 /
!     data imach(10) /  127 /
!
!     Machine constants for the SEQUENT BALANCE 8000.
!
!     data imach( 1) /     2 /
!     data imach( 2) /    31 /
!     data imach( 3) / 2147483647 /
!     data imach( 4) /     2 /
!     data imach( 5) /    24 /
!     data imach( 6) /  -125 /
!     data imach( 7) /   128 /
!     data imach( 8) /    53 /
!     data imach( 9) / -1021 /
!     data imach(10) /  1024 /
!
!     Machine constants for the SILICON GRAPHICS IRIS-4D
!     SERIES (MIPS R3000 PROCESSOR).
!
!     data imach( 1) /     2 /
!     data imach( 2) /    31 /
!     data imach( 3) / 2147483647 /
!     data imach( 4) /     2 /
!     data imach( 5) /    24 /
!     data imach( 6) /  -125 /
!     data imach( 7) /   128 /
!     data imach( 8) /    53 /
!     data imach( 9) / -1021 /
!     data imach(10) /  1024 /
!
!     MACHINE CONSTANTS FOR IEEE ARITHMETIC MACHINES, SUCH AS THE AT&T
!     3B SERIES, MOTOROLA 68000 BASED MACHINES (E.G. SUN 3 AND AT&T
!     PC 7300), AND 8087 BASED MICROS (E.G. IBM PC AND AT&T 6300).
!
  data imach( 1) /     2 /
  data imach( 2) /    31 /
  data imach( 3) / 2147483647 /
  data imach( 4) /     2 /
  data imach( 5) /    24 /
  data imach( 6) /  -125 /
  data imach( 7) /   128 /
  data imach( 8) /    53 /
  data imach( 9) / -1021 /
  data imach(10) /  1024 /
!
!     Machine constants for the UNIVAC 1100 SERIES.
!
!     data imach( 1) /    2 /
!     data imach( 2) /   35 /
!     data imach( 3) / 34359738367 /
!     data imach( 4) /    2 /
!     data imach( 5) /   27 /
!     data imach( 6) / -128 /
!     data imach( 7) /  127 /
!     data imach( 8) /   60 /
!     data imach( 9) /-1024 /
!     data imach(10) / 1023 /
!
!     Machine constants for the VAX 11/780.
!
!     data imach( 1) /    2 /
!     data imach( 2) /   31 /
!     data imach( 3) / 2147483647 /
!     data imach( 4) /    2 /
!     data imach( 5) /   24 /
!     data imach( 6) / -127 /
!     data imach( 7) /  127 /
!     data imach( 8) /   56 /
!     data imach( 9) / -127 /
!     data imach(10) /  127 /
!
  ipmpar = imach(i)

  return
end
subroutine negative_binomial_cdf_values ( n_data, f, s, p, cdf )

!*****************************************************************************80
!
!! NEGATIVE_BINOMIAL_CDF_VALUES returns values of the negative binomial CDF.
!
!  Discussion:
!
!    Assume that a coin has a probability P of coming up heads on
!    any one trial.  Suppose that we plan to flip the coin until we
!    achieve a total of S heads.  If we let F represent the number of
!    tails that occur in this process, then the value of F satisfies
!    a negative binomial PDF:
!
!      PDF(F,S,P) = Choose ( F from F+S-1 ) * P^S * (1-P)^F
!
!    The negative binomial CDF is the probability that there are F or
!    fewer failures upon the attainment of the S-th success.  Thus,
!
!      CDF(F,S,P) = sum ( 0 <= G <= F ) PDF(G,S,P)
!
!  Licensing:
!
!    This code is distributed under the MIT license.
!
!  Modified:
!
!    07 June 2004
!
!  Author:
!
!    John Burkardt
!
!  Reference:
!
!    FC Powell,
!    Statistical Tables for Sociology, Biology and Physical Sciences,
!    Cambridge University Press, 1982.
!
!  Parameters:
!
!    Input/output, integer N_DATA.  The user sets N_DATA to 0
!    before the first call.  On each call, the routine increments N_DATA by 1,
!    and returns the corresponding data; when there is no more data, the
!    output value of N_DATA will be 0 again.
!
!    Output, integer F, the maximum number of failures.
!
!    Output, integer S, the number of successes.
!
!    Output, real ( kind = rk ) P, the probability of a success on one trial.
!
!    Output, real ( kind = rk ) CDF, the probability of at most F failures
!    before the S-th success.
!
  implicit none

  integer, parameter :: rk = kind ( 1.0D+00 )

  integer, parameter :: n_max = 27

  real ( kind = rk ) cdf
  real ( kind = rk ), save, dimension ( n_max ) :: cdf_vec = (/ &
    0.6367D+00, 0.3633D+00, 0.1445D+00, &
    0.5000D+00, 0.2266D+00, 0.0625D+00, &
    0.3438D+00, 0.1094D+00, 0.0156D+00, &
    0.1792D+00, 0.0410D+00, 0.0041D+00, &
    0.0705D+00, 0.0109D+00, 0.0007D+00, &
    0.9862D+00, 0.9150D+00, 0.7472D+00, &
    0.8499D+00, 0.5497D+00, 0.2662D+00, &
    0.6513D+00, 0.2639D+00, 0.0702D+00, &
    1.0000D+00, 0.0199D+00, 0.0001D+00 /)
  integer f
  integer, save, dimension ( n_max ) :: f_vec = (/ &
     4,  3,  2, &
     3,  2,  1, &
     2,  1,  0, &
     2,  1,  0, &
     2,  1,  0, &
    11, 10,  9, &
    17, 16, 15, &
     9,  8,  7, &
     2,  1,  0 /)
  integer n_data
  real ( kind = rk ) p
  real ( kind = rk ), save, dimension ( n_max ) :: p_vec = (/ &
    0.50D+00, 0.50D+00, 0.50D+00, &
    0.50D+00, 0.50D+00, 0.50D+00, &
    0.50D+00, 0.50D+00, 0.50D+00, &
    0.40D+00, 0.40D+00, 0.40D+00, &
    0.30D+00, 0.30D+00, 0.30D+00, &
    0.30D+00, 0.30D+00, 0.30D+00, &
    0.10D+00, 0.10D+00, 0.10D+00, &
    0.10D+00, 0.10D+00, 0.10D+00, &
    0.01D+00, 0.01D+00, 0.01D+00 /)
  integer s
  integer, save, dimension ( n_max ) :: s_vec = (/ &
    4, 5, 6, &
    4, 5, 6, &
    4, 5, 6, &
    4, 5, 6, &
    4, 5, 6, &
    1, 2, 3, &
    1, 2, 3, &
    1, 2, 3, &
    0, 1, 2 /)

  if ( n_data < 0 ) then
    n_data = 0
  end if

  n_data = n_data + 1

  if ( n_max < n_data ) then
    n_data = 0
    f = 0
    s = 0
    p = 0.0D+00
    cdf = 0.0D+00
  else
    f = f_vec(n_data)
    s = s_vec(n_data)
    p = p_vec(n_data)
    cdf = cdf_vec(n_data)
  end if

  return
end
subroutine normal_01_cdf_values ( n_data, x, fx )

!*****************************************************************************80
!
!! NORMAL_01_CDF_VALUES returns some values of the Normal 01 CDF.
!
!  Discussion:
!
!    In Mathematica, the function can be evaluated by:
!
!      Needs["Statistics`ContinuousDistributions`"]
!      dist = NormalDistribution [ 0, 1 ]
!      CDF [ dist, x ]
!
!  Licensing:
!
!    This code is distributed under the MIT license.
!
!  Modified:
!
!    28 August 2004
!
!  Author:
!
!    John Burkardt
!
!  Reference:
!
!    Milton Abramowitz, Irene Stegun,
!    Handbook of Mathematical Functions,
!    US Department of Commerce, 1964.
!
!    Stephen Wolfram,
!    The Mathematica Book,
!    Fourth Edition,
!    Wolfram Media / Cambridge University Press, 1999.
!
!  Parameters:
!
!    Input/output, integer N_DATA.  The user sets N_DATA to 0
!    before the first call.  On each call, the routine increments N_DATA by 1,
!    and returns the corresponding data; when there is no more data, the
!    output value of N_DATA will be 0 again.
!
!    Output, real ( kind = rk ) X, the argument of the function.
!
!    Output, real ( kind = rk ) FX, the value of the function.
!
  implicit none

  integer, parameter :: rk = kind ( 1.0D+00 )

  integer, parameter :: n_max = 17

  real ( kind = rk ) fx
  real ( kind = rk ), save, dimension ( n_max ) :: fx_vec = (/ &
    0.5000000000000000D+00, &
    0.5398278372770290D+00, &
    0.5792597094391030D+00, &
    0.6179114221889526D+00, &
    0.6554217416103242D+00, &
    0.6914624612740131D+00, &
    0.7257468822499270D+00, &
    0.7580363477769270D+00, &
    0.7881446014166033D+00, &
    0.8159398746532405D+00, &
    0.8413447460685429D+00, &
    0.9331927987311419D+00, &
    0.9772498680518208D+00, &
    0.9937903346742239D+00, &
    0.9986501019683699D+00, &
    0.9997673709209645D+00, &
    0.9999683287581669D+00 /)
  integer n_data
  real ( kind = rk ) x
  real ( kind = rk ), save, dimension ( n_max ) :: x_vec = (/ &
    0.0000000000000000D+00, &
    0.1000000000000000D+00, &
    0.2000000000000000D+00, &
    0.3000000000000000D+00, &
    0.4000000000000000D+00, &
    0.5000000000000000D+00, &
    0.6000000000000000D+00, &
    0.7000000000000000D+00, &
    0.8000000000000000D+00, &
    0.9000000000000000D+00, &
    0.1000000000000000D+01, &
    0.1500000000000000D+01, &
    0.2000000000000000D+01, &
    0.2500000000000000D+01, &
    0.3000000000000000D+01, &
    0.3500000000000000D+01, &
    0.4000000000000000D+01 /)

  if ( n_data < 0 ) then
    n_data = 0
  end if

  n_data = n_data + 1

  if ( n_max < n_data ) then
    n_data = 0
    x = 0.0D+00
    fx = 0.0D+00
  else
    x = x_vec(n_data)
    fx = fx_vec(n_data)
  end if

  return
end
subroutine normal_cdf_values ( n_data, mu, sigma, x, fx )

!*****************************************************************************80
!
!! NORMAL_CDF_VALUES returns some values of the Normal CDF.
!
!  Discussion:
!
!    In Mathematica, the function can be evaluated by:
!
!      Needs["Statistics`ContinuousDistributions`"]
!      dist = NormalDistribution [ mu, sigma ]
!      CDF [ dist, x ]
!
!  Licensing:
!
!    This code is distributed under the MIT license.
!
!  Modified:
!
!    05 August 2004
!
!  Author:
!
!    John Burkardt
!
!  Reference:
!
!    Milton Abramowitz, Irene Stegun,
!    Handbook of Mathematical Functions,
!    US Department of Commerce, 1964.
!
!    Stephen Wolfram,
!    The Mathematica Book,
!    Fourth Edition,
!    Wolfram Media / Cambridge University Press, 1999.
!
!  Parameters:
!
!    Input/output, integer N_DATA.  The user sets N_DATA to 0
!    before the first call.  On each call, the routine increments N_DATA by 1,
!    and returns the corresponding data; when there is no more data, the
!    output value of N_DATA will be 0 again.
!
!    Output, real ( kind = rk ) MU, the mean of the distribution.
!
!    Output, real ( kind = rk ) SIGMA, the variance of the distribution.
!
!    Output, real ( kind = rk ) X, the argument of the function.
!
!    Output, real ( kind = rk ) FX, the value of the function.
!
  implicit none

  integer, parameter :: rk = kind ( 1.0D+00 )

  integer, parameter :: n_max = 12

  real ( kind = rk ) fx
  real ( kind = rk ), save, dimension ( n_max ) :: fx_vec = (/ &
    0.5000000000000000D+00, &
    0.9772498680518208D+00, &
    0.9999683287581669D+00, &
    0.9999999990134124D+00, &
    0.6914624612740131D+00, &
    0.6305586598182364D+00, &
    0.5987063256829237D+00, &
    0.5792597094391030D+00, &
    0.6914624612740131D+00, &
    0.5000000000000000D+00, &
    0.3085375387259869D+00, &
    0.1586552539314571D+00 /)
  real ( kind = rk ) mu
  real ( kind = rk ), save, dimension ( n_max ) :: mu_vec = (/ &
    0.1000000000000000D+01, &
    0.1000000000000000D+01, &
    0.1000000000000000D+01, &
    0.1000000000000000D+01, &
    0.1000000000000000D+01, &
    0.1000000000000000D+01, &
    0.1000000000000000D+01, &
    0.1000000000000000D+01, &
    0.2000000000000000D+01, &
    0.3000000000000000D+01, &
    0.4000000000000000D+01, &
    0.5000000000000000D+01 /)
  integer n_data
  real ( kind = rk ) sigma
  real ( kind = rk ), save, dimension ( n_max ) :: sigma_vec = (/ &
    0.5000000000000000D+00, &
    0.5000000000000000D+00, &
    0.5000000000000000D+00, &
    0.5000000000000000D+00, &
    0.2000000000000000D+01, &
    0.3000000000000000D+01, &
    0.4000000000000000D+01, &
    0.5000000000000000D+01, &
    0.2000000000000000D+01, &
    0.2000000000000000D+01, &
    0.2000000000000000D+01, &
    0.2000000000000000D+01 /)
  real ( kind = rk ) x
  real ( kind = rk ), save, dimension ( n_max ) :: x_vec = (/ &
    0.1000000000000000D+01, &
    0.2000000000000000D+01, &
    0.3000000000000000D+01, &
    0.4000000000000000D+01, &
    0.2000000000000000D+01, &
    0.2000000000000000D+01, &
    0.2000000000000000D+01, &
    0.2000000000000000D+01, &
    0.3000000000000000D+01, &
    0.3000000000000000D+01, &
    0.3000000000000000D+01, &
    0.3000000000000000D+01 /)

  if ( n_data < 0 ) then
    n_data = 0
  end if

  n_data = n_data + 1

  if ( n_max < n_data ) then
    n_data = 0
    mu = 0.0D+00
    sigma = 0.0D+00
    x = 0.0D+00
    fx = 0.0D+00
  else
    mu = mu_vec(n_data)
    sigma = sigma_vec(n_data)
    x = x_vec(n_data)
    fx = fx_vec(n_data)
  end if

  return
end
subroutine poisson_cdf_values ( n_data, a, x, fx )

!*****************************************************************************80
!
!! POISSON_CDF_VALUES returns some values of the Poisson CDF.
!
!  Discussion:
!
!    CDF(X)(A) is the probability of at most X successes in unit time,
!    given that the expected mean number of successes is A.
!
!  Licensing:
!
!    This code is distributed under the MIT license.
!
!  Modified:
!
!    28 May 2001
!
!  Author:
!
!    John Burkardt
!
!  Reference:
!
!    Milton Abramowitz, Irene Stegun,
!    Handbook of Mathematical Functions,
!    US Department of Commerce, 1964.
!
!    Daniel Zwillinger,
!    CRC Standard Mathematical Tables and Formulae,
!    30th Edition, CRC Press, 1996, pages 653-658.
!
!  Parameters:
!
!    Input/output, integer N_DATA.  The user sets N_DATA to 0
!    before the first call.  On each call, the routine increments N_DATA by 1,
!    and returns the corresponding data; when there is no more data, the
!    output value of N_DATA will be 0 again.
!
!    Output, real ( kind = rk ) A, integer X, the arguments of the function.
!
!    Output, real ( kind = rk ) FX, the value of the function.
!
  implicit none

  integer, parameter :: rk = kind ( 1.0D+00 )

  integer, parameter :: n_max = 21

  real ( kind = rk ) a
  real ( kind = rk ), save, dimension ( n_max ) :: a_vec = (/ &
    0.02D+00, 0.10D+00, 0.10D+00, 0.50D+00, &
    0.50D+00, 0.50D+00, 1.00D+00, 1.00D+00, &
    1.00D+00, 1.00D+00, 2.00D+00, 2.00D+00, &
    2.00D+00, 2.00D+00, 5.00D+00, 5.00D+00, &
    5.00D+00, 5.00D+00, 5.00D+00, 5.00D+00, &
    5.00D+00 /)
  real ( kind = rk ) fx
  real ( kind = rk ), save, dimension ( n_max ) :: fx_vec = (/ &
    0.980D+00, 0.905D+00, 0.995D+00, 0.607D+00, &
    0.910D+00, 0.986D+00, 0.368D+00, 0.736D+00, &
    0.920D+00, 0.981D+00, 0.135D+00, 0.406D+00, &
    0.677D+00, 0.857D+00, 0.007D+00, 0.040D+00, &
    0.125D+00, 0.265D+00, 0.441D+00, 0.616D+00, &
    0.762D+00 /)
  integer n_data
  integer x
  integer, save, dimension ( n_max ) :: x_vec = (/ &
     0, 0, 1, 0, &
     1, 2, 0, 1, &
     2, 3, 0, 1, &
     2, 3, 0, 1, &
     2, 3, 4, 5, &
     6 /)

  if ( n_data < 0 ) then
    n_data = 0
  end if

  n_data = n_data + 1

  if ( n_max < n_data ) then
    n_data = 0
    a = 0.0D+00
    x = 0
    fx = 0.0D+00
  else
    a = a_vec(n_data)
    x = x_vec(n_data)
    fx = fx_vec(n_data)
  end if

  return
end
function psi ( xx )

!*****************************************************************************80
!
!! PSI evaluates the psi or digamma function, d/dx ln(gamma(x)).
!
!  Discussion:
!
!    The main computation involves evaluation of rational Chebyshev
!    approximations.  PSI was written at Argonne National Laboratory
!    for FUNPACK, and subsequently modified by A. H. Morris of NSWC.
!
!  Licensing:
!
!    This code is distributed under the MIT license.
!
!  Modified:
!
!    15 February 2021
!
!  Reference:
!
!    William Cody, Anthony Strecok, Henry Thacher,
!    Chebyshev Approximations for the Psi Function,
!    Mathematics of Computation,
!    Volume 27, 1973, pages 123-127.
!
!    Armido DiDinato, Alfred Morris,
!    Algorithm 708:
!    Significant Digit Computation of the Incomplete Beta Function Ratios,
!    ACM Transactions on Mathematical Software,
!    Volume 18, 1993, pages 360-373.
!
!  Parameters:
!
!    Input, real ( kind = rk ) XX, the argument of the psi function.
!
!    Output, real ( kind = rk ) PSI, the value of the psi function.  PSI
!    is assigned the value 0 when the psi function is undefined.
!
  implicit none

  integer, parameter :: rk = kind ( 1.0D+00 )

  real ( kind = rk ) aug
  real ( kind = rk ) den
  real ( kind = rk ), parameter :: dx0 = &
    1.461632144968362341262659542325721325D+00
  integer i
  integer ipmpar
  integer m
  integer n
  integer nq
  real ( kind = rk ), parameter, dimension ( 7 ) :: p1 = (/ &
   0.895385022981970D-02, &
   0.477762828042627D+01, &
   0.142441585084029D+03, &
   0.118645200713425D+04, &
   0.363351846806499D+04, &
   0.413810161269013D+04, &
   0.130560269827897D+04/)
  real ( kind = rk ), dimension ( 4 ) :: p2 = (/ &
    -0.212940445131011D+01, &
    -0.701677227766759D+01, &
    -0.448616543918019D+01, &
    -0.648157123766197D+00 /)
  real ( kind = rk ), parameter :: piov4 = 0.785398163397448D+00
  real ( kind = rk ) psi
!
!  Coefficients for rational approximation of
!  PSI(X) / (X - X0),  0.5D+00 <= X <= 3.0D+00
!
  real ( kind = rk ), dimension ( 6 ) :: q1 = (/ &
    0.448452573429826D+02, &
    0.520752771467162D+03, &
    0.221000799247830D+04, &
    0.364127349079381D+04, &
    0.190831076596300D+04, &
    0.691091682714533D-05 /)
  real ( kind = rk ), dimension ( 4 ) :: q2 = (/ &
    0.322703493791143D+02, &
    0.892920700481861D+02, &
    0.546117738103215D+02, &
    0.777788548522962D+01 /)
  real ( kind = rk ) sgn
  real ( kind = rk ) upper
  real ( kind = rk ) w
  real ( kind = rk ) x
  real ( kind = rk ) xmax1
  real ( kind = rk ) xmx0
  real ( kind = rk ) xsmall
  real ( kind = rk ) xx
  real ( kind = rk ) z
!
!  XMAX1 is the largest positive floating point constant with entirely
!  integer representation.  It is also used as negative of lower bound
!  on acceptable negative arguments and as the positive argument beyond which
!  psi may be represented as LOG(X).
!
  xmax1 = real ( ipmpar(3), kind = rk )
  xmax1 = min ( xmax1, 1.0D+00 / epsilon ( xmax1 ) )
!
!  XSMALL is the absolute argument below which PI*COTAN(PI*X)
!  may be represented by 1/X.
!
  xsmall = 1.0D-09

  x = xx
  aug = 0.0D+00

  if ( x == 0.0D+00 ) then
    psi = 0.0D+00
    return
  end if
!
!  X < 0.5,  Use reflection formula PSI(1-X) = PSI(X) + PI * COTAN(PI*X)
!
  if ( x < 0.5D+00 ) then
!
!  0 < ABS ( X ) <= XSMALL.  Use 1/X as a substitute for PI * COTAN(PI*X)
!
    if ( abs ( x ) <= xsmall ) then
      aug = -1.0D+00 / x
      go to 40
    end if
!
!  Reduction of argument for cotangent.
!
    w = -x
    sgn = piov4

    if ( w <= 0.0D+00 ) then
      w = -w
      sgn = -sgn
    end if
!
!  Make an error exit if X <= -XMAX1
!
    if ( xmax1 <= w ) then
      psi = 0.0D+00
      return
    end if

    nq = int ( w )
    w = w - real ( nq, kind = rk )
    nq = int ( w * 4.0D+00 )
    w = 4.0D+00 * ( w - real ( nq, kind = rk ) * 0.25D+00 )
!
!  W is now related to the fractional part of 4.0 * X.
!  Adjust argument to correspond to values in first
!  quadrant and determine sign.
!
    n = nq / 2
    if ( n + n /= nq ) then
      w = 1.0D+00 - w
    end if

    z = piov4 * w
    m = n / 2

    if ( m + m /= n ) then
      sgn = -sgn
    end if
!
!  Determine final value for -PI * COTAN(PI*X).
!
    n = ( nq + 1 ) / 2
    m = n / 2
    m = m + m

    if ( m == n ) then

      if ( z == 0.0D+00 ) then
        psi = 0.0D+00
        return
      end if

      aug = 4.0D+00 * sgn * ( cos(z) / sin(z) )

    else

      aug = 4.0D+00 * sgn * ( sin(z) / cos(z) )

    end if

   40   continue

    x = 1.0D+00 - x

  end if
!
!  0.5 <= X <= 3
!
  if ( x <= 3.0D+00 ) then

    den = x
    upper = p1(1) * x

    do i = 1, 5
      den = ( den + q1(i) ) * x
      upper = ( upper + p1(i+1) ) * x
    end do

    den = ( upper + p1(7) ) / ( den + q1(6) )
    xmx0 = real ( x, kind = rk ) - dx0
    psi = den * xmx0 + aug
!
!  3 < X < XMAX1
!
  else if ( x < xmax1 ) then

    w = ( 1.0D+00 / x ) / x
    den = w
    upper = p2(1) * w

    do i = 1, 3
      den = ( den + q2(i) ) * w
      upper = ( upper + p2(i+1) ) * w
    end do

    aug = upper / ( den + q2(4) ) - 0.5D+00 / x + aug
    psi = aug + log ( x )
!
!  XMAX1 <= X
!
  else

    psi = aug + log ( x )

  end if

  return
end
subroutine psi_values ( n_data, x, fx )

!*****************************************************************************80
!
!! PSI_VALUES returns some values of the Psi or Digamma function.
!
!  Discussion:
!
!    PSI(X) = d LN ( GAMMA ( X ) ) / d X = GAMMA'(X) / GAMMA(X)
!
!    PSI(1) = - Euler's constant.
!
!    PSI(X+1) = PSI(X) + 1 / X.
!
!  Licensing:
!
!    This code is distributed under the MIT license.
!
!  Modified:
!
!    17 May 2001
!
!  Author:
!
!    John Burkardt
!
!  Reference:
!
!    Milton Abramowitz, Irene Stegun,
!    Handbook of Mathematical Functions,
!    US Department of Commerce, 1964.
!
!  Parameters:
!
!    Input/output, integer N_DATA.  The user sets N_DATA to 0
!    before the first call.  On each call, the routine increments N_DATA by 1,
!    and returns the corresponding data; when there is no more data, the
!    output value of N_DATA will be 0 again.
!
!    Output, real ( kind = rk ) X, the argument of the function.
!
!    Output, real ( kind = rk ) FX, the value of the function.
!
  implicit none

  integer, parameter :: rk = kind ( 1.0D+00 )

  integer, parameter :: n_max = 11

  real ( kind = rk ) fx
  real ( kind = rk ), save, dimension ( n_max ) :: fx_vec = (/ &
    -0.5772156649D+00, -0.4237549404D+00, -0.2890398966D+00, &
    -0.1691908889D+00, -0.0613845446D+00, -0.0364899740D+00, &
     0.1260474528D+00,  0.2085478749D+00,  0.2849914333D+00, &
     0.3561841612D+00,  0.4227843351D+00 /)
  integer n_data
  real ( kind = rk ) x
  real ( kind = rk ), save, dimension ( n_max ) :: x_vec = (/ &
    1.0D+00,  1.1D+00,  1.2D+00,  &
    1.3D+00,  1.4D+00,  1.5D+00,  &
    1.6D+00,  1.7D+00,  1.8D+00,  &
    1.9D+00,  2.0D+00 /)

  if ( n_data < 0 ) then
    n_data = 0
  end if

  n_data = n_data + 1

  if ( n_max < n_data ) then
    n_data = 0
    x = 0.0D+00
    fx = 0.0D+00
  else
    x = x_vec(n_data)
    fx = fx_vec(n_data)
  end if

  return
end
subroutine r8_swap ( x, y )

!*****************************************************************************80
!
!! R8_SWAP swaps two R8 values.
!
!  Licensing:
!
!    This code is distributed under the MIT license.
!
!  Modified:
!
!    01 May 2000
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input/output, real ( kind = rk ) X, Y.  On output, the values of X and
!    Y have been interchanged.
!
  implicit none

  integer, parameter :: rk = kind ( 1.0D+00 )

  real ( kind = rk ) x
  real ( kind = rk ) y
  real ( kind = rk ) z

  z = x
  x = y
  y = z

  return
end
function rcomp ( a, x )

!*****************************************************************************80
!
!! RCOMP evaluates exp(-X) * X^A / Gamma(A).
!
!  Licensing:
!
!    This code is distributed under the MIT license.
!
!  Modified:
!
!    15 February 2021
!
!  Author:
!
!    Armido DiDinato, Alfred Morris
!
!  Reference:
!
!    Armido DiDinato, Alfred Morris,
!    Algorithm 708:
!    Significant Digit Computation of the Incomplete Beta Function Ratios,
!    ACM Transactions on Mathematical Software,
!    Volume 18, 1993, pages 360-373.
!
!  Parameters:
!
!    Input, real ( kind = rk ) A, X, arguments of the quantity to be computed.
!
!    Output, real ( kind = rk ) RCOMP, the value of exp(-X) * X^A / Gamma(A).
!
!  Local:
!
!    RT2PIN = 1/SQRT(2*PI)
!
  implicit none

  integer, parameter :: rk = kind ( 1.0D+00 )

  real ( kind = rk ) a
  real ( kind = rk ) gam1
  real ( kind = rk ) gamma
  real ( kind = rk ) rcomp
  real ( kind = rk ) rlog
  real ( kind = rk ), parameter :: rt2pin = 0.398942280401433D+00
  real ( kind = rk ) t
  real ( kind = rk ) t1
  real ( kind = rk ) u
  real ( kind = rk ) x

  if ( a < 20.0D+00 ) then

    t = a * log ( x ) - x

    if ( a < 1.0D+00 ) then
      rcomp = ( a * exp ( t ) ) * ( 1.0D+00 + gam1 ( a ) )
    else
      rcomp = exp ( t ) / gamma ( a )
    end if

  else

    u = x / a

    if ( u == 0.0D+00 ) then
      rcomp = 0.0D+00
    else
      t = ( 1.0D+00 / a )**2
      t1 = ((( 0.75D+00 * t - 1.0D+00 ) * t + 3.5D+00 ) * t - 105.0D+00 ) &
        / ( a * 1260.0D+00 )
      t1 = t1 - a * rlog ( u )
      rcomp = rt2pin * sqrt ( a ) * exp ( t1 )
    end if

  end if

  return
end
function rexp ( x )

!*****************************************************************************80
!
!! REXP evaluates the function EXP(X) - 1.
!
!  Licensing:
!
!    This code is distributed under the MIT license.
!
!  Modified:
!
!    15 February 2021
!
!  Author:
!
!    Armido DiDinato, Alfred Morris
!
!  Reference:
!
!    Armido DiDinato, Alfred Morris,
!    Algorithm 708:
!    Significant Digit Computation of the Incomplete Beta Function Ratios,
!    ACM Transactions on Mathematical Software,
!    Volume 18, 1993, pages 360-373.
!
!  Parameters:
!
!    Input, real ( kind = rk ) X, the argument of the function.
!
!    Output, real ( kind = rk ) REXP, the value of EXP(X)-1.
!
  implicit none

  integer, parameter :: rk = kind ( 1.0D+00 )

  real ( kind = rk ), parameter :: p1 =  0.914041914819518D-09
  real ( kind = rk ), parameter :: p2 =  0.238082361044469D-01
  real ( kind = rk ), parameter :: q1 = -0.499999999085958D+00
  real ( kind = rk ), parameter :: q2 =  0.107141568980644D+00
  real ( kind = rk ), parameter :: q3 = -0.119041179760821D-01
  real ( kind = rk ), parameter :: q4 =  0.595130811860248D-03
  real ( kind = rk ) rexp
  real ( kind = rk ) w
  real ( kind = rk ) x

  if ( abs ( x ) <= 0.15D+00 ) then

    rexp = x * ( ( ( p2 * x + p1 ) * x + 1.0D+00 ) &
      / ( ( ( ( q4 * x + q3 ) * x + q2 ) * x + q1 ) * x + 1.0D+00 ) )

  else

    w = exp ( x )

    if ( x <= 0.0D+00 ) then
      rexp = ( w - 0.5D+00 ) - 0.5D+00
    else
      rexp = w * ( 0.5D+00 + ( 0.5D+00 - 1.0D+00 / w ) )
    end if

  end if

  return
end
function rlog ( x )

!*****************************************************************************80
!
!! RLOG computes X - 1 - LN(X).
!
!  Licensing:
!
!    This code is distributed under the MIT license.
!
!  Modified:
!
!    15 February 2021
!
!  Author:
!
!    Armido DiDinato, Alfred Morris
!
!  Reference:
!
!    Armido DiDinato, Alfred Morris,
!    Algorithm 708:
!    Significant Digit Computation of the Incomplete Beta Function Ratios,
!    ACM Transactions on Mathematical Software,
!    Volume 18, 1993, pages 360-373.
!
!  Parameters:
!
!    Input, real ( kind = rk ) X, the argument of the function.
!
!    Output, real ( kind = rk ) RLOG, the value of the function.
!
  implicit none

  integer, parameter :: rk = kind ( 1.0D+00 )

  real ( kind = rk ), parameter :: a  =  0.566749439387324D-01
  real ( kind = rk ), parameter :: b  =  0.456512608815524D-01
  real ( kind = rk ), parameter :: half = 0.5D+00
  real ( kind = rk ), parameter :: p0 =  0.333333333333333D+00
  real ( kind = rk ), parameter :: p1 = -0.224696413112536D+00
  real ( kind = rk ), parameter :: p2 =  0.620886815375787D-02
  real ( kind = rk ), parameter :: q1 = -0.127408923933623D+01
  real ( kind = rk ), parameter :: q2 =  0.354508718369557D+00
  real ( kind = rk ) r
  real ( kind = rk ) rlog
  real ( kind = rk ) t
  real ( kind = rk ), parameter :: two =  2.0D+00
  real ( kind = rk ) u
  real ( kind = rk ) w
  real ( kind = rk ) w1
  real ( kind = rk ) x

  if ( x < 0.61D+00 ) then

    r = ( x - 0.5D+00 ) - 0.5D+00
    rlog = r - log ( x )

  else if ( x < 1.57D+00 ) then

    if ( x < 0.82D+00 ) then

      u = x - 0.7D+00
      u = u / 0.7D+00
      w1 = a - u * 0.3D+00

    else if ( x < 1.18D+00 ) then

      u = ( x - half ) - half
      w1 = 0.0D+00

    else if ( x < 1.57D+00 ) then

      u = 0.75D+00 * x - 1.0D+00
      w1 = b + u / 3.0D+00

    end if

    r = u / ( u + two )
    t = r * r
    w = ( ( p2 * t + p1 ) * t + p0 ) / ( ( q2 * t + q1 ) * t + 1.0D+00 )
    rlog = two * t * ( 1.0D+00 / ( 1.0D+00 - r ) - r * w ) + w1

  else if ( 1.57D+00 <= x ) then

    r = ( x - half ) - half
    rlog = r - log ( x )

  end if

  return
end
function rlog1 ( x )

!*****************************************************************************80
!
!! RLOG1 evaluates the function X - ln ( 1 + X ).
!
!  Licensing:
!
!    This code is distributed under the MIT license.
!
!  Modified:
!
!    15 February 2021
!
!  Author:
!
!    Armido DiDinato, Alfred Morris
!
!  Reference:
!
!    Armido DiDinato, Alfred Morris,
!    Algorithm 708:
!    Significant Digit Computation of the Incomplete Beta Function Ratios,
!    ACM Transactions on Mathematical Software,
!    Volume 18, 1993, pages 360-373.
!
!  Parameters:
!
!    Input, real ( kind = rk ) X, the argument.
!
!    Output, real ( kind = rk ) RLOG1, the value of X - ln ( 1 + X ).
!
  implicit none

  integer, parameter :: rk = kind ( 1.0D+00 )

  real ( kind = rk ), parameter :: a = 0.566749439387324D-01
  real ( kind = rk ), parameter :: b = 0.456512608815524D-01
  real ( kind = rk ) h
  real ( kind = rk ), parameter :: half = 0.5D+00
  real ( kind = rk ), parameter :: p0 = 0.333333333333333D+00
  real ( kind = rk ), parameter :: p1 = -0.224696413112536D+00
  real ( kind = rk ), parameter :: p2 = 0.620886815375787D-02
  real ( kind = rk ), parameter :: q1 = -0.127408923933623D+01
  real ( kind = rk ), parameter :: q2 = 0.354508718369557D+00
  real ( kind = rk ) r
  real ( kind = rk ) rlog1
  real ( kind = rk ) t
  real ( kind = rk ), parameter :: two =  2.0D+00
  real ( kind = rk ) w
  real ( kind = rk ) w1
  real ( kind = rk ) x

  if ( x < -0.39D+00 ) then

    w = ( x + half ) + half
    rlog1 = x - log ( w )

  else if ( x < -0.18D+00 ) then

    h = x + 0.3D+00
    h = h / 0.7D+00
    w1 = a - h * 0.3D+00

    r = h / ( h + 2.0D+00 )
    t = r * r
    w = ( ( p2 * t + p1 ) * t + p0 ) / ( ( q2 * t + q1 ) * t + 1.0D+00 )
    rlog1 = two * t * ( 1.0D+00 / ( 1.0D+00 - r ) - r * w ) + w1

  else if ( x <= 0.18D+00 ) then

    h = x
    w1 = 0.0D+00

    r = h / ( h + two )
    t = r * r
    w = ( ( p2 * t + p1 ) * t + p0 ) / ( ( q2 * t + q1 ) * t + 1.0D+00 )
    rlog1 = two * t * ( 1.0D+00 / ( 1.0D+00 - r ) - r * w ) + w1

  else if ( x <= 0.57D+00 ) then

    h = 0.75D+00 * x - 0.25D+00
    w1 = b + h / 3.0D+00

    r = h / ( h + 2.0D+00 )
    t = r * r
    w = ( ( p2 * t + p1 ) * t + p0 ) / ( ( q2 * t + q1 ) * t + 1.0D+00 )
    rlog1 = two * t * ( 1.0D+00 / ( 1.0D+00 - r ) - r * w ) + w1

  else

    w = ( x + half ) + half
    rlog1 = x - log ( w )

  end if

  return
end
subroutine student_cdf_values ( n_data, a, x, fx )

!*****************************************************************************80
!
!! STUDENT_CDF_VALUES returns some values of the Student CDF.
!
!  Licensing:
!
!    This code is distributed under the MIT license.
!
!  Modified:
!
!    02 June 2001
!
!  Author:
!
!    John Burkardt
!
!  Reference:
!
!    Milton Abramowitz, Irene Stegun,
!    Handbook of Mathematical Functions,
!    US Department of Commerce, 1964.
!
!  Parameters:
!
!    Input/output, integer N_DATA.  The user sets N_DATA to 0
!    before the first call.  On each call, the routine increments N_DATA by 1,
!    and returns the corresponding data; when there is no more data, the
!    output value of N_DATA will be 0 again.
!
!    Output, integer A, real ( kind = rk ) X, the arguments of
!    the function.
!
!    Output, real ( kind = rk ) FX, the value of the function.
!
  implicit none

  integer, parameter :: rk = kind ( 1.0D+00 )

  integer, parameter :: n_max = 13

  integer a
  integer, save, dimension ( n_max ) :: a_vec = (/ &
    1, 2, 3, 4, &
    5, 2, 5, 2, &
    5, 2, 3, 4, &
    5 /)
  real ( kind = rk ) fx
  real ( kind = rk ), save, dimension ( n_max ) :: fx_vec = (/ &
    0.60D+00, 0.60D+00, 0.60D+00, 0.60D+00, &
    0.60D+00, 0.75D+00, 0.75D+00, 0.95D+00, &
    0.95D+00, 0.99D+00, 0.99D+00, 0.99D+00, &
    0.99D+00 /)
  integer n_data
  real ( kind = rk ) x
  real ( kind = rk ), save, dimension ( n_max ) :: x_vec = (/ &
    0.325D+00, 0.289D+00, 0.277D+00, 0.271D+00, &
    0.267D+00, 0.816D+00, 0.727D+00, 2.920D+00, &
    2.015D+00, 6.965D+00, 4.541D+00, 3.747D+00, &
    3.365D+00 /)

  if ( n_data < 0 ) then
    n_data = 0
  end if

  n_data = n_data + 1

  if ( n_max < n_data ) then
    n_data = 0
    a = 0
    x = 0.0D+00
    fx = 0.0D+00
  else
    a = a_vec(n_data)
    x = x_vec(n_data)
    fx = fx_vec(n_data)
  end if

  return
end
function stvaln ( p )

!*****************************************************************************80
!
!! STVALN provides starting values for the inverse of the normal distribution.
!
!  Discussion:
!
!    The routine returns an X for which it is approximately true that
!      P = CUMNOR(X),
!    that is,
!      P = Integral ( -infinity < U <= X ) exp(-U*U/2)/sqrt(2*PI) dU.
!
!  Licensing:
!
!    This code is distributed under the MIT license.
!
!  Modified:
!
!    15 February 2021
!
!  Reference:
!
!    William Kennedy, James Gentle,
!    Statistical Computing,
!    Marcel Dekker, NY, 1980, page 95,
!    QA276.4 K46
!
!  Parameters:
!
!    Input, real ( kind = rk ) P, the probability whose normal deviate
!    is sought.
!
!    Output, real ( kind = rk ) STVALN, the normal deviate whose probability
!    is approximately P.
!
  implicit none

  integer, parameter :: rk = kind ( 1.0D+00 )

  real ( kind = rk ) eval_pol
  real ( kind = rk ) p
  real ( kind = rk ) sgn
  real ( kind = rk ) stvaln
  real ( kind = rk ), parameter, dimension(0:4) :: xden = (/ &
    0.993484626060D-01, &
    0.588581570495D+00, &
    0.531103462366D+00, &
    0.103537752850D+00, &
    0.38560700634D-02 /)
  real ( kind = rk ), parameter, dimension(0:4) :: xnum = (/ &
    -0.322232431088D+00, &
    -1.000000000000D+00, &
    -0.342242088547D+00, &
    -0.204231210245D-01, &
    -0.453642210148D-04 /)
  real ( kind = rk ) y
  real ( kind = rk ) z

  if ( p <= 0.5D+00 ) then

    sgn = -1.0D+00
    z = p

  else

    sgn = 1.0D+00
    z = 1.0D+00 - p

  end if

  y = sqrt ( -2.0D+00 * log ( z ) )
  stvaln = y + eval_pol ( xnum, 4, y ) / eval_pol ( xden, 4, y )
  stvaln = sgn * stvaln

  return
end

