! @section Synopsis
!
! Statistical functions for VIF.
!
! @author J. Marcel van der Veer
!
! @section copyright
!
! This file is part of VIF - vintage fortran compiler.
! Copyright 2020-2025 J. Marcel van der Veer <algol68g@xs4all.nl>.
!
! @section license
!
! This program is free software; you can redistribute it and/or modify it 
! under the terms of the gnu general public license as published by the 
! free software foundation; either version 3 of the license, or 
! (at your option) any later version.
!
! This program is distributed in the hope that it will be useful, but 
! without any warranty; without even the implied warranty of merchantability 
! or fitness for a particular purpose. See the GNU general public license for 
! more details. You should have received a copy of the GNU general public 
! license along with this program. If not, see <http://www.gnu.org/licenses/>.
!

      REAL*8 FUNCTION dlnorm (x, upper)
!
! DLNORM computes the cumulative density of the standard normal distribution.
!
! Modified:
!
!   28 March 1999
!
! Author:
!
!   David Hill
!   Modifications by John Burkardt
!
! Reference:
!
!   David Hill,
!   Algorithm AS 66:
!   The Normal Integral,
!   Applied Statistics,
!   Volume 22, Number 3, 1973, pages 424-427.
!
! Parameters:
!
!   Input, real*8 X, is one endpoint of the semi-infinite interval
!   over which the integration takes place.
!
!   Input, logical UPPER, determines whether the upper or lower
!   interval is to be integrated:
!   .TRUE.  => integrate from X to + Infinity;
!   .FALSE. => integrate from - Infinity to X.
!
!   Output, real*8 ALNORM, the integral of the standard normal
!   distribution over the desired interval.
!
      IMPLICIT none

      REAL*8 a1
      PARAMETER (a1 = 5.75885480458d+00)
      REAL*8 a2
      PARAMETER (a2 = 2.62433121679d+00)
      REAL*8 a3
      PARAMETER (a3 = 5.92885724438d+00)
      REAL*8 b1
      PARAMETER (b1 = -29.8213557807d+00)
      REAL*8 b2
      PARAMETER (b2 = 48.6959930692d+00)
      REAL*8 c1
      PARAMETER (c1 = -0.000000038052d+00)
      REAL*8 c2
      PARAMETER (c2 = 0.000398064794d+00)
      REAL*8 c3
      PARAMETER (c3 = -0.151679116635d+00)
      REAL*8 c4
      PARAMETER (c4 = 4.8385912808d+00)
      REAL*8 c5
      PARAMETER (c5 = 0.742380924027d+00)
      REAL*8 c6
      PARAMETER (c6 = 3.99019417011d+00)
      REAL*8 con
      PARAMETER (con = 1.28d+00)
      REAL*8 d1
      PARAMETER (d1 = 1.00000615302d+00)
      REAL*8 d2
      PARAMETER (d2 = 1.98615381364d+00)
      REAL*8 d3
      PARAMETER (d3 = 5.29330324926d+00)
      REAL*8 d4
      PARAMETER (d4 = -15.1508972451d+00)
      REAL*8 d5
      PARAMETER (d5 = 30.789933034d+00)
      REAL*8 ltone
      PARAMETER (ltone = 7.0d+00)
      REAL*8 p
      PARAMETER (p = 0.398942280444d+00)
      REAL*8 q
      PARAMETER (q = 0.39990348504d+00)
      REAL*8 r
      PARAMETER (r = 0.398942280385d+00)
      LOGICAL up
      LOGICAL upper
      REAL*8 utzero
      PARAMETER (utzero = 18.66d+00)
      REAL*8 x
      REAL*8 y
      REAL*8 z

      up = upper
      z = x

      IF (z .lt. 0.0d+00) THEN
        up = .not. up
        z = - z
      END IF

      IF (ltone .lt. z .and. 
     &  ((.not. up) .or. utzero .lt. z)) THEN

        IF (up) THEN
          dlnorm = 0.0d+00
        ELSE
          dlnorm = 1.0d+00
        END IF

        RETURN

      END IF

      y = 0.5d+00 * z * z

      IF (z .le. con) THEN

        dlnorm = 0.5d+00 - z * (p - q * y
     &    / (y + a1 + b1 
     &    / (y + a2 + b2 
     &    / (y + a3))))

      ELSE

        dlnorm = r * dexp (- y)
     &    / (z + c1 + d1
     &    / (z + c2 + d2
     &    / (z + c3 + d3
     &    / (z + c4 + d4
     &    / (z + c5 + d5
     &    / (z + c6))))))

      END IF

      IF (.not. up) THEN
        dlnorm = 1.0d+00 - dlnorm
      END IF

      RETURN
      END

      REAL*8 FUNCTION prncst (st, idf, d, ifault)

