! @section Synopsis
!
! Auxiliary math 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/>.
!

      SUBROUTINE rand48(ix,iy,yfl)
!
! Generates random numbers between 0 and 1 (SUN version).
!
!       ix - initial seed
!       iy - new seed value
!       yfl - random number double precision
!
! Adapted from CASCADE: netlib.org/ieeecs/cascade
! The CASCADE library is in the public domain.
!
      DOUBLE PRECISION yfl, drand48
      INTEGER ix, iy, iseed
      LOGICAL first
      DATA    first /.true./
      SAVE    first, iseed
!
!     if this is the first call, initialize topmost 32 bits of the seed
!
      IF (first .or. iseed .ne. ix) THEN
        CALL srand48 (ix)
        first = .false.
      END IF
!
!     Use SUN-supplied function drand48
!
      iy = ix
      iseed = ix
      yfl = drand48()
!
      RETURN
      END

      SUBROUTINE gauss(ix,x)
! The routine gauss generates a random number from a gaussian 
! distribution, with a mean of zero and a standard deviation of one.
!
!       VAX/VMS version
!
!       Variables:
!
!       ix - initial seed integer; gauss updates it with a new seed value
!
!       x - the output gaussian variable
!
! Adapted from CASCADE: netlib.org/ieeecs/cascade
! The CASCADE library is in the public domain.
!
      DOUBLE PRECISION x, y, sum
      sum = 0d0
      DO 1 i = 1, 5
         CALL rand48(ix,iy,y)
         ix = iy
         sum = sum + y
    1 CONTINUE
      x = 6d0 * (sum / 5d0) - 3d0
      RETURN
      END

      REAL*8 function zero in (ax, bx, f, tol, ierr)
      IMPLICIT REAL*8 (a - h, o - z)
!
! Compute a zero of the function f(x) in the interval [ax, bx].
!
! It is assumed that f(ax) and f(bx) have opposite signs.
! Zeroin returns a zero in the given interval ax, bx to within a
! tolerance 4 * macheps * abs(x) + tol, where macheps
! is the relative machine precision.
!
! Adapted from zeroin.f from netlib.org/fmm.
! That function is a slightly modified translation of the ALGOL 60
! procedure zero given in
!
!  Richard Brent, Algorithms for Minimization without Derivatives, 
!  Prentice - Hall, inc. (1973).
!
! Parameters:
!
! ax  left endpoint of initial interval
! bx  right endpoint of initial interval
! f   function subprogram which evaluates f(x) for any x in the interval ax, bx
! tol desired length of the interval of uncertainty of the final result (>= 0.0d0)
!
! Result:
!
! Approximation of a zero of f in the interval ax, bx
! ierr = 0 'zero in' found a root
! ierr = 1 'zero in' did not find a root
!
! Compare to SLATEC routines DFZERO and FZERO.
!

! Initialization.
      eps = d1mach(3)
      a = ax
      b = bx
      fa = f(a)
      fb = f(b)
! Begin.
    1 c = a
      fc = fa
      d = b - a
      e = d
    2 IF (dabs(fc) < dabs(fb)) THEN
        a = b
        b = c
        c = a
        fa = fb
        fb = fc
        fc = fa
      END IF
! Convergence check.
      tol1 = 2.0d0 * eps * dabs(b) + 0.5d0 * tol
      xm = .5d0 * (c - b)
      IF (dabs(xm) <= tol1 | fb == 0.0d0) GO TO 5
! Is bisection necessary?
      IF (dabs(e) < tol1 | dabs(fa) <= dabs(fb)) GO TO 3
! Is quadratic interpolation possible?
      IF (a == c) THEN
! Linear interpolation.
        s = fb / fa
        p = 2.0d0 * xm * s
        q = 1.0d0 - s
      ELSE
! Inverse quadratic interpolation.
        q = fa / fc
        r = fb / fc
        s = fb / fa
        p = s * (2.0d0 * xm * q * (q - r) - (b - a) * (r - 1.0d0))
        q = (q - 1.0d0) * (r - 1.0d0) * (s - 1.0d0)
      END IF
! Adjust signs.
      IF (p > 0.0d0) q = -q
      p = dabs(p)
! Is interpolation acceptable?
      IF ((2.0d0 * p) >= (3.0d0 * xm * q - dabs(tol1 * q))) GO TO 3
      IF (p >= dabs(0.5d0 * e * q)) GO TO 3
      e = d
      d = p / q
      GO TO 4
! Bisection.
    3 d = xm
      e = d
! Complete step.
    4 a = b
      fa = fb
      IF (dabs(d) > tol1) b = b + d
      IF (dabs(d) <= tol1) b = b + dsign(tol1, xm)
      fb = f(b)
      IF ((fb * (fc / dabs(fc))) > 0.0d0) GO TO 1
      GO TO 2
! Done.
    5 zero in = b
      IF (dabs (fb) <= tol) THEN
        ierr = 0
      ELSE
        ierr = 1
      END IF
      RETURN
      END