!
! PRNCST computes the lower tail of noncentral T distribution.
!
! Modified:
!
!   06 January 2008
!
! Author:
!
!   BE Cooper
!   Modifications by John Burkardt
!
! Reference:
!
!   BE Cooper,
!   Algorithm AS 5: 
!   The Integral of the Non-Central T-Distribution,
!   Applied Statistics,
!   Volume 17, Number 2, 1968, page 193.
!
! Parameters:
!
!   Input, real*8 ST, the argument.
!
!   Input, integer IDF, the number of degrees of freedom.
!
!   Input, real*8 D, the noncentrality parameter.
!
!   Output, integer IFAULT, error flag.
!   0, no error occurred.
!   nonzero, an error occurred.
!
!   Output, real*8 PRNCST, the value of the lower tail of
!   the noncentral T distribution.
!
! Local Parameters:
!
!   Local, real*8 G1, 1.0 / sqrt(2.0 * pi)
!
!   Local, real*8 G2, 1.0 / (2.0 * pi)
!
!   Local, real*8 G3, sqrt(2.0 * pi)
!
      IMPLICIT none

      REAL*8 a
      REAL*8 ak
      REAL*8 dlnorm
      REAL*8 b
      REAL*8 d
      REAL*8 da
      REAL*8 drb
      REAL*8 emin
      PARAMETER (emin = 12.5d+00)
      REAL*8 f
      REAL*8 fk
      REAL*8 fkm1
      REAL*8 fmkm1
      REAL*8 fmkm2
      REAL*8 g1
      PARAMETER (g1 = 0.3989422804d+00)
      REAL*8 g2
      PARAMETER (g2 = 0.1591549431d+00)
      REAL*8 g3
      PARAMETER (g3 = 2.5066282746d+00)
      INTEGER idf
      INTEGER ifault
      INTEGER ioe
      INTEGER k
      REAL*8 rb
      REAL*8 st
      REAL*8 sum
      REAL*8 tfn

      f = dble (idf)
!
! For very large IDF, use the normal approximation.
!
      IF (100 .lt. idf) THEN

        ifault = 1

        a = dsqrt (0.5d+00 * f) 
     &  * dexp (dlngam (0.5d+00 * (f - 1.0d+00))
     &  - dlngam (0.5d+00 * f)) * d

        prncst = dlnorm ((st - a) / dsqrt (f * (1.0d+00 + d * d)
     &  / (f - 2.0d+00) - a * a), .false.)

        RETURN
      END IF

      ifault = 0
      ioe = mod (idf, 2)
      a = st / dsqrt (f)
      b = f / (f + st * st)
      rb = dsqrt (b)
      da = d * a
      drb = d * rb

      IF (idf .eq. 1) THEN
        prncst = dlnorm (drb, .true.) + 2.0d+00 * tfn (drb, a)
        RETURN
      END IF

      sum = 0.0d+00

      IF (dabs (drb) .lt. emin) THEN
        fmkm2 = a * rb * dexp (- 0.5d+00 * drb * drb)
     &  * dlnorm (a * drb, .false.) * g1
      ELSE
        fmkm2 = 0.0d+00
      END IF

      fmkm1 = b * da * fmkm2

      IF (dabs (d)  .lt. emin) THEN
        fmkm1 = fmkm1 + b * a * g2 * dexp (- 0.5d+00 * d * d)
      END IF

      IF (ioe .eq. 0) THEN
        sum = fmkm2
      ELSE
        sum = fmkm1
      END IF

      ak = 1.0d+00
      fk = 2.0d+00

      DO k = 2, idf - 2, 2

        fkm1 = fk - 1.0d+00
        fmkm2 = b * (da * ak * fmkm1 + fmkm2) * fkm1 / fk
        ak = 1.0d+00 / (ak * fkm1)
        fmkm1 = b * (da * ak * fmkm2 + fmkm1) * fk / (fk + 1.0d+00)

        IF (ioe .eq. 0) THEN
          sum = sum + fmkm2
        ELSE
          sum = sum + fmkm1
        END IF

        ak = 1.0d+00 / (ak * fk)
        fk = fk + 2.0d+00

      END DO

      IF (ioe .eq. 0) THEN
        prncst = dlnorm (d, .true.) + sum * g3
      ELSE
        prncst = dlnorm (drb, .true.) 
     &  + 2.0d+00 * (sum + tfn (drb, a))
      END IF

      RETURN
      END

      SUBROUTINE student_noncentral_cdf_values (n_data, df, lambda, 
     &  x, fx)

!
! STUDENT_NONCENTRAL_CDF_VALUES returns values of the noncentral Student CDF.
!
! Discussion:
!
!   In Mathematica, the function can be evaluated by:
!
!     Needs["Statistics`ContinuousDistributions`"]
!     dist = NoncentralStudentTDistribution [ df, lambda ]
!     CDF [ dist, x ]
!
!   Mathematica seems to have some difficulty computing this function
!   to the desired number of digits.
!
! Modified:
!
!   25 March 2007
!
! Author:
!
!   John Burkardt
!
! Reference:
!
!   Milton Abramowitz, Irene Stegun,
!   Handbook of Mathematical Functions,
!   National Bureau of Standards, 1964,
!   ISBN: 0-486-61272-4,
!   LC: QA47.A34.
!
!   Stephen Wolfram,
!   The Mathematica Book,
!   Fourth Edition,
!   Cambridge University Press, 1999,
!   ISBN: 0-521-64314-7,
!   LC: QA76.95.W65.
!
! 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 DF, real*8 LAMBDA, the parameters of the
!   function.
!
!   Output, real*8 X, the argument of the function.
!
!   Output, real*8 FX, the value of the function.
!
      IMPLICIT none

      INTEGER n_max
      PARAMETER (n_max = 30)

      INTEGER df
      INTEGER df_vec(n_max) 
      REAL*8 fx
      REAL*8 fx_vec(n_max) 
      REAL*8 lambda
      REAL*8 lambda_vec(n_max) 
      INTEGER n_data
      REAL*8 x
      REAL*8 x_vec(n_max) 

      SAVE df_vec
      SAVE fx_vec
      SAVE lambda_vec
      SAVE x_vec

      DATA df_vec /
     &   1,  2,  3, 
     &   1,  2,  3, 
     &   1,  2,  3, 
     &   1,  2,  3, 
     &   1,  2,  3, 
     &  15, 20, 25, 
     &   1,  2,  3, 
     &  10, 10, 10, 
     &  10, 10, 10, 
     &  10, 10, 10 /
      DATA fx_vec /
     &  0.8975836176504333d+00, 
     &  0.9522670169d+00, 
     &  0.9711655571887813d+00, 
     &  0.8231218864d+00, 
     &  0.9049021510d+00, 
     &  0.9363471834d+00, 
     &  0.7301025986d+00, 
     &  0.8335594263d+00, 
     &  0.8774010255d+00, 
     &  0.5248571617d+00, 
     &  0.6293856597d+00, 
     &  0.6800271741d+00, 
     &  0.20590131975d+00, 
     &  0.2112148916d+00, 
     &  0.2074730718d+00, 
     &  0.9981130072d+00, 
     &  0.9994873850d+00, 
     &  0.9998391562d+00, 
     &  0.168610566972d+00, 
     &  0.16967950985d+00, 
     &  0.1701041003d+00, 
     &  0.9247683363d+00, 
     &  0.7483139269d+00, 
     &  0.4659802096d+00, 
     &  0.9761872541d+00, 
     &  0.8979689357d+00, 
     &  0.7181904627d+00, 
     &  0.9923658945d+00, 
     &  0.9610341649d+00, 
     &  0.8688007350d+00 /
      DATA lambda_vec /
     &  0.0d+00, 
     &  0.0d+00, 
     &  0.0d+00, 
     &  0.5d+00, 
     &  0.5d+00, 
     &  0.5d+00, 
     &  1.0d+00, 
     &  1.0d+00, 
     &  1.0d+00, 
     &  2.0d+00, 
     &  2.0d+00, 
     &  2.0d+00, 
     &  4.0d+00, 
     &  4.0d+00, 
     &  4.0d+00, 
     &  7.0d+00, 
     &  7.0d+00, 
     &  7.0d+00, 
     &  1.0d+00, 
     &  1.0d+00, 
     &  1.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 /
      DATA x_vec /
     &   3.00d+00, 
     &   3.00d+00, 
     &   3.00d+00, 
     &   3.00d+00, 
     &   3.00d+00, 
     &   3.00d+00, 
     &   3.00d+00, 
     &   3.00d+00, 
     &   3.00d+00, 
     &   3.00d+00, 
     &   3.00d+00, 
     &   3.00d+00, 
     &   3.00d+00, 
     &   3.00d+00, 
     &   3.00d+00, 
     &  15.00d+00, 
     &  15.00d+00, 
     &  15.00d+00, 
     &   0.05d+00, 
     &   0.05d+00, 
     &   0.05d+00, 
     &   4.00d+00, 
     &   4.00d+00, 
     &   4.00d+00, 
     &   5.00d+00, 
     &   5.00d+00, 
     &   5.00d+00, 
     &   6.00d+00, 
     &   6.00d+00, 
     &   6.00d+00 /

      IF (n_data .lt. 0) THEN
        n_data = 0
      END IF

      n_data = n_data + 1

      IF (n_max .lt. n_data) THEN
        n_data = 0
        df = 0
        lambda = 0.0d+00
        x = 0.0d+00
        fx = 0.0d+00
      ELSE
        df = df_vec(n_data)
        lambda = lambda_vec(n_data)
        x = x_vec(n_data)
        fx = fx_vec(n_data)
      END IF

      RETURN
      END

      REAL*8 FUNCTION tfn (x, fx)
!
! TFN calculates the T-function of Owen.
!
! Modified:
!
!   06 January 2008
!
! Author:
!
!   JC Young, Christoph Minder
!   Modifications by John Burkardt
!
! Reference:
!
!   MA Porter, DJ Winstanley,
!   Remark AS R30:
!   A Remark on Algorithm AS76:
!   An Integral Useful in Calculating Noncentral T and Bivariate
!   Normal Probabilities,
!   Applied Statistics,
!   Volume 28, Number 1, 1979, page 113.
!
!   JC Young, Christoph Minder,
!   Algorithm AS 76: 
!   An Algorithm Useful in Calculating Non-Central T and 
!   Bivariate Normal Distributions,
!   Applied Statistics,
!   Volume 23, Number 3, 1974, pages 455-457.
!
! Parameters:
!
!   Input, real*8 X, FX, the parameters of the function.
!
!   Output, real*8 TFN, the value of the T-function.
!
      IMPLICIT none

      INTEGER ng
      PARAMETER (ng = 5)

      REAL*8 fx
      REAL*8 fxs
      INTEGER i
      REAL*8 r(ng)
      REAL*8 r1
      REAL*8 r2
      REAL*8 rt
      REAL*8 tp
      PARAMETER (tp = 0.159155d+00)
      REAL*8 tv1
      PARAMETER (tv1 = 1.0d-35)
      REAL*8 tv2
      PARAMETER (tv2 = 15.0d+00)
      REAL*8 tv3
      PARAMETER (tv3 = 15.0d+00)
      REAL*8 tv4
      PARAMETER (tv4 = 1.0d-05)
      REAL*8 u(ng)
      REAL*8 x
      REAL*8 x1
      REAL*8 x2
      REAL*8 xs

      DATA u / 
     &  0.0744372d+00, 
     &  0.2166977d+00, 
     &  0.3397048d+00, 
     &  0.4325317d+00, 
     &  0.4869533d+00 /

      DATA r /
     &  0.1477621d+00, 
     &  0.1346334d+00, 
     &  0.1095432d+00, 
     &  0.0747257d+00, 
     &  0.0333357d+00 /
!
! Test for X near zero.
!
      IF (dabs (x) .lt. tv1) THEN
        tfn = tp * atan (fx)
        RETURN
      END IF
!
! Test for large values of abs(X).
!
      IF (tv2 .lt. dabs (x)) THEN
        tfn = 0.0d+00
        RETURN
      END IF
!
! Test for FX near zero.
!
      IF (dabs (fx) .lt. tv1) THEN
        tfn = 0.0d+00
        RETURN
      END IF
!
! Test whether abs (FX) is so large that it must be truncated.
!
      xs = - 0.5d+00 * x * x
      x2 = fx
      fxs = fx * fx

      IF (dlog (1.0d+00 + fxs) - xs * fxs .lt. tv3) THEN
        GO TO 2 
      END IF
!
! Computation of truncation point by Newton iteration.
!
      x1 = 0.5d+00 * fx
      fxs = 0.25d+00 * fxs

    1 CONTINUE

        rt = fxs + 1.0d+00

        x2 = x1 + (xs * fxs + tv3 - dlog (rt)) 
     &  / (2.0d+00 * x1 * (1.0d+00 / rt - xs))

        fxs = x2 * x2

        IF (dabs (x2 - x1) .lt. tv4) THEN
          GO TO 2
        END IF

        x1 = x2

      GO TO 1
!
! Gaussian quadrature.
!
    2 CONTINUE

      rt = 0.0d+00

      DO i = 1, ng

        r1 = 1.0d+00 + fxs * (0.5d+00 + u(i))**2
        r2 = 1.0d+00 + fxs * (0.5d+00 - u(i))**2

        rt = rt + r(i) * (dexp (xs * r1) / r1 
     &  + dexp (xs * r2) / r2)

      END DO

      tfn = rt * x2 * tp

      RETURN
      END
