  MODULE SPLINE_MOD
!-----------------------------------------------------------------------
! --- SUBROUTINE SPLIE2
! --- SUBROUTINE SPLIE3
! --- SUBROUTINE SPLINE
! --- SUBROUTINE SPLINT
! --- SUBROUTINE SPLIN2
! --- SUBROUTINE SPLIN3
! --- SUBROUTINE FRPRM
! --- SUBROUTINE LINMIN
! --- SUBROUTINE LINMIN1
! --- SUBROUTINE F1D1M
! --- SUBROUTINE MNBRAK
! --- SUBROUTINE BRENT
! --- SUBROUTINE SHAPE
!-----------------------------------------------------------------------
  implicit none

  integer, private, parameter       :: nmax = 2
  integer, private                  :: ncom
  real,    private, dimension(nmax) :: pcom, xicom

  contains
!########################################################################

  SUBROUTINE SPLIE2( x1a, x2a, ya, y2a )
!-----------------------------------------------------------------------
! Given an M by N tabulated function YA and tabulated independant
! variables X1A (M values) and X2A (N values), this routine constructs
! one-dimensional natural cubic splines of the rows and returns
! the second-derivatives in the array Y2A.
!-----------------------------------------------------------------------
  implicit none

  real, intent(in),  dimension(:)   :: x1a   ! ===> NOT REFERENCED
  real, intent(in),  dimension(:)   :: x2a
  real, intent(in),  dimension(:,:) :: ya
  real, intent(out), dimension(:,:) :: y2a

  real,  dimension(SIZE(ya,2)) :: ytmp, y2tmp
  integer                      :: m, n, j

  real, parameter :: ypval = 1.e30

!-----------------------------------------------------------------------

  m = SIZE( ya, 1 )
  n = SIZE( ya, 2 )

  do j = 1,m
! %%%%%%%%%%%%%%

  ytmp(:) = ya(j,:)

  CALL SPLINE( x2a, ytmp, ypval, ypval, y2tmp )

  y2a(j,:) = y2tmp(:)

! %%%%%%%%%%%%%%
  end do

!-----------------------------------------------------------------------
  end SUBROUTINE SPLIE2

!########################################################################

  SUBROUTINE SPLIE3( x1a, x2a, ya, y2a )
!-----------------------------------------------------------------------
! Given an M by N tabulated function YA and tabulated independant
! variables X1A (M values) and X2A (N values), this routine constructs
! one-dimensional natural cubic splines of the rows and returns
! the second-derivatives in the array Y2A.
!-----------------------------------------------------------------------
  implicit none

  real, intent(in),  dimension(:)   :: x1a
  real, intent(in),  dimension(:)   :: x2a   ! ===> NOT REFERENCED
  real, intent(in),  dimension(:,:) :: ya
  real, intent(out), dimension(:,:) :: y2a

  real,  dimension(SIZE(ya,1)) :: ytmp, y2tmp
  integer                      :: m, n, k

  real, parameter :: ypval = 1.e30

!-----------------------------------------------------------------------

  m = SIZE( ya, 1 )
  n = SIZE( ya, 2 )

  do k = 1,n
! %%%%%%%%%%%%%%

  ytmp(:) = ya(:,k)

  CALL SPLINE( x1a, ytmp, ypval, ypval, y2tmp )

  y2a(:,k) = y2tmp(:)

! %%%%%%%%%%%%%%
  end do

!-----------------------------------------------------------------------
  end SUBROUTINE SPLIE3

!########################################################################

  SUBROUTINE SPLINE( x, y, yp1, ypn, y2 )
!-----------------------------------------------------------------------
! Given arrays X and Y of lenght N containing a tabulated function,i.e.
! Yi = f(Xi), with X1<X2<...<Xn, and given values YP1 and YPN for the
! first derivative of the interpolating function at points 1 and N,
! respectively, this routine returns an array Y2 of length N which
! contains the second derivatives of the interpolating function
! of the tabulated points Xi.
! If YP1 and/or YPN are equal to 1.E30 or larger, the routine
! is signalled to set the corresponding boundary  condition
! for a natural spline, wuth zero derivative on that boundary.
!-----------------------------------------------------------------------
  implicit none

  real, intent(in)                :: yp1, ypn
  real, intent(in),  dimension(:) :: x,   y
  real, intent(out), dimension(:) :: y2

  real, dimension(SIZE(x)) :: u,  sig, p
  real                     :: qn, un
  integer                  :: n,  i

  real, parameter :: yptest = 0.99e30

!-----------------------------------------------------------------------

  n = SIZE( x )

  if ( yp1 > yptest  ) then
       y2(1) = 0.
        u(1) = 0.
  else
       y2(1) = -0.5
        u(1) = ( 3.0 / ( x(2) - x(1) ) ) * &
                     ( ( y(2) - y(1) ) / ( x(2) - x(1) ) - yp1 )
  endif

  do i = 2,n-1
! %%%%%%%%%%%%%%
  sig(i) = ( x(i) - x(i-1) ) / ( x(i+1) - x(i-1) )
    p(i) = sig(i) * y2(i-1) + 2.
   y2(i) = ( sig(i) - 1. ) / p(i)
    u(i) = ( 6.0 * ( ( y(i+1) - y(i)   )    &
                   / ( x(i+1) - x(i)   )    &
                   - ( y(i)   - y(i-1) )    &
                   / ( x(i)   - x(i-1) ) )  &
                   / ( x(i+1) - x(i-1) ) - sig(i) * u(i-1) ) / p(i)
! %%%%%%%%%%%%%%
  end do

  if ( ypn > yptest ) then
       qn = 0.
       un = 0.
  else
       qn = 0.5
       un = ( 3.0 / ( x(n) - x(n-1) ) ) * &
            ( ypn - ( y(n) - y(n-1) ) / ( x(n) - x(n-1) ) )
  endif

       y2(n) = ( un - qn * u(n-1) ) / ( qn * y2(n-1) + 1. )
  do i = n-1,1,-1
       y2(i) = y2(i) * y2(i+1) + u(i)
  end do

!-----------------------------------------------------------------------
  end SUBROUTINE SPLINE

!########################################################################

  SUBROUTINE SPLINT( xa, ya, y2a, x, y, dy, dyy )
!-----------------------------------------------------------------------
! Given the arrays XA and YA of length N, which tabulate a function
! (with the XA's in order), and given the array Y2A, which is the output
! from spline above, and given a value of X, this routine
! returns a cubic-spline interpolated value Y.
!-----------------------------------------------------------------------
  implicit none

  real, intent(in),  dimension(:) :: xa, ya, y2a
  real, intent(in)                :: x
  real, intent(out)               :: y,  dy, dyy

  integer :: n, k, klo, khi
  real    :: h, a, b,   ddy

!-----------------------------------------------------------------------

  n = SIZE( xa )

         klo = 1
         khi = n

1 if ( ( khi - klo ) > 1 ) then
         k = ( khi + klo ) / 2
    if ( xa(k) > x ) then
         khi = k
    else
         klo = k
    endif
  GOTO 1
  endif

  h = xa(khi) - xa(klo)

  if ( h == 0. ) PRINT *, ' *** SPLINT: bad xa input'

  a = ( xa(khi) - x ) / h
  b = ( x - xa(klo) ) / h

  y = a * ya(klo) + b * ya(khi)  &
     + ( ( a**3 - a ) * y2a(klo) &
       + ( b**3 - b ) * y2a(khi) ) * ( h**2 ) / 6.

  dy = ( ya(khi) - ya(klo) ) / h                  &
     - ( 3.0 * a**2 - 1.0 ) * h * y2a(klo) / 6.0  &
     + ( 3.0 * b**2 - 1.0 ) * h * y2a(khi) / 6.0

  ddy = a * y2a(klo) + b * y2a(khi)
! dyy = ddy

!-----------------------------------------------------------------------
  end SUBROUTINE SPLINT

!########################################################################

  SUBROUTINE SPLIN2( x1a, x2a, ya, y2a, x1, x2, y, dy, ddy )
!-----------------------------------------------------------------------
! Given X1A, X2A, YA, M, N as described in SPLIE2 and Y2A as produced
! by that routine; and given a desired interpolating point X1, X2;
! this routine returns an interpolated function value Y by bicubic
! spline interpolation
!-----------------------------------------------------------------------
  implicit none

  real, intent(in)                 :: x1,  x2
  real, intent(in), dimension(:)   :: x1a, x2a
  real, intent(in), dimension(:,:) :: ya,  y2a
  real, intent(out)                :: y,   dy, ddy

  real, dimension(SIZE(ya,2)) :: ytmp, y2tmp
  real, dimension(SIZE(ya,1)) :: yytmp, yy2tmp

  real    :: y1, y2
  integer :: m,  n, j

  real, parameter :: ypval = 1.e30

!-----------------------------------------------------------------------

  m = SIZE( ya, 1 )
  n = SIZE( ya, 2 )

  do j = 1,m
! %%%%%%%%%%%%%%

   ytmp(:) =  ya(j,:)
  y2tmp(:) = y2a(j,:)

  CALL SPLINT( x2a, ytmp, y2tmp, x2, yytmp(j), y1, y2 )

! %%%%%%%%%%%%%%
  end do

  CALL SPLINE( x1a, yytmp, ypval,  ypval, yy2tmp  )
  CALL SPLINT( x1a, yytmp, yy2tmp, x1, y, dy, ddy )

  ddy = 0.

!-----------------------------------------------------------------------
  end SUBROUTINE SPLIN2

!########################################################################

  SUBROUTINE SPLIN3( x1a, x2a, ya, y2a, x1, x2, y, dy, ddy )
!-----------------------------------------------------------------------
! Given X1A, X2A, YA, M, N as described in SPLIE2 and Y2A as produced
! by that routine; and given a desired interpolating point X1, X2;
! this routine returns an interpolated function value Y by bicubic
! spline interpolation
!-----------------------------------------------------------------------
  implicit none

  real, intent(in)                 :: x1,  x2
  real, intent(in), dimension(:)   :: x1a, x2a
  real, intent(in), dimension(:,:) :: ya,  y2a
  real, intent(out)                :: y,   dy, ddy

  real, dimension(SIZE(ya,1)) :: ytmp,  y2tmp
  real, dimension(SIZE(ya,2)) :: yytmp, yy2tmp

  real    :: y1, y2
  integer :: m,  n, k

  real, parameter :: ypval = 1.e30

!-----------------------------------------------------------------------

  m = SIZE( ya, 1 )
  n = SIZE( ya, 2 )

  do k = 1,n
! %%%%%%%%%%%%%%

   ytmp(:) =  ya(:,k)
  y2tmp(:) = y2a(:,k)

  CALL SPLINT( x1a, ytmp, y2tmp, x1, yytmp(k), y1, y2 )

! %%%%%%%%%%%%%%
  end do

  CALL SPLINE( x2a, yytmp, ypval,  ypval, yy2tmp  )
  CALL SPLINT( x2a, yytmp, yy2tmp, x2, y, dy, ddy )

  ddy = 0.

!-----------------------------------------------------------------------
  end SUBROUTINE SPLIN3

!########################################################################

  SUBROUTINE FRPRM( x1a, x2a, ya, y2a, y3a, p, ftol, iter, fret, ierror)
!-----------------------------------------------------------------------
! Given a starting point P that is a vector of length N, Fletcher-Reeves
! Polak-Ribiere minimization is performed on a function FUNV, using its
! gradient as calculated by a routine DFUNC,. The convergence tolerance
! on the function value is input as FTOL. Returned quantities are P
! (the location of the minimum), ITER (the number of iterations
! that were performed), and FRET(the minimum value of the function).
! The routine LINMIN is called to perform line minimizations.
! Maximum anticipated value of N; maximum allowed number of iterations;
! small number to rectify special case of converging to exactly zero
! function value
!-----------------------------------------------------------------------
  implicit none

  integer, parameter :: itmax = 20
  real,    parameter :: eps   = 1.0E-10

  real,    intent(in)                    :: ftol
  real,    intent(in),    dimension(:)   :: x1a, x2a
  real,    intent(in),    dimension(:,:) :: ya,  y2a, y3a
  real,    intent(inout), dimension(:)   :: p
  real,    intent(out)                   :: fret
  integer, intent(out)                   :: iter
  integer, intent(inout)                 :: ierror

  real, dimension(SIZE(p)) :: g, h, xi

  integer :: l, m, n, j, its, ier
  real    :: p1, px, pxx, py, pyy, fp, s0, pp1, pp2, gg, dgg, gam

!-----------------------------------------------------------------------

  l = SIZE( ya, 1 )
  m = SIZE( ya, 2 )
  n = SIZE( p     )

  CALL SPLIN2( x1a, x2a, ya, y2a, p(1), p(2), p1, px, pxx )
  CALL SPLIN3( x1a, x2a, ya, y3a, p(1), p(2), p1, py, pyy )

  fp    = p1
  xi(1) = px
  xi(2) = py

  do j = 1,n
     g(j) = -xi(j)
     h(j) =   g(j)
    xi(j) =   h(j)
  end do

  do its = 1,itmax
! %%%%%%%%%%%%%%%%%
  iter = its

  s0    = SQRT( xi(1)**2 + xi(2)**2 )
  xi(1) = xi(1) / s0
  xi(2) = xi(2) / s0

  CALL LINMIN( p, xi, fret, x1a, x2a, ya, y2a, ier )

  if( ier == 1 ) then
    ierror = 1
    RETURN
  endif

  if( ( 2.0*ABS( fret - fp ) ) <=   &
      ( ftol*( ABS( fret ) + ABS( fp ) + eps ) ) ) RETURN

                     pp1 =   p(1)
                     pp2 =   p(2)
  if( p(1) <=   0. ) pp1 =   p(1) + 360.0
  if( p(1) >= 360. ) pp1 =   p(1) - 360.0
  if( p(2) <= -90. ) pp2 = -180.0 - p(2)
  if( p(2) >=  90. ) pp2 =  180.0 - p(2)

  CALL SPLIN2( x1a, x2a, ya, y2a, pp1, pp2, p1, px, pxx )
  CALL SPLIN3( x1a, x2a, ya, y3a, pp1, pp2, p1, py, pyy )

  xi(1) = px
  xi(2) = py
  fp    = p1
  gg    = 0.
  dgg   = 0.

  do j = 1,n
    gg  =  gg + g(j)**2
    dgg = dgg + xi(j)**2
    dgg = dgg + ( xi(j) + g(j) ) * xi(j)
  end do

  if( gg == 0.0 ) RETURN

  gam = dgg / gg

  do j = 1,n
     g(j) =- xi(j)
     h(j) =   g(j) + gam*h(j)
    xi(j) =   h(j)
  end do

! %%%%%%%%%%%%%%%%%
  end do

  ierror = 1
  PRINT *, ' *** FRPRM: maximum iterations exceeded'

!-----------------------------------------------------------------------
  end SUBROUTINE FRPRM

!########################################################################

  SUBROUTINE LINMIN( p, xi, fret, x1a, x2a, ya, y2a, ier )
!-----------------------------------------------------------------------
  implicit none

  real, parameter :: tol  = 1.0E-4

  real,    intent(in),    dimension(:)   :: x1a, x2a
  real,    intent(in),    dimension(:,:) :: ya,  y2a
  real,    intent(inout), dimension(:)   :: p,   xi
  real,    intent(out)                   :: fret
  integer, intent(out)                   :: ier

  integer :: l, m, n, j
  real    :: ax, xx, bx, fa, fx, fb, xmin

!-----------------------------------------------------------------------

     l = SIZE( ya, 1 )
     m = SIZE( ya, 2 )
     n = SIZE( p     )
  ncom = n

  do j = 1,n
     pcom(j) =  p(j)
    xicom(j) = xi(j)
  end do

  ax = 0.
  xx = 1.

  CALL MNBRAK( ax, xx, bx, fa, fx, fb, x1a, x2a, ya, y2a )

  ier = 0

  CALL BRENT( ax, xx, bx, tol, fret, xmin, x1a, x2a, ya, y2a, ier )

  if ( xmin <= 1.E-5 ) xmin = 0.0

  do j = 1,n
     xi(j) = xmin * xi(j)
      p(j) = p(j) + xi(j)
  end do

!-----------------------------------------------------------------------
  end SUBROUTINE LINMIN

!########################################################################

  SUBROUTINE LINMIN1( p, xi, fret, x1a, x2a, ya, y2a, ier, val, dist_val )
!-----------------------------------------------------------------------
  implicit none

  real, parameter :: tol  = 1.0E-4

  real,    intent(in)                    :: val, dist_val
  real,    intent(in),    dimension(:)   :: x1a, x2a, xi
  real,    intent(in),    dimension(:,:) :: ya,  y2a
  real,    intent(inout), dimension(:)   :: p
  real,    intent(out)                   :: fret
  integer, intent(out)                   :: ier

  real, dimension(SIZE(p)) :: xt

  integer :: l, m, n, j
  real    :: x20, y20, x, d, y, py, pyy, y0, y1

!-----------------------------------------------------------------------

     l = SIZE( ya, 1 )
     m = SIZE( ya, 2 )
     n = SIZE( p     )
  ncom = n

  x20 = P(1)
  y20 = p(2)

  do j = 1,n
     pcom(j) =  p(j)
    xicom(j) = xi(j)
  end do

  ier = 0
  x  = 1.
  d  = 0.

  CALL SPLIN2( x1a, x2a, ya, y2a, p(1), p(2), y, py, pyy )

  y0 = y

! %%%%%%%%%%%%%%%%%
  1 CONTINUE
! %%%%%%%%%%%%%%%%%

  do j = 1,n
    xt(j) = p(j) + x * xicom(j)
  end do

  d = SQRT( ( xt(1) - x20 )**2 + ( xt(2) - y20 )**2 )

  CALL SPLIN2( x1a, x2a, ya, y2a, xt(1), xt(2), y1, py, pyy )

  !WRITE( *,*) "d: ", d
  if( ABS( d ) >= dist_val ) then
  !if( ABS( d ) >= 8.0 ) then
    ier = 1
    RETURN
  endif

  if( x <= 0.0001 ) then
    fret = y
    RETURN
  endif

  if( ( y0 - y1 ) >= val ) RETURN

  if( ( ( y0 - y1 ) <= 2.0 ) .and. ( y <= 1000000. ) ) then
    p(1) = xt(1)
    p(2) = xt(2)
! %%%%%%%%%%%%%%%%%
  GOTO 1
! %%%%%%%%%%%%%%%%%
  endif

  if(y1 >= 10000000. ) then
    p(1) = xt(1)
    p(2) = xt(2)
  endif

  x = x / 2.0

! %%%%%%%%%%%%%%%%%
  GOTO 1
! %%%%%%%%%%%%%%%%%

!-----------------------------------------------------------------------
  end SUBROUTINE LINMIN1

!########################################################################

  SUBROUTINE F1D1M( y, x, x1a, x2a, ya, y2a )
!-----------------------------------------------------------------------
  implicit none

  real,    intent(in)                    :: x
  real,    intent(in),    dimension(:)   :: x1a, x2a
  real,    intent(in),    dimension(:,:) :: ya,  y2a
  real,    intent(out)                   :: y

  real, dimension(nmax) :: xt

  integer :: l, m, j
  real    :: py, pyy

!-----------------------------------------------------------------------

  l = SIZE( ya, 1 )
  m = SIZE( ya, 2 )

  do j = 1,ncom
    xt(j) = pcom(j) + x * xicom(j)
  end do

  if( xt(1) <=   0.0 ) xt(1) =  360.0 + xt(1)
  if( xt(1) >= 360.0 ) xt(1) =  xt(1) - 360.0
  if( xt(2) <= -90.0 ) xt(2) = -180.0 - xt(2)
  if( xt(2) >=  90.0 ) xt(2) =  180.0 - xt(2)

  CALL SPLIN2( x1a, x2a, ya, y2a, xt(1), xt(2), y, py, pyy )

!-----------------------------------------------------------------------
  end SUBROUTINE F1D1M

!########################################################################

  SUBROUTINE MNBRAK( ax, bx, cx, fa, fb, fc, x1a, x2a, ya, y2a )
!-----------------------------------------------------------------------
  implicit none

  real, parameter :: gold   = 1.618034
  real, parameter :: glimit = 100.0
  real, parameter :: tiny   = 1.0E-20

  real, intent(in), dimension(:)   :: x1a, x2a
  real, intent(in), dimension(:,:) :: ya,  y2a
  real, intent(inout)              :: ax, bx, cx
  real, intent(out)                :: fa, fb, fc

  integer :: l, m
  real    :: dum, r, q, u, ulim, fu
  real    :: uxt, uxb

!-----------------------------------------------------------------------

  l = SIZE( ya, 1 )
  m = SIZE( ya, 2 )

  CALL F1D1M( fa, ax, x1a, x2a, ya, y2a )
  CALL F1D1M( fb, bx, x1a, x2a, ya, y2a )

  if( fb > fa ) then
     dum = ax
     ax  = bx
     bx  = dum
     dum = fb
     fb  = fa
     fa  = dum
  endif

  cx = bx + gold * ( bx - ax )
  CALL F1D1M( fc, cx, x1a, x2a, ya, y2a )

! %%%%%%%%%%%%%%%%%%%%%%
  1 if( fb >= fc ) then
! %%%%%%%%%%%%%%%%%%%%%%

  r    = ( bx - ax ) * ( fb - fc )
  q    = ( bx - cx ) * ( fb - fa )

! u    = bx - ( ( bx - cx ) * q - ( bx - ax ) * r ) /  &
!        ( 2.0 * SIGN( MAX( ABS( q - r ), tiny ), q - r ) )

  uxt  = ( bx - cx ) * q - ( bx - ax ) * r
  uxb  =  2.0 * SIGN( MAX( ABS( q - r ), tiny ), q - r )
  u    = bx - uxt / uxb
  u    = MIN( cx + gold * ( cx - bx ), u )
  ulim = bx + glimit * ( cx - bx )

! ---------------------------------------------------
  if( ( ( bx - u ) * ( u - cx ) ) > 0.0 ) then
! ---------------------------------------------------
     CALL F1D1M( fu, u, x1a, x2a, ya, y2a )
  if( fu < fc ) then
     ax = bx
     fa = fb
     bx = u
     fb = fu
     RETURN
  else if( fu > fb ) then
     cx = u
     fc = fu
     RETURN
  endif
     u = cx + gold * ( cx - bx )
     CALL F1D1M( fu, u, x1a, x2a, ya, y2a )
! ---------------------------------------------------------
  else if( ( ( cx - u ) * ( u - ulim ) ) > 0.0 ) then
! ---------------------------------------------------------
     CALL F1D1M( fu, u, x1a, x2a, ya, y2a )
  if( fu < fc ) then
     bx = cx
     cx = u
     u  = cx + gold * ( cx - bx )
     fb = fc
     fc = fu
     CALL F1D1M( fu, u, x1a, x2a, ya, y2a )
  endif
! ---------------------------------------------------------
  else if( ( ( u - ulim ) * ( ulim - cx ) ) >= 0.0 ) then
! ---------------------------------------------------------
     u = ulim
     CALL F1D1M( fu, u, x1a, x2a, ya, y2a )
! ---------------------------------------------------------
  else
! ---------------------------------------------------------
     u = cx + gold * ( cx - bx )
     CALL F1D1M( fu, u, x1a, x2a, ya, y2a )
! ---------------------------------------------------------
  endif
! ---------------------------------------------------------

  ax = bx
  bx = cx
  cx = u
  fa = fb
  fb = fc
  fc = fu

! %%%%%%%%%%%%%%%%%%%%%%
  GOTO 1
  endif
! %%%%%%%%%%%%%%%%%%%%%%

!-----------------------------------------------------------------------
  end SUBROUTINE MNBRAK

!########################################################################

  SUBROUTINE BRENT( ax, bx, cx, tol, fret, xmin, x1a, x2a, ya, y2a, ier)
!-----------------------------------------------------------------------
  implicit none

  real,    parameter :: cgold = 0.3819660
  real,    parameter :: zeps  = 1.0E-10
  integer, parameter :: itmax = 100

  real,    intent(in)                 :: ax,  bx, cx, tol
  real,    intent(in), dimension(:)   :: x1a, x2a
  real,    intent(in), dimension(:,:) :: ya,  y2a
  integer, intent(inout)              :: ier
  real,    intent(out)                :: fret, xmin

  integer :: l, m, iter
  real    :: a, b, v, w, x, e, fx, fv, fw, d, u, fu
  real    :: xm, tol1, tol2, r, q, p, etemp

!-----------------------------------------------------------------------

  l = SIZE( ya, 1 )
  m = SIZE( ya, 2 )

  a = MIN( ax, cx )
  b = MAX( ax, cx )
  v = bx
  w = v
  x = v
  e = 0.
  CALL F1D1M( fx, x, x1a, x2a, ya, y2a )
  fv = fx
  fw = fx

! %%%%%%%%%%%%%%%%%%%%%%
  do iter = 1,itmax
! %%%%%%%%%%%%%%%%%%%%%%

  xm   = 0.5 * ( a + b )
  tol1 = tol * ABS( x ) + zeps
  tol2 = 2.0 * tol1

  if( ABS( x - xm ) <= ( tol2 - 0.5 * ( b - a ) ) ) GOTO 3

! ---------------------------------------------------------
  if( ABS( e ) > tol1 ) then
! ---------------------------------------------------------
                  r = ( x - w ) * ( fx - fv )
                  q = ( x - v ) * ( fx - fw )
                  p = ( x - v ) * q - ( x - w ) * r
                  q = 2.0 * ( q - r )
    if( q > 0.0 ) p = -p
                  q = ABS( q )
              etemp = e
                  e = d

    if( ( ABS( p ) >= ABS( 0.5 * q * etemp ) ) .or.  &
        (      p   <= ( q * ( a - x ) )      ) .or.  &
        (      p   >= ( q * ( b - x ) )      )  ) GOTO 1

    d = p / q
    u = x + d

    if( ( ( u - a ) < tol2 )  .or. &
        ( ( b - u ) < tol2 ) ) d = SIGN( tol1, xm - x )
    GOTO 2

! ---------------------------------------------------------
  endif
! ---------------------------------------------------------

 1 CONTINUE
    if( x >= xm ) then
        e = a - x
    else
        e = b - x
    endif
        d = cgold * e

 2 CONTINUE
    if (abs(d) >= tol1) then
        u = x + d
    else
        u = x + SIGN( tol1, d )
    endif
        CALL F1D1M( fu, u, x1a, x2a, ya, y2a )

! ---------------------------------------------------------
  if( fu <= fx ) then
! ---------------------------------------------------------
    if( u >= x ) then
        a = x
    else
        b = x
    endif
         v =  w
        fv = fw
         w =  x
        fw = fx
         x =  u
        fx = fu
! ---------------------------------------------------------
  else
! ---------------------------------------------------------
    if( u < x ) then
        a = u
    else
        b = u
    endif
    if( ( fu <= fw ) .or. ( w == x ) ) then
         v =  w
        fv = fw
         w =  u
        fw = fu
    else if( ( fu <= fv ) .or. ( v == x ) .or. ( v == w ) ) then
         v =  u
        fv = fu
    endif
! ---------------------------------------------------------
  endif
! ---------------------------------------------------------

! %%%%%%%%%%%%%%%%%%%%%%
  end do
! %%%%%%%%%%%%%%%%%%%%%%

  ier = 1
  PRINT *, ' *** Brent: exceed maximum iterations'

 3 CONTINUE
   xmin = x
   fret = fx

!-----------------------------------------------------------------------
  end SUBROUTINE BRENT

!########################################################################

  SUBROUTINE SHAPE( x1a,  x2a,  ya,   y2a,     y3a, p, &
                    ftol, iter, fret, ierror2, val, dist_val )
!-----------------------------------------------------------------------
! Given a starting point P that is a vector of length N, Fletcher-Reeves
! Polak-Ribiere minimization is performed on a function FUNV, using its
! gradient as calculated by a routine DFUNC,. The convergence tolerance
! on the function value is input as FTOL. Returned quantities are P
! (the location of the minimum), ITER (the number of iterations
! that were performed), and FRET(the minimum value of the function).
! The routine LINMIN1 is called to perform line minimizations.
! Maximum anticipated value of N; maximum allowed number of iterations;
! small number to rectify special case of converging to exactly zero
! function value.
!-----------------------------------------------------------------------
  implicit none

  real,    intent(in),  dimension(:)   :: x1a, x2a, p
  real,    intent(in),  dimension(:,:) :: ya,  y2a, y3a
  real,    intent(in)                  :: val, dist_val
  integer, intent(inout)               :: ierror2

  real,    intent(in)  :: ftol         ! ===> NOT REFERENCED
  integer, intent(out) :: iter         ! ===> NOT REFERENCED
  real,    intent(out) :: fret         ! ===> NOT REFERENCED

  real, dimension(SIZE(p))               :: q,  g,   h, xi
  real, dimension(SIZE(ya,1),SIZE(ya,2)) :: ta, t2a, t3a

  integer :: l,  m, n, i, ier
  real    :: dr, fret1

 real, dimension(8) :: xi1 = (/ 0.,  0., 1., -1.,  1., 1., -1., -1. /)
 real, dimension(8) :: xi2 = (/ 1., -1., 0.,  0., -1., 1.,  1., -1. /)

!-----------------------------------------------------------------------

  l = SIZE( ya, 1 )
  m = SIZE( ya, 2 )
  n = SIZE( p     )

   ta(:,:) =  -ya(:,:)
  t2a(:,:) = -y2a(:,:)
  t3a(:,:) = -y3a(:,:)

  do i = 1,8
! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  if( ierror2 == 0 ) then
         q(1) =   p(1)
         q(2) =   p(2)
        xi(1) = xi1(i)
        xi(2) = xi2(i)
  CALL LINMIN1( q, xi, fret1, x1a, x2a, ta, t2a, ier, val, dist_val )
        dr = ( p(1) - q(1) )**2 + ( p(2) - q(2) )**2
    if( dr >= 100.0 ) ierror2 = 1
    if( ier == 1    ) ierror2 = 1
  end if
! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  end do

!-----------------------------------------------------------------------
  end SUBROUTINE SHAPE

!########################################################################
 end MODULE SPLINE_MOD


! written by jxzou at 20200607
! This version of mo_svd read overlap, dipole matrix, etc from formatted files
!  (like the Gaussian .log/.out file with iop(3/33=1), OpenMolcas output file
!  with 'print' keyword in &SEWARD) and performs SVD on the overlap of two sets of MOs.

! Another version file mo_svd.f90 reads overlap matrix from memory when running PySCF,
! thus that file is compiled by f2py wrapper. While this file is compiled by gfortran/ifort.

! Three arguments are: orbital file1, orbital file2, and output file containing
! AO-basis overlap. If the first argument ends with .fch, this will be identified
! as the Gaussian case. Otherwise it will be identified as the OpenMolcas case.

program main
 implicit none
 integer :: i, idx1, idx2
 integer, parameter :: iout = 6
 character(len=10) :: str
 character(len=240) :: fname1, fname2, ovlp_file

 i = iargc()
 if(i /= 5) then
  write(iout,'(/,A)') ' ERROR in subroutine mo_svd: wrong command line arguments!'
  write(iout,'(/,A)') ' Example 1(Gaussian): mo_svd a.fch b.fch a.log idx1 idx2'
  write(iout,'(/,A,/)') ' Example 2(OpenMolcas): mo_svd a.INPORB b.RasOrb a.out idx1 idx2'
  stop
 end if

 fname1 = ' '
 fname2 = ' '
 ovlp_file = ' '
 call getarg(1, fname1)
 call getarg(2, fname2)
 call getarg(3, ovlp_file)
 call getarg(4, str)
 read(str,*) idx1
 call getarg(5, str)
 read(str,*) idx2

 call mo_svd(fname1, fname2, ovlp_file, idx1, idx2)
 stop
end program main

subroutine mo_svd(fname1, fname2, ovlp_file, idx1, idx2)
 implicit none
 integer :: i, j, nbf, nif, nmo
 integer, parameter :: iout = 6
 integer, intent(in) :: idx1, idx2
 character(len=240), intent(in) :: fname1, fname2, ovlp_file
 real(kind=8), allocatable :: S(:,:), mo_ovlp(:,:), SC(:,:)
 real(kind=8), allocatable :: coeff1(:,:), coeff2(:,:)
 real(kind=8), allocatable :: u(:,:), vt(:,:), ev(:)
 logical :: gau

 i = index(fname1, '.txt', back=.true.)
 if(i /= 0) then ! Gaussian case
  gau = .true.
  call read_nbf_and_nif_from_fch(fname1, nbf, nif)
 else ! i == 0, OpenMolcas case
  gau = .false.
  call read_nbf_and_nif_from_orb(fname1, nbf, nif)
 end if

 nmo = idx2 - idx1 + 1
 allocate(coeff1(nbf,nif), source=0.0d0)
 allocate(coeff2(nbf,nif), source=0.0d0)
 allocate(S(nbf,nbf), source=0.0d0)

 if(gau) then ! Gaussian case
  call read_mo_from_fch(fname1, nbf, nif, 'a', coeff1)
  call read_mo_from_fch(fname2, nbf, nif, 'a', coeff2)
!  call read_mo_from_chk_txt(fname1, nbf, nif, 'a', coeff1)
!  call read_mo_from_chk_txt(fname2, nbf, nif, 'a', coeff2)
  call read_int1e_from_gau_log(ovlp_file, 1, nbf, S)
 else         ! OpenMolcas case
  call read_mo_from_orb(fname1, nbf, nif, 'a', coeff1)
  call read_mo_from_orb(fname2, nbf, nif, 'a', coeff2)
  call read_ovlp_from_molcas_out(ovlp_file, nbf, S)
 end if

 ! check orthonormality
 allocate(mo_ovlp(nif,nif), source=0.0d0)
 mo_ovlp = MATMUL(TRANSPOSE(coeff1), MATMUL(S,coeff1))
 write(*,'(A)') 'orthonormality of file1:'
 do i = 1, nif, 1
  do j = i, nif, 1
   if(j==i) mo_ovlp(j,i) = mo_ovlp(j,i) - 1.0d0
   if(DABS(mo_ovlp(j,i)) > 1.0d-6) write(iout,'(2I6,F15.8)') j, i, mo_ovlp(j,i)
  end do ! for j
 end do ! for i
 mo_ovlp = MATMUL(TRANSPOSE(coeff2), MATMUL(S,coeff2))
 write(*,'(A)') 'orthonormality of file2:'
 do i = 1, nif, 1
  do j = i, nif, 1
   if(j==i) mo_ovlp(j,i) = mo_ovlp(j,i) - 1.0d0
   if(DABS(mo_ovlp(j,i)) > 1.0d-6) write(iout,'(2I6,F15.8)') j, i, mo_ovlp(j,i)
  end do ! for j
 end do ! for i
 deallocate(mo_ovlp)
 ! check done

 ! compute the MO-basis overlap matrix (C1^T)SC2
 allocate(SC(nbf,nmo), source=0.0d0)
 call dsymm('L', 'U', nbf, nmo, 1.0d0, S, nbf, coeff2(:,idx1:idx2), nbf, 0.0d0, SC, nbf)
 deallocate(S, coeff2)
 allocate(mo_ovlp(nmo,nmo), source=0.0d0)
 call dgemm('T', 'N', nmo, nmo, nbf, 1.0d0, coeff1(:,idx1:idx2), nbf, SC, nbf, 0.0d0, mo_ovlp, nmo)
 deallocate(SC, coeff1)

 ! perform SVD on the MO-basis overlap matrix
 allocate(u(nmo,nmo), vt(nmo,nmo), ev(nmo))
 call svd_on_ovlp(nmo, nmo, mo_ovlp, u, vt, ev)
 deallocate(mo_ovlp, u, vt)

 write(iout,'(/,A)') 'SVD analysis of two sets of MOs:'
 write(iout,'(A,ES15.8)') 'The smallest singular value:', MINVAL(ev)
 i = COUNT(ev < 0.1d0)
 write(iout,'(A,I0)') 'Number of singular values< 0.1: ', i
 i = COUNT(ev < 0.01d0)
 write(iout,'(A,I0)') 'Number of singular values<0.01: ', i

 write(iout,'(A)') 'All singular values:'
 write(iout,'(5(1X,ES15.8))') (ev(i),i=1,nmo)
 deallocate(ev)
 return
end subroutine mo_svd

! perform SVD on a given overlap matrix
subroutine svd_on_ovlp(m, n, a, u, vt, s)
 implicit none
 integer :: i, lwork
 integer, intent(in) :: m,n
 integer, parameter :: iout = 6
 real(kind=8), intent(in) :: a(m,n)
 real(kind=8), intent(out) :: u(m,m), vt(n,n), s(m)
 real(kind=8), allocatable :: work(:)
 real(kind=8) :: a_copy(m,n)

 a_copy = a
 u = 0.0d0; vt = 0.0d0; s = 0.0d0

 ! ?gesvd: Computes the singular value decomposition of a general rectangular matrix
 ! Syntax FORTRAN 77:
 ! call dgesvd(jobu, jobvt, m, n, a, lda, s, u, ldu, vt, ldvt, work, lwork, info)
 lwork = -1
 allocate(work(1))
 work = 0
 call dgesvd('A', 'A', m, n, a_copy, m, s, u, m, vt, n, work, lwork, i)
 lwork = CEILING(work(1))
 deallocate(work)
 allocate(work(lwork))
 call dgesvd('A', 'A', m, n, a_copy, m, s, u, m, vt, n, work, lwork, i)

 deallocate(work)
 if(i /= 0) then
  write(iout,'(A)') 'ERROR: info /= 0 in subroutine svd_on_ovlp. Please check why.'
  write(iout,'(A5,I0)') 'info=',i
  stop
 end if
 return
end subroutine svd_on_ovlp


subroutine diffuse(x1, y1, z1, ib, jb, kb, dt,imt,jmt,km,dxv,dyu,dzt,h,ah,av,do3d,doturb)

!============================================================================
! Add a small displacement to a particle s.t. it is still in the model area.
!
!  Input:
!    dt             : time step of trajectory iteration in seconds
!    imt,jmt,km     : grid index sizing constants in (x,y,z), are for
!                     horizontal and vertical rho grid [scalar]
!    dxv            : Horizontal grid cell walls areas in x direction [imt,jmt-1]
!    dyu            : Horizontal grid cell walls areas in y direction [imt-1,jmt]
!    dzt            : Height of k-cells in 3 dim in meters on rho vertical grid. [imt,jmt,km]
!    h              : Depths [imt,jmt]
!    ah             : horizontal diffusion in m^2/s. Input parameter.
!                   : For -turb and -diffusion flags
!    av             : vertical diffusion in m^2/s. Input parameter. For -diffusion flag.
!    do3d           : Flag to set whether to use 3d velocities or not
!    doturb         : Flag to set whether or not to use turb/diff and which kind if so
!
!  Input/Output:
!    x1, y1, z1     : Current positions of the particle. Are updated by the subroutine.
!    ib, jb, kb     : Indices for current box for the particle. Are updated by the subroutine.
!
!  Other parameters used in function:
!    tmpX, tmpY, tmpZ   : Temporal position
!    xd, yd, zd         : Displacement
!    itno               : Number of iterations
!    tmpi, tmpj, tmpk   : Temporal box indices
!    tryAgain           : Tells whether to continue displace
!============================================================================

implicit none

integer,        intent(in)                                  :: do3d, doturb
real(kind=8),   intent(in)                                  :: ah,av,dt
real*8,         intent(in),     dimension(imt-1,jmt)        :: dyu
real*8,         intent(in),     dimension(imt,jmt-1)        :: dxv
real*8,         intent(in),     dimension(imt,jmt)          :: h
real(kind=8),   intent(in),     dimension(imt,jmt,km,2)     :: dzt
integer,        intent(in)                                  :: imt,jmt,km
real(kind=8),   intent(in out)                              :: x1, y1, z1
integer,        intent(in out)                              :: ib,jb,kb
integer                                                     :: itno,tmpi, tmpj, tmpk
real(kind=8)                                                :: xd, yd, zd, tmpX, tmpY, tmpZ
logical                                                     :: tryAgain

! print *,''
! print *,'start of diffusion'
! print *,'x1=',x1,' y1=',y1,' ib=',ib,' jb=',jb

tryAgain = .FALSE.

! Is particle within model area?
! KMT: I do not understand how the vertical checks are correct here, so I am changing them

!   if(ib>=1 .AND. ib<=imt .AND. jb>=1 .AND. jb<=jmt .AND. km+1-kmt(ib,jb)<=kb .AND. kb>=1 ) then
if(ib>1 .AND. ib<imt .AND. jb>1 .AND. jb<jmt .AND. km>=kb .AND. kb>=1 ) then
    tryAgain = .TRUE.
else
!     print *,'outside model domain in diffusion',ib,jb,km,kb
! !     print *,'outside model domain in diffusion',ib,jb,km+1-kmt(ib,jb),kb
end if

itno=0
do while(tryAgain)
    itno=itno+1
    ! find random displacement
    call displacement(xd, yd, zd, ib, jb, dt,imt,jmt,h,ah,av,dxv,dyu,do3d,doturb)
!     CALL displacement(xd, yd, zd, ib, jb, kb, dt,imt,jmt,kmt,h,ah,av)
!     print *,'xd=',xd,' yd=',yd,' zd=',zd
!     print *,'dzt(ib,jb,:,1)=',dzt(ib,jb,:,1)
    ! Convert displacement from meters to model coordinates
    ! KMT note: following example in master code for orc project
    xd = xd/dxv(ib,jb)
    yd = yd/dyu(ib,jb)
    zd = zd/dzt(ib,jb,kb,1) !KMT: this should be better than dz()
!     print *,'dzt(ib,jb,kb,1)=',dzt(ib,jb,kb,1)

    ! TO DO: improve so that dzt is calculated including free surface and for correct time
!     zd = zd/dz(kb) !should be replaced for bottom box and include ssh (original note)

!     print *,'xd=',xd,' yd=',yd,' zd=',zd

    ! Update position temporarily
    tmpX = x1 + xd
    tmpY = y1 + yd
    tmpZ = z1 + zd
    ! Update box number temporarily
    tmpi = int(tmpX) + 1
    tmpj = int(tmpY) + 1
    tmpk = int(tmpZ) + 1
!     print *,'temp dzt(ib,jb,kb,1)=',dzt(tmpi,tmpj,tmpk,1)

!     ! Check if particle is on an open boundary. Using rco example.
!     if(tmpi==1 .AND. tmpj>=1 .AND. tmpj<=jmt .AND. km+1-kmt(tmpi,tmpj)<=tmpk .AND. tmpk>=1 ) then
!         tryAgain = .FALSE.
!     end if

    ! check that column is deep enough
    ! KMT: this is the same check as above that looks wrong and I changed
!     if( 1<=tmpi .AND. tmpi<=imt .AND. 1<=tmpj .AND. tmpj<=jmt .AND. km+1-kmt(tmpi,tmpj)<=tmpk .AND. tmpk>=1 ) then
    if(tmpi>1 .AND. tmpi<imt .AND. tmpj>1 .AND. tmpj<jmt .AND. km>=tmpk .AND. tmpk>=1 ) then
!         print *,'km=',km,' km+1-kmt(tmpi,tmpj)=',km+1-kmt(tmpi,tmpj),' tmpk=',tmpk
        tryAgain = .FALSE.
!         print *,'found new position for drifter that is within model domain, so move on.'
        ! if false then a new position for the particle has been found and we exit the loop
    end if

    ! KMT: Need to check to see if new position is on masked land.
    ! Can do this by checking dzt at the new position, which is zero when on land.
    ! If we are on land, keep tryAgain = .TRUE. so that this displacement choice is
    ! not used. This can alter the value of tryAgain just given above.
    if(dzt(tmpi,tmpj,tmpk,1)==0.) then
        tryAgain = .TRUE.
    endif

    ! If tryAgain is still true, the particle is outside model area. The
    ! displacement is not saved, but we make a new try to displace.

    ! "Infinite loop?"
    if(itno>=100000 .AND. tryAgain) then
        tryAgain = .FALSE.
        write(*,*)"Particle stuck in infinite diffusion loop. No diffusion added.",ib,jb,kb
        stop 34956
        tmpX=x1 ; tmpY=y1 ; tmpZ=z1
        tmpi=ib ; tmpj=jb ; tmpk=kb
    end if

  enddo

! Update return position
! if(abs(x1-tmpX).gt.5. .and. abs(x1-tmpX).lt.1000.) print *,x1,tmpX,xd,ib,jb,dxv(ib,jb)
x1 = tmpX
y1 = tmpY
ib = tmpi
jb = tmpj

! print *,'After diffusion'
! print *,'x1=',x1,' y1=',y1,' ib=',ib,' jb=',jb

if(do3d==1) then
    z1 = tmpZ
    kb = tmpk
endif

if(x1.ne.dble(idint(x1))) ib=idint(x1)+1 ! make sure the index corresponds to the right grid cell

!print *,'slut',itno,kmt(ib,jb),ib,jb,kb,x1,y1,z1

end subroutine diffuse

!===============================================================================
! Calculate a random displacement
! (sqrt(-4ah*dt*log(1-q1))*cos(2PIq2),
!  sqrt(-4ah*dt*log(1-q1))*sin(2PIq2),
!  sqrt(-4av*dt*log(1-q3))*cos(2PIq4))
! where av and ah are set in run.in, dt is the model time step and q1,q2,q3,q4 are random
! numbers between 0 and 1.
!
! Arguments :
! xd, yd, zd : Variables in which the displacement will be stored
! dt: Model time step
!===============================================================================
subroutine displacement(xd, yd, zd, ib, jb, dt,imt,jmt,h,ah,av,dxv,dyu,do3d,doturb)

implicit none

integer,        intent(in)                          :: ib,jb,imt,jmt   ! box indices
integer,        intent(in)                          :: do3d, doturb
real(kind=8),   intent(in)                          :: dt,ah,av
real*8,         intent(in), dimension(imt,jmt)      :: h
real*8,         intent(in), dimension(imt-1,jmt)    :: dyu
real*8,         intent(in), dimension(imt,jmt-1)    :: dxv
real(kind=8),   intent(out)                         :: xd, yd, zd
real(kind=8),   parameter                           :: pi = 3.14159265358979323846
real(kind=8)                                        :: q1, q2, q3, q4, r, elip, xx, yy
real(kind=8)                                        :: grdx, grdy, grad, theta
integer                                             :: ip,im,jp,jm

! random generated numbers between 0 and 1
q1 = rand()
q2 = rand()
q3 = rand()
q4 = rand()

! Horizontal displacements in meters
R = sqrt(-4*ah*dt*log(1-q1))
xd = R * cos(2*PI*q2)
yd = R * sin(2*PI*q2)

! Vertical displacement in meters
if(do3d==1) then
    R = sqrt(-4*av*dt*log(1-q3))
    zd = R*cos(2*PI*q4)
else
    zd = 0.
endif

! print *,' '
! print *,'circle'
! print *,'xd=',xd,' yd=',yd

if(doturb==3) then
    !_______________________________________________________________________________
    ! The diffusion is here set on an ellipse instead of a circle
    ! so that the diffusion is higher along the isobaths and weaker
    ! in the perpendicular direction (up/downhill)

    ! for index in i direction for one cell positive from the current cell
    ip=ib+1
    ! KMT: Is this a periodic BC? Replace with just the edge value so it won't
    ! elliptical but just at the edge.
    ! I think the check should happen for ip==imt since in the x direction for u
    ! the grid only goes up to imt-1 for the arakawa c grid.
    if(ip.eq.imt) ip = imt-1 ! use ib instead of ib+1, and here ib=imt-1
!     if(ip.eq.imt+1) ip=1

    ! for index in i direction for one cell negative from the current cell
    im=ib-1
    ! KMT: Is this a periodic BC? Replace with just the edge value so it won't
    ! elliptical but just at the edge.
    if(im.eq.0) im = 1 ! use ib instead of ib-1, and here ib=1
!     if(im.eq.0) im=imt

     ! for index in j direction for one cell positive from the current cell
    jp=jb+1
    ! KMT: In v they don't use period BC.
    ! I think the check should happen for jp==jmt since in the y direction for v
    ! the grid only goes up to jmt-1 for the arakawa c grid.
    if(jp.eq.jmt) jp = jmt-1 ! use jb instead of jb+1, and here jb=jmt-1
!     if(jp.eq.jmt+1) jp=jmt

    ! for index in j direction for one cell negative from the current cell
    jm=jb-1
    ! KMT: In v they don't use period BC and this check is fine as is.
    if(jm.eq.0) jm = 1

    ! just depth gradient
    ! grdx=float(kmt(ip,jb)-kmt(im,jb)) ! zonal      depth gradient (zw should be used)
    ! grdy=float(kmt(ib,jp)-kmt(ib,jm)) ! meridional depth gradient
    ! KMT: switching the bathymetry/depths array and grid distances in here
    ! since user manual (pg 21) shows grdx=\Delta h/\Delta x, for example
!     grdx=(h(ip,jb)-h(im,jb))/(0.5*(dxv(im,jb)+dxv(ib,jb))+0.5*(dxv(ib,jb)+dxv(ip,jb))) ! zonal depth gradient
    ! Same as easier-to-read previous line but more efficient:
    grdx=(h(ip,jb)-h(im,jb))/(0.5*dxv(im,jb) + 0.5*dxv(ip,jb) + dxv(ib,jb)) ! zonal depth gradient

!     grdy=(h(ib,jp)-h(ib,jm))/(0.5*(dyu(ib,jm)+dyu(ib,jb)) + 0.5*(dyu(ib,jb)+dyu(ib,jp))) ! meridional depth gradient
    ! Same as easier-to-read previous line but more efficient:
    grdy=(h(ib,jp)-h(ib,jm))/(0.5*dyu(ib,jm) + dyu(ib,jb) + 0.5*dyu(ib,jp)) ! meridional depth gradient

    grad=dsqrt(grdx**2+grdy**2)       ! total depth gradient

    ! angle between the eastward direction and
    ! the constant depth direction (=0 if only meridional slope)
    if(grad.eq.0.d0) then
        ! theta=0.d0 + pi/2.d0
        theta=0.d0
    else
        ! theta=dasin(grdx/grad) +pi/2.d0 ! varför 90 grader mer? ny2
        theta=dasin(grdx/grad) ! ny1
    endif

    ! elliptic horizontal distribution of the diffusion
    !elip=dabs(1.d2*grad)+1.d0 ! för 1/h
    !elip=dabs(1.d-2*grad)+1.d0 ! för h
    elip=dabs(grad)+1.d0 ! för h

    !elip=amin1(10.d0,grad) ! gives slightly higher relative dispersion
    elip=amin1(5.d0,elip) !

    !print *,'elip=',elip,grad,theta

    !The circular disk is stretched into an elliptic disk
    ! with unchanges surface area by
    xx=xd*elip
    yy=yd/elip

    ! coordinate transformation to put the diffusion on an
    ! ellipse with the maxium diffusion along the isobaths
    xd= xx*dcos(theta)-yy*dsin(theta)
    yd=-xx*dsin(theta)+yy*dcos(theta)

!     print *,'ellipse'
!     print *,'xd=',xd,' yd=',yd
    ! print *,'theta=',theta,' xx=',xx,' yy=',yy,' grdx=',grdx,' grdy=',grdy

    !print *,'theta=',theta*180./pi,elip,grdx/grad

    !if(jb.gt.400) stop 3096
    !_______________________________________________________________________________
endif

end subroutine displacement


*DECK QAWS
      SUBROUTINE QAWS (F, A, B, ALFA, BETA, INTEGR, EPSABS, EPSREL,
     +   RESULT, ABSERR, NEVAL, IER, LIMIT, LENW, LAST, IWORK, WORK)
C***BEGIN PROLOGUE  QAWS
C***PURPOSE  The routine calculates an approximation result to a given
C            definite integral I = Integral of F*W over (A,B),
C            (where W shows a singular behaviour at the end points
C            see parameter INTEGR).
C            Hopefully satisfying following claim for accuracy
C            ABS(I-RESULT).LE.MAX(EPSABS,EPSREL*ABS(I)).
C***LIBRARY   SLATEC (QUADPACK)
C***CATEGORY  H2A2A1
C***TYPE      SINGLE PRECISION (QAWS-S, DQAWS-D)
C***KEYWORDS  ALGEBRAIC-LOGARITHMIC END POINT SINGULARITIES,
C             AUTOMATIC INTEGRATOR, CLENSHAW-CURTIS METHOD,
C             GLOBALLY ADAPTIVE, QUADPACK, QUADRATURE, SPECIAL-PURPOSE
C***AUTHOR  Piessens, Robert
C             Applied Mathematics and Programming Division
C             K. U. Leuven
C           de Doncker, Elise
C             Applied Mathematics and Programming Division
C             K. U. Leuven
C***DESCRIPTION
C
C        Integration of functions having algebraico-logarithmic
C        end point singularities
C        Standard fortran subroutine
C        Real version
C
C        PARAMETERS
C         ON ENTRY
C            F      - Real
C                     Function subprogram defining the integrand
C                     function F(X). The actual name for F needs to be
C                     declared E X T E R N A L in the driver program.
C
C            A      - Real
C                     Lower limit of integration
C
C            B      - Real
C                     Upper limit of integration, B.GT.A
C                     If B.LE.A, the routine will end with IER = 6.
C
C            ALFA   - Real
C                     Parameter in the integrand function, ALFA.GT.(-1)
C                     If ALFA.LE.(-1), the routine will end with
C                     IER = 6.
C
C            BETA   - Real
C                     Parameter in the integrand function, BETA.GT.(-1)
C                     If BETA.LE.(-1), the routine will end with
C                     IER = 6.
C
C            INTEGR - Integer
C                     Indicates which WEIGHT function is to be used
C                     = 1  (X-A)**ALFA*(B-X)**BETA
C                     = 2  (X-A)**ALFA*(B-X)**BETA*LOG(X-A)
C                     = 3  (X-A)**ALFA*(B-X)**BETA*LOG(B-X)
C                     = 4  (X-A)**ALFA*(B-X)**BETA*LOG(X-A)*LOG(B-X)
C                     If INTEGR.LT.1 or INTEGR.GT.4, the routine
C                     will end with IER = 6.
C
C            EPSABS - Real
C                     Absolute accuracy requested
C            EPSREL - Real
C                     Relative accuracy requested
C                     If  EPSABS.LE.0
C                     and EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28),
C                     the routine will end with IER = 6.
C
C         ON RETURN
C            RESULT - Real
C                     Approximation to the integral
C
C            ABSERR - Real
C                     Estimate of the modulus of the absolute error,
C                     Which should equal or exceed ABS(I-RESULT)
C
C            NEVAL  - Integer
C                     Number of integrand evaluations
C
C            IER    - Integer
C                     IER = 0 Normal and reliable termination of the
C                             routine. It is assumed that the requested
C                             accuracy has been achieved.
C                     IER.GT.0 Abnormal termination of the routine
C                             The estimates for the integral and error
C                             are less reliable. It is assumed that the
C                             requested accuracy has not been achieved.
C            ERROR MESSAGES
C                     IER = 1 Maximum number of subdivisions allowed
C                             has been achieved. One can allow more
C                             subdivisions by increasing the value of
C                             LIMIT (and taking the according dimension
C                             adjustments into account). However, if
C                             this yields no improvement it is advised
C                             to analyze the integrand, in order to
C                             determine the integration difficulties
C                             which prevent the requested tolerance from
C                             being achieved. In case of a jump
C                             discontinuity or a local singularity
C                             of algebraico-logarithmic type at one or
C                             more interior points of the integration
C                             range, one should proceed by splitting up
C                             the interval at these points and calling
C                             the integrator on the subranges.
C                         = 2 The occurrence of roundoff error is
C                             detected, which prevents the requested
C                             tolerance from being achieved.
C                         = 3 Extremely bad integrand behaviour occurs
C                             at some points of the integration
C                             interval.
C                         = 6 The input is invalid, because
C                             B.LE.A or ALFA.LE.(-1) or BETA.LE.(-1) or
C                             or INTEGR.LT.1 or INTEGR.GT.4 or
C                             (EPSABS.LE.0 and
C                              EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28))
C                             or LIMIT.LT.2 or LENW.LT.LIMIT*4.
C                             RESULT, ABSERR, NEVAL, LAST are set to
C                             zero. Except when LENW or LIMIT is invalid
C                             IWORK(1), WORK(LIMIT*2+1) and
C                             WORK(LIMIT*3+1) are set to zero, WORK(1)
C                             is set to A and WORK(LIMIT+1) to B.
C
C         DIMENSIONING PARAMETERS
C            LIMIT  - Integer
C                     Dimensioning parameter for IWORK
C                     LIMIT determines the maximum number of
C                     subintervals in the partition of the given
C                     integration interval (A,B), LIMIT.GE.2.
C                     If LIMIT.LT.2, the routine will end with IER = 6.
C
C            LENW   - Integer
C                     Dimensioning parameter for WORK
C                     LENW must be at least LIMIT*4.
C                     If LENW.LT.LIMIT*4, the routine will end
C                     with IER = 6.
C
C            LAST   - Integer
C                     On return, LAST equals the number of
C                     subintervals produced in the subdivision process,
C                     which determines the significant number of
C                     elements actually in the WORK ARRAYS.
C
C         WORK ARRAYS
C            IWORK  - Integer
C                     Vector of dimension LIMIT, the first K
C                     elements of which contain pointers
C                     to the error estimates over the subintervals,
C                     such that WORK(LIMIT*3+IWORK(1)), ...,
C                     WORK(LIMIT*3+IWORK(K)) form a decreasing
C                     sequence with K = LAST if LAST.LE.(LIMIT/2+2),
C                     and K = LIMIT+1-LAST otherwise
C
C            WORK   - Real
C                     Vector of dimension LENW
C                     On return
C                     WORK(1), ..., WORK(LAST) contain the left
C                      end points of the subintervals in the
C                      partition of (A,B),
C                     WORK(LIMIT+1), ..., WORK(LIMIT+LAST) contain
C                      the right end points,
C                     WORK(LIMIT*2+1), ..., WORK(LIMIT*2+LAST)
C                      contain the integral approximations over
C                      the subintervals,
C                     WORK(LIMIT*3+1), ..., WORK(LIMIT*3+LAST)
C                      contain the error estimates.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  QAWSE, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   800101  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C***END PROLOGUE  QAWS
C
      REAL A,ABSERR,ALFA,B,BETA,EPSABS,EPSREL,F,RESULT,WORK
      INTEGER IER,INTEGR,IWORK,LENW,LIMIT,LVL,L1,L2,L3,NEVAL
C
      DIMENSION IWORK(*),WORK(*)
C
      EXTERNAL F
C
C         CHECK VALIDITY OF LIMIT AND LENW.
C
C***FIRST EXECUTABLE STATEMENT  QAWS
      IER = 6
      NEVAL = 0
      LAST = 0
      RESULT = 0.0E+00
      ABSERR = 0.0E+00
      IF(LIMIT.LT.2.OR.LENW.LT.LIMIT*4) GO TO 10
C
C         PREPARE CALL FOR QAWSE.
C
      L1 = LIMIT+1
      L2 = LIMIT+L1
      L3 = LIMIT+L2
C
      CALL QAWSE(F,A,B,ALFA,BETA,INTEGR,EPSABS,EPSREL,LIMIT,RESULT,
     1  ABSERR,NEVAL,IER,WORK(1),WORK(L1),WORK(L2),WORK(L3),IWORK,LAST)
C
C         CALL ERROR HANDLER IF NECESSARY.
C
      LVL = 0
10    IF(IER.EQ.6) LVL = 1
      IF (IER .NE. 0) CALL XERMSG ('SLATEC', 'QAWS',
     +   'ABNORMAL RETURN', IER, LVL)
      RETURN
      END


!      Ken Klare, LANL P-4      (c)1990,1991
!***********************************************************************
!********************* 3.2 Cubic Spline Evaluation *********************
!-----------------------------------------------------------------------
      Real Function CSVAL(x,nintv,break,c)
      Real      x      !input, the point to evaluate
      Integer nintv      !input, the number of polynomial pieces
      Real      break(*)!input, [nintv+1] breakpoints
      Real      c(4,*)      !input, [4,nintv+1] polynomial coefficients
!+Cubic spline evaluation.
      Real      PPDER
      CSVAL = PPDER(0,x,4,nintv,break,c)
      End
!-----------------------------------------------------------------------
      Real Function CSDER(ideriv,x,nintv,break,c)
      Integer ideriv      !input, the order of deriavtive to be evaluated
      Real      x      !input, the point to evaluate
      Integer nintv      !input, the number of polynomial pieces
      Real      break(*)!input, [nintv+1] breakpoints
      Real      c(4,*)      !input, [4,nintv+1] polynomial coefficients
!+Cubic spline derivative evaluation.
      Real      PPDER
      CSDER = PPDER(ideriv,x,4,nintv,break,c)
      End
!-----------------------------------------------------------------------
      Real Function CSITG(a,b,nintv,break,c)
      Real      a,b      !input, the range to evaluate
      Integer nintv      !input, the number of polynomial pieces
      Real      break(*)!input, [nintv+1] breakpoints
      Real      c(4,*)      !input, [4,nintv+1] polynomial coefficients
!+Cubic spline evaluation.
      Real      PPITG
      CSITG = PPITG(a,b,4,nintv,break,c)
      End
!***********************************************************************
!********************* Vector extensions *******************************
!-----------------------------------------------------------------------
      Subroutine CSVALV(nx,x,nintv,break,c,y)
!     ENTRY CSVALV_(nx,x,nintv,break,c,y)
      Integer      nx      !input, the number of points
      Real      x(*)      !input, the [nx] points to evaluate
      Integer nintv      !input, the number of polynomial pieces
      Real      break(*)!input, [nintv+1] breakpoints
      Real      c(4,*)      !input, [4,nintv+1] polynomial coefficients
      Real      y(*)      !output, the evaluated points
!+Cubic spline evaluation.
      Call PPDERV(0,nx,x,4,nintv,break,c,y)
      End
!-----------------------------------------------------------------------
      Subroutine CSDERV(ideriv,nx,x,nintv,break,c,y)
!     ENTRY CSDERV_(ideriv,nx,x,nintv,break,c,y)
      Integer ideriv      !input, the order of deriavtive to be evaluated
      Integer      nx      !input, the number of points
      Real      x(*)      !input, the [nx] points to evaluate
      Integer nintv      !input, the number of polynomial pieces
      Real      break(*)!input, [nintv+1] breakpoints
      Real      c(4,*)      !input, [4,nintv+1] polynomial coefficients
      Real      y(*)      !output, the evaluated points
!+Cubic spline derivative evaluation.
      Call PPDERV(ideriv,nx,x,4,nintv,break,c,y)
      End
!-----------------------------------------------------------------------
      Subroutine CSITGV(na,a,nb,b,nintv,break,c,y)
!     ENTRY CSITGV_(na,a,nb,b,nintv,break,c,y)
      Integer      na      !input, the number of points
      Real      a(*)      !input, the [na] points to evaluate
      Integer      nb      !input, the number of points
      Real      b(*)      !input, the [nb] points to evaluate
      Integer nintv      !input, the number of polynomial pieces
      Real      break(*)!input, [nintv+1] breakpoints
      Real      c(4,*)      !input, [4,nintv+1] polynomial coefficients
      Real      y(*)      !output, the evaluated points
!+Cubic spline evaluation.
      Call PPITGV(na,a,nb,b,4,nintv,break,c,y)
      End


!---------------------------------------------------------------------!
! OWNER: Ithaca Combustion Enterprise, LLC                            !
! COPYRIGHT: © 2012, Ithaca Combustion Enterprise, LLC                !
! LICENSE: BSD 3-Clause License (The complete text of the license can !
!  be found in the `LICENSE-ICE.txt' file included in the ISAT-CK7    !
!  source directory.)                                                 !
!---------------------------------------------------------------------!

subroutine ell_low2chol( n, l, g )

!  l contains the lower triangle L of the n x n PSD matrix A,
!  in packed format.
!  The Cholesky lower triangle G,  A = G * G^T is returned in g
!  in packed format in g.

implicit none
integer, parameter      :: k_dp = kind(1.d0)
integer, intent(in)     :: n
real(k_dp), intent(in)  :: l((n*(n+1))/2)
real(k_dp), intent(out) :: g((n*(n+1))/2)

integer :: info

g = l
call dpptrf( 'L', n, g, info )

if( info /= 0 ) then
   write(0,*)'ell_low2chol: info = ', info
   stop
endif

return
end subroutine ell_low2chol


      SUBROUTINE cumf(f,dfn,dfd,cum,ccum)
C**********************************************************************
C
C     SUBROUTINE CUMF(F,DFN,DFD,CUM,CCUM)
C                    CUMulative F distribution
C
C
C                              Function
C
C
C     Computes  the  integral from  0  to  F of  the f-density  with DFN
C     and DFD degrees of freedom.
C
C
C                              Arguments
C
C
C     F --> Upper limit of integration of the f-density.
C                                                  F is DOUBLE PRECISION
C
C     DFN --> Degrees of freedom of the numerator sum of squares.
C                                                  DFN is DOUBLE PRECISI
C
C     DFD --> Degrees of freedom of the denominator sum of squares.
C                                                  DFD is DOUBLE PRECISI
C
C     CUM <-- Cumulative f distribution.
C                                                  CUM is DOUBLE PRECISI
C
C     CCUM <-- Compliment of Cumulative f distribution.
C                                                  CCUM is DOUBLE PRECIS
C
C
C                              Method
C
C
C     Formula  26.5.28 of  Abramowitz and   Stegun   is  used to  reduce
C     the cumulative F to a cumulative beta distribution.
C
C
C                              Note
C
C
C     If F is less than or equal to 0, 0 is returned.
C
C**********************************************************************
C     .. Scalar Arguments ..
      DOUBLE PRECISION dfd,dfn,f,cum,ccum
C     ..
C     .. Local Scalars ..

      DOUBLE PRECISION dsum,prod,xx,yy
      INTEGER ierr
C     ..
C     .. Parameters ..
      DOUBLE PRECISION half
      PARAMETER (half=0.5D0)
      DOUBLE PRECISION done
      PARAMETER (done=1.0D0)
C     ..
C     .. External Subroutines ..
      EXTERNAL bratio
C     ..
C     .. Executable Statements ..

      IF (.NOT. (f.LE.0.0D0)) GO TO 10
      cum = 0.0D0
      ccum = 1.0D0
      RETURN

   10 prod = dfn*f
C
C     XX is such that the incomplete beta with parameters
C     DFD/2 and DFN/2 evaluated at XX is 1 - CUM or CCUM
C
C     YY is 1 - XX
C
C     Calculate the smaller of XX and YY accurately
C
      dsum = dfd + prod
      xx = dfd/dsum
      IF (xx.GT.half) THEN
          yy = prod/dsum
          xx = done - yy

      ELSE
          yy = done - xx
      END IF

      CALL bratio(dfd*half,dfn*half,xx,yy,ccum,cum,ierr)
      RETURN

      END


cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c Compute the matrix R.
c This version detrends every search window W before computing rho(A,W).

      subroutine compute_R_detrend(A,ia,ja,B,ib,jb,R,ir,jr,
     &		W,rsw,csw)
      implicit none
c Inputs...
      integer ia,ja
      integer*2 A(-ia:ia,-ja:ja)	!nlw x nsw shape function.
      integer ib,jb
      integer*2 B(-ib:ib,-jb:jb)	!search window centered at D(lnom,snom).
      integer ir,jr
c Scratch space...
      integer*2 W(-ia:ia,-ja:ja)
      integer rsw(-ja:ja)		!sums along each row of w
      integer csw(-ib:ib)		!sums along each column of B
c Output...
      real*4 R(-ir:ir,-jr:jr)		!rho for nver x nhor search area

c Template A mean and sigma...
      common/ca/area,meanA,sigA
      real area,meanA,sigA

c Local variables...
      integer ii,jj		!search window offsets
      integer i,j		!A(i,j) = B(i+ii,j+jj)

      integer sw,sw2,saw
      real meanW,varW,covAW,sigW

      do 20 jj=-jr,jr		!row loop thru R
      do 10 ii=-ir,ir		!column loop thru R
      call detrend_window(B,ib,jb,ii,jj,W,ia,ja,rsw,csw)
      sw = 0
      sw2 = 0
      saw = 0
      do j=-ja,ja
         do i=-ia,ia
            sw = sw + w(i,j)
            sw2 = sw2 + w(i,j)**2
            saw = saw + a(i,j)*w(i,j)
         enddo
      enddo
      meanW = sw/area
      varW = sw2/area - meanW**2
      if (varW.gt.0) then	!do this if there is a signal
         covAW = saw/area - meanA*meanW
         sigW = sqrt(varW)
         R(ii,jj) = covAW/(sigA*sigW)
      else
         R(ii,jj) = -999	!no pulse, rho has no meaning.
      endif
   10 continue
   20 continue

      return
      end


subroutine filter(x,sx,nel,n,y,sy)

! Apply a boxcar filter n+1 pixels wide to a vector x.
! The routine uses linear propagation of errors to derive the errors
! in the smoothed vector from the  errors provided for the original
! data.
!
!
!	IN:	x	Input vector
!		sx	Errors in input vector
!		nel	number of points in the input vectors
!		n	n/2 pixels will be used on each
!					if not, n/2 on the left,
!					and n/2-1 on the right
!
!	OUT:	y	Output vector
!		sy	Resulting vector
!

use share, only: dp

implicit none

!input/output
integer, intent(in)	:: nel,n
real(dp), intent(in)	:: x(nel),sx(nel) !input vector (data and errors)
real(dp), intent(out)	:: y(nel),sy(nel) !output vectors (smooth data and errors)

!locals
integer			:: j,i1,i2,taco
real(dp)		:: sx2(nel)	  !sx**2

taco=0
if (n/2. > floor(n/2.)) taco=1

do j=1,nel
	sx2(j)=sx(j)*sx(j)
enddo

do j=0,nel-1
	i1=j-n/2
	if (i1 < 0) i1=0
	i2=j+n/2-taco
	if (i2 > nel-1) i2=nel-1
	y(j+1)=sum(x(i1+1:i2+1))/(i2-i1+1._dp)
	sy(j+1)=sqrt(sum(sx2(i1+1:i2+1)))/(i2-i1+1._dp)
enddo

end subroutine filter


include 'maths_module.f90'
include 'sub1_module.f90'

program ch2105
    ! Modules and Include Statements
    use iso_fortran_env, wp => real64
    use sub1_module
    implicit none

    real(wp) :: r, a, c

    print *, 'radius?'
    read *, r
    call sub1(r,a,c)
    print *, ' for radius = ', r
    print *, ' area = ', a
    print *, ' circumference = ', c
end program


    program demo_setexp
    implicit none
    real :: x = 178.1387e-4
    integer :: i = 17
       print *, set_exponent(x, i), fraction(x) * radix(x)**i
    end program demo_setexp


! 7.1b в учебнике

program ex_7_1b
    implicit none

    integer, allocatable    :: A(:)
    integer                 :: In, Out, size, i
    character(*), parameter :: output_file = "output.txt", &
                               input_file = "../data/input.txt"

    open (file=input_file, newunit=In)
        read(In, *) size
        allocate(A(size))
        read(In, *) A(:)
    close (In)

    do i = 1, size
        A(i:) = cshift(A(i:), minloc(A(i:), 1) - 1)
    enddo

    open (file=output_file, newunit=Out)
        write(Out, *) A
    close (Out)

end program ex_7_1b


!  This file is an example of the Corana et al. simulated annealing algorithm
!  for multimodal and robust optimization as implemented and modified by
!  Goffe, Ferrier and Rogers.  Counting the above line
!  ABSTRACT as 1, the routine itself (SA), with its supplementary
!  routines, is on lines 232-990. A multimodal example from Judge et al.
!  (FCN) is on lines 150-231. The rest of this file (lines 1-149) is a
!  driver routine with values appropriate for the Judge example.  Thus, this
!  example is ready to run.

!  To understand the algorithm, the documentation for SA on lines 236-
!  484 should be read along with the parts of the paper that describe
!  simulated annealing. Then the following lines will then aid the user
!  in becomming proficient with this implementation of simulated annealing.

!  Learning to use SA:
!      Use the sample function from Judge with the following suggestions
!  to get a feel for how SA works. When you've done this, you should be
!  ready to use it on most any function with a fair amount of expertise.
!    1. Run the program as is to make sure it runs okay. Take a look at
!       the intermediate output and see how it optimizes as temperature
!       (T) falls.  Notice how the optimal point is reached and how
!       falling T reduces VM.
!    2. Look through the documentation to SA so the following makes a
!       bit of sense. In line with the paper, it shouldn't be that hard
!       to figure out. The core of the algorithm is described on pp. 68-70
!       and on pp. 94-95. Also see Corana et al. pp. 264-9.
!    3. To see how it selects points and makes decisions about uphill and
!       downhill moves, set IPRINT = 3 (very detailed intermediate output)
!       and MAXEVL = 100 (only 100 function evaluations to limit output).
!    4. To see the importance of different temperatures, try starting
!       with a very low one (say T = 10E-5).  You'll see (i) it never
!       escapes from the local optima (in annealing terminology, it
!       quenches) & (ii) the step length (VM) will be quite small.  This
!       is a key part of the algorithm: as temperature (T) falls, step
!       length does too. In a minor point here, note how VM is quickly
!       reset from its initial value. Thus, the input VM is not very
!       important.  This is all the more reason to examine VM once the
!       algorithm is underway.
!    5. To see the effect of different parameters and their effect on
!       the speed of the algorithm, try RT = .95 & RT = .1.  Notice the
!       vastly different speed for optimization. Also try NT = 20.  Note
!       that this sample function is quite easy to optimize, so it will
!       tolerate big changes in these parameters.  RT and NT are the
!       parameters one should adjust to modify the runtime of the
!       algorithm and its robustness.
!    6. Try constraining the algorithm with either LB or UB.

MODULE simulated_anneal

! ABSTRACT:
!   Simulated annealing is a global optimization method that distinguishes
!   between different local optima.  Starting from an initial point, the
!   algorithm takes a step and the function is evaluated. When minimizing a
!   function, any downhill step is accepted and the process repeats from this
!   new point. An uphill step may be accepted. Thus, it can escape from local
!   optima. This uphill decision is made by the Metropolis criteria. As the
!   optimization process proceeds, the length of the steps decline and the
!   algorithm closes in on the global optimum. Since the algorithm makes very
!   few assumptions regarding the function to be optimized, it is quite
!   robust with respect to non-quadratic surfaces. The degree of robustness
!   can be adjusted by the user. In fact, simulated annealing can be used as
!   a local optimizer for difficult functions.

!   This implementation of simulated annealing was used in "Global Optimizatio
!   of Statistical Functions with Simulated Annealing," Goffe, Ferrier and
!   Rogers, Journal of Econometrics, vol. 60, no. 1/2, Jan./Feb. 1994, pp.
!   65-100. Briefly, we found it competitive, if not superior, to multiple
!   restarts of conventional optimization routines for difficult optimization
!   problems.

!   For more information on this routine, contact its author:
!   Bill Goffe, bgoffe@whale.st.usm.edu

! This version in Fortran 90 has been prepared by Alan Miller.
! It is compatible with Lahey's ELF90 compiler.
! N.B. The 3 last arguments have been removed from subroutine sa.   these
!      were work arrays and are now internal to the routine.
! e-mail:  amiller @ bigpond.net.au
! URL   :  http://users.bigpond.net.au/amiller

! Latest revision of Fortran 90 version - 2 October 2013

IMPLICIT NONE

INTEGER, PARAMETER :: dp = SELECTED_REAL_KIND(14, 60)

! The following variables were in COMMON /raset1/
REAL, SAVE    :: u(97), cc, cd, cm
INTEGER, SAVE :: i97, j97

CONTAINS

SUBROUTINE sa(n, x, max, rt, eps, ns, nt, neps, maxevl, lb, ub, c, iprint,  &
              iseed1, iseed2, t, vm, xopt, fopt, nacc, nfcnev, nobds, ier)

!  Version: 3.2
!  Date: 1/22/94.
!  Differences compared to Version 2.0:
!     1. If a trial is out of bounds, a point is randomly selected
!        from LB(i) to UB(i). Unlike in version 2.0, this trial is
!        evaluated and is counted in acceptances and rejections.
!        All corresponding documentation was changed as well.
!  Differences compared to Version 3.0:
!     1. If VM(i) > (UB(i) - LB(i)), VM is set to UB(i) - LB(i).
!        The idea is that if T is high relative to LB & UB, most
!        points will be accepted, causing VM to rise. But, in this
!        situation, VM has little meaning; particularly if VM is
!        larger than the acceptable region. Setting VM to this size
!        still allows all parts of the allowable region to be selected.
!  Differences compared to Version 3.1:
!     1. Test made to see if the initial temperature is positive.
!     2. WRITE statements prettied up.
!     3. References to paper updated.

!  Synopsis:
!  This routine implements the continuous simulated annealing global
!  optimization algorithm described in Corana et al.'s article "Minimizing
!  Multimodal Functions of Continuous Variables with the "Simulated Annealing"
!  Algorithm" in the September 1987 (vol. 13, no. 3, pp. 262-280) issue of
!  the ACM Transactions on Mathematical Software.

!  A very quick (perhaps too quick) overview of SA:
!     SA tries to find the global optimum of an N dimensional function.
!  It moves both up and downhill and as the optimization process
!  proceeds, it focuses on the most promising area.
!     To start, it randomly chooses a trial point within the step length
!  VM (a vector of length N) of the user selected starting point. The
!  function is evaluated at this trial point and its value is compared
!  to its value at the initial point.
!     In a maximization problem, all uphill moves are accepted and the
!  algorithm continues from that trial point. Downhill moves may be
!  accepted; the decision is made by the Metropolis criteria. It uses T
!  (temperature) and the size of the downhill move in a probabilistic
!  manner. The smaller T and the size of the downhill move are, the more
!  likely that move will be accepted. If the trial is accepted, the
!  algorithm moves on from that point. If it is rejected, another point
!  is chosen instead for a trial evaluation.
!     Each element of VM periodically adjusted so that half of all
!  function evaluations in that direction are accepted.
!     A fall in T is imposed upon the system with the RT variable by
!  T(i+1) = RT*T(i) where i is the ith iteration. Thus, as T declines,
!  downhill moves are less likely to be accepted and the percentage of
!  rejections rise. Given the scheme for the selection for VM, VM falls.
!  Thus, as T declines, VM falls and SA focuses upon the most promising
!  area for optimization.

!  The importance of the parameter T:
!     The parameter T is crucial in using SA successfully. It influences
!  VM, the step length over which the algorithm searches for optima. For
!  a small intial T, the step length may be too small; thus not enough
!  of the function might be evaluated to find the global optima. The user
!  should carefully examine VM in the intermediate output (set IPRINT =
!  1) to make sure that VM is appropriate. The relationship between the
!  initial temperature and the resulting step length is function
!  dependent.
!     To determine the starting temperature that is consistent with
!  optimizing a function, it is worthwhile to run a trial run first. Set
!  RT = 1.5 and T = 1.0. With RT > 1.0, the temperature increases and VM
!  rises as well. Then select the T that produces a large enough VM.

!  For modifications to the algorithm and many details on its use,
!  (particularly for econometric applications) see Goffe, Ferrier
!  and Rogers, "Global Optimization of Statistical Functions with
!  Simulated Annealing," Journal of Econometrics, vol. 60, no. 1/2,
!  Jan./Feb. 1994, pp. 65-100.
!  For more information, contact
!              Bill Goffe
!              Department of Economics and International Business
!              University of Southern Mississippi
!              Hattiesburg, MS  39506-5072
!              (601) 266-4484 (office)
!              (601) 266-4920 (fax)
!              bgoffe@whale.st.usm.edu (Internet)

!  As far as possible, the parameters here have the same name as in
!  the description of the algorithm on pp. 266-8 of Corana et al.

!  In this description, SP is single precision, DP is double precision,
!  INT is integer, L is logical and (N) denotes an array of length n.
!  Thus, DP(N) denotes a double precision array of length n.

!  Input Parameters:
!    Note: The suggested values generally come from Corana et al. To
!          drastically reduce runtime, see Goffe et al., pp. 90-1 for
!          suggestions on choosing the appropriate RT and NT.
!    N - Number of variables in the function to be optimized. (INT)
!    X - The starting values for the variables of the function to be
!        optimized. (DP(N))
!    MAX - Denotes whether the function should be maximized or minimized.
!          A true value denotes maximization while a false value denotes
!          minimization.  Intermediate output (see IPRINT) takes this into
!          account. (L)
!    RT - The temperature reduction factor.  The value suggested by
!         Corana et al. is .85. See Goffe et al. for more advice. (DP)
!    EPS - Error tolerance for termination. If the final function
!          values from the last neps temperatures differ from the
!          corresponding value at the current temperature by less than
!          EPS and the final function value at the current temperature
!          differs from the current optimal function value by less than
!          EPS, execution terminates and IER = 0 is returned. (EP)
!    NS - Number of cycles.  After NS*N function evaluations, each element of
!         VM is adjusted so that approximately half of all function evaluations
!         are accepted.  The suggested value is 20. (INT)
!    NT - Number of iterations before temperature reduction. After
!         NT*NS*N function evaluations, temperature (T) is changed
!         by the factor RT.  Value suggested by Corana et al. is
!         MAX(100, 5*N).  See Goffe et al. for further advice. (INT)
!    NEPS - Number of final function values used to decide upon termi-
!           nation.  See EPS.  Suggested value is 4. (INT)
!    MAXEVL - The maximum number of function evaluations.  If it is
!             exceeded, IER = 1. (INT)
!    LB - The lower bound for the allowable solution variables. (DP(N))
!    UB - The upper bound for the allowable solution variables. (DP(N))
!         If the algorithm chooses X(I) .LT. LB(I) or X(I) .GT. UB(I),
!         I = 1, N, a point is from inside is randomly selected. This
!         This focuses the algorithm on the region inside UB and LB.
!         Unless the user wishes to concentrate the search to a particular
!         region, UB and LB should be set to very large positive
!         and negative values, respectively.  Note that the starting
!         vector X should be inside this region.  Also note that LB and
!         UB are fixed in position, while VM is centered on the last
!         accepted trial set of variables that optimizes the function.
!    C - Vector that controls the step length adjustment.  The suggested
!        value for all elements is 2.0. (DP(N))
!    IPRINT - controls printing inside SA. (INT)
!             Values: 0 - Nothing printed.
!                     1 - Function value for the starting value and
!                         summary results before each temperature
!                         reduction. This includes the optimal
!                         function value found so far, the total
!                         number of moves (broken up into uphill,
!                         downhill, accepted and rejected), the
!                         number of out of bounds trials, the
!                         number of new optima found at this
!                         temperature, the current optimal X and
!                         the step length VM. Note that there are
!                         N*NS*NT function evalutations before each
!                         temperature reduction. Finally, notice is
!                         is also given upon achieveing the termination
!                         criteria.
!                     2 - Each new step length (VM), the current optimal
!                         X (XOPT) and the current trial X (X). This
!                         gives the user some idea about how far X
!                         strays from XOPT as well as how VM is adapting
!                         to the function.
!                     3 - Each function evaluation, its acceptance or
!                         rejection and new optima. For many problems,
!                         this option will likely require a small tree
!                         if hard copy is used. This option is best
!                         used to learn about the algorithm. A small
!                         value for MAXEVL is thus recommended when
!                         using IPRINT = 3.
!             Suggested value: 1
!             Note: For a given value of IPRINT, the lower valued
!                   options (other than 0) are utilized.
!    ISEED1 - The first seed for the random number generator RANMAR.
!             0 <= ISEED1 <= 31328. (INT)
!    ISEED2 - The second seed for the random number generator RANMAR.
!             0 <= ISEED2 <= 30081. Different values for ISEED1
!             and ISEED2 will lead to an entirely different sequence
!             of trial points and decisions on downhill moves (when
!             maximizing).  See Goffe et al. on how this can be used
!             to test the results of SA. (INT)

!  Input/Output Parameters:
!    T - On input, the initial temperature. See Goffe et al. for advice.
!        On output, the final temperature. (DP)
!    VM - The step length vector. On input it should encompass the region of
!         interest given the starting value X.  For point X(I), the next
!         trial point is selected is from X(I) - VM(I)  to  X(I) + VM(I).
!         Since VM is adjusted so that about half of all points are accepted,
!         the input value is not very important (i.e. is the value is off,
!         SA adjusts VM to the correct value). (DP(N))

!  Output Parameters:
!    XOPT - The variables that optimize the function. (DP(N))
!    FOPT - The optimal value of the function. (DP)
!    NACC - The number of accepted function evaluations. (INT)
!    NFCNEV - The total number of function evaluations. In a minor
!             point, note that the first evaluation is not used in the
!             core of the algorithm; it simply initializes the
!             algorithm. (INT).
!    NOBDS - The total number of trial function evaluations that
!            would have been out of bounds of LB and UB. Note that
!            a trial point is randomly selected between LB and UB. (INT)
!    IER - The error return number. (INT)
!          Values: 0 - Normal return; termination criteria achieved.
!                  1 - Number of function evaluations (NFCNEV) is
!                      greater than the maximum number (MAXEVL).
!                  2 - The starting value (X) is not inside the
!                      bounds (LB and UB).
!                  3 - The initial temperature is not positive.
!                  99 - Should not be seen; only used internally.

!  Work arrays that must be dimensioned in the calling routine:
!       RWK1 (DP(NEPS))  (FSTAR in SA)
!       RWK2 (DP(N))     (XP    "  " )
!       IWK  (INT(N))    (NACP  "  " )
!  N.B. In the Fortran 90 version, these are automatic arrays.

!  Required Functions (included):
!    EXPREP - Replaces the function EXP to avoid under- and overflows.
!             It may have to be modified for non IBM-type main-
!             frames. (DP)
!    RMARIN - Initializes the random number generator RANMAR.
!    RANMAR - The actual random number generator. Note that
!             RMARIN must run first (SA does this). It produces uniform
!             random numbers on [0,1]. These routines are from
!             Usenet's comp.lang.fortran. For a reference, see
!             "Toward a Universal Random Number Generator"
!             by George Marsaglia and Arif Zaman, Florida State
!             University Report: FSU-SCRI-87-50 (1987).
!             It was later modified by F. James and published in
!             "A Review of Pseudo-random Number Generators." For
!             further information, contact stuart@ads.com. These
!             routines are designed to be portable on any machine
!             with a 24-bit or more mantissa. I have found it produces
!             identical results on a IBM 3081 and a Cray Y-MP.

!  Required Subroutines (included):
!    PRTVEC - Prints vectors.
!    PRT1 ... PRT10 - Prints intermediate output.
!    FCN - Function to be optimized. The form is
!            SUBROUTINE FCN(N, X, F)
!            IMPLICIT NONE
!            INTEGER, PARAMETER     :: dp = SELECTED_REAL_KIND(14, 60)
!            INTEGER, INTENT(IN)    :: N
!            REAL (dp), INTENT(IN)  :: X(N)
!            REAL (dp), INTENT(OUT) :: F
!            ...
!            function code with F = F(X)
!            ...
!            RETURN
!            END
!  Note: This is the same form used in the multivariable
!        minimization algorithms in the IMSL edition 10 library.

!  Machine Specific Features:
!    1. EXPREP may have to be modified if used on non-IBM type main-
!       frames. Watch for under- and overflows in EXPREP.
!    2. Some FORMAT statements use G25.18; this may be excessive for
!       some machines.
!    3. RMARIN and RANMAR are designed to be protable; they should not
!       cause any problems.

!  Type all external variables.
REAL (dp), INTENT(IN)     :: lb(:), ub(:), c(:), eps, rt
REAL (dp), INTENT(IN OUT) :: x(:), t, vm(:)
REAL (dp), INTENT(OUT)    :: xopt(:), fopt
INTEGER, INTENT(IN)       :: n, ns, nt, neps, maxevl, iprint, iseed1, iseed2
INTEGER, INTENT(OUT)      :: nacc, nfcnev, nobds, ier
LOGICAL, INTENT(IN)       :: max

!  Type all internal variables.
REAL (dp) :: f, fp, p, pp, ratio, xp(n), fstar(neps)
INTEGER   :: nup, ndown, nrej, nnew, lnobds, h, i, j, m, nacp(n)
LOGICAL   :: quit

INTERFACE
  SUBROUTINE fcn(n, theta, h)
    IMPLICIT NONE
    INTEGER, PARAMETER     :: dp = SELECTED_REAL_KIND(14, 60)
    INTEGER, INTENT(IN)    :: n
    REAL (dp), INTENT(IN)  :: theta(:)
    REAL (dp), INTENT(OUT) :: h
  END SUBROUTINE fcn
END INTERFACE

!  Initialize the random number generator RANMAR.
CALL rmarin(iseed1, iseed2)

!  Set initial values.
nacc = 0
nobds = 0
nfcnev = 0
ier = 99

DO i = 1, n
  xopt(i) = x(i)
  nacp(i) = 0
END DO

fstar = 1.0D+20

!  If the initial temperature is not positive, notify the user and
!  return to the calling routine.
IF (t <= 0.0) THEN
  WRITE(*,'(/, "  THE INITIAL TEMPERATURE IS NOT POSITIVE. "/,  &
        &    "  reset the variable t. "/)')
  ier = 3
  RETURN
END IF

!  If the initial value is out of bounds, notify the user and return
!  to the calling routine.
DO i = 1, n
  IF ((x(i) > ub(i)) .OR. (x(i) < lb(i))) THEN
    CALL prt1()
    ier = 2
    RETURN
  END IF
END DO

!  Evaluate the function with input X and return value as F.
CALL fcn(n, x, f)

!  If the function is to be minimized, switch the sign of the function.
!  Note that all intermediate and final output switches the sign back
!  to eliminate any possible confusion for the user.
IF(.NOT. max) f = -f
nfcnev = nfcnev + 1
fopt = f
fstar(1) = f
IF(iprint >= 1) CALL prt2(max, n, x, f)

!  Start the main loop. Note that it terminates if (i) the algorithm
!  succesfully optimizes the function or (ii) there are too many
!  function evaluations (more than MAXEVL).
100 nup = 0
nrej = 0
nnew = 0
ndown = 0
lnobds = 0

DO m = 1, nt
  DO j = 1, ns
    DO h = 1, n

!  Generate XP, the trial value of X. Note use of VM to choose XP.
      DO i = 1, n
        IF (i == h) THEN
          xp(i) = x(i) + (ranmar()*2. - 1.) * vm(i)
        ELSE
          xp(i) = x(i)
        END IF

!  If XP is out of bounds, select a point in bounds for the trial.
        IF((xp(i) < lb(i)) .OR. (xp(i) > ub(i))) THEN
          xp(i) = lb(i) + (ub(i) - lb(i))*ranmar()
          lnobds = lnobds + 1
          nobds = nobds + 1
          IF(iprint >= 3) CALL prt3(max, n, xp, x, f)
        END IF
      END DO

!  Evaluate the function with the trial point XP and return as FP.
      CALL fcn(n, xp, fp)
      IF(.NOT. max) fp = -fp
      nfcnev = nfcnev + 1
      IF(iprint >= 3) CALL prt4(max, n, xp, x, fp, f)

!  If too many function evaluations occur, terminate the algorithm.
      IF(nfcnev >= maxevl) THEN
        CALL prt5()
        IF (.NOT. max) fopt = -fopt
        ier = 1
        RETURN
      END IF

!  Accept the new point if the function value increases.
      IF(fp >= f) THEN
        IF(iprint >= 3) THEN
          WRITE(*,'("  POINT ACCEPTED")')
        END IF
        x(1:n) = xp(1:n)
        f = fp
        nacc = nacc + 1
        nacp(h) = nacp(h) + 1
        nup = nup + 1

!  If greater than any other point, record as new optimum.
        IF (fp > fopt) THEN
          IF(iprint >= 3) THEN
            WRITE(*,'("  NEW OPTIMUM")')
          END IF
          xopt(1:n) = xp(1:n)
          fopt = fp
          nnew = nnew + 1
        END IF

!  If the point is lower, use the Metropolis criteria to decide on
!  acceptance or rejection.
      ELSE
        p = exprep((fp - f)/t)
        pp = ranmar()
        IF (pp < p) THEN
          IF(iprint >= 3) CALL prt6(max)
          x(1:n) = xp(1:n)
          f = fp
          nacc = nacc + 1
          nacp(h) = nacp(h) + 1
          ndown = ndown + 1
        ELSE
          nrej = nrej + 1
          IF(iprint >= 3) CALL prt7(max)
        END IF
      END IF

    END DO
  END DO

!  Adjust VM so that approximately half of all evaluations are accepted.
  DO i = 1, n
    ratio = DBLE(nacp(i)) /DBLE(ns)
    IF (ratio > .6) THEN
      vm(i) = vm(i)*(1. + c(i)*(ratio - .6)/.4)
    ELSE IF (ratio < .4) THEN
      vm(i) = vm(i)/(1. + c(i)*((.4 - ratio)/.4))
    END IF
    IF (vm(i) > (ub(i)-lb(i))) THEN
      vm(i) = ub(i) - lb(i)
    END IF
  END DO

  IF(iprint >= 2) THEN
    CALL prt8(n, vm, xopt, x)
  END IF

  nacp(1:n) = 0

END DO

IF(iprint >= 1) THEN
  CALL prt9(max,n,t,xopt,vm,fopt,nup,ndown,nrej,lnobds,nnew)
END IF

!  Check termination criteria.
quit = .false.
fstar(1) = f
IF ((fopt - fstar(1)) <= eps) quit = .true.
DO i = 1, neps
  IF (ABS(f - fstar(i)) > eps) quit = .false.
END DO

!  Terminate SA if appropriate.
IF (quit) THEN
  x(1:n) = xopt(1:n)
  ier = 0
  IF (.NOT. max) fopt = -fopt
  IF(iprint >= 1) CALL prt10()
  RETURN
END IF

!  If termination criteria is not met, prepare for another loop.
t = rt*t
DO i = neps, 2, -1
  fstar(i) = fstar(i-1)
END DO
f = fopt
x(1:n) = xopt(1:n)

!  Loop again.
GO TO 100

END SUBROUTINE sa

FUNCTION exprep(rdum) RESULT(fn_val)
!  This function replaces exp to avoid under- and overflows and is
!  designed for IBM 370 type machines. It may be necessary to modify
!  it for other machines. Note that the maximum and minimum values of
!  EXPREP are such that they has no effect on the algorithm.

REAL (dp), INTENT(IN) :: rdum
REAL (dp)             :: fn_val

IF (rdum > 174._dp) THEN
  fn_val = 3.69D+75
ELSE IF (rdum < -180._dp) THEN
  fn_val = 0.0_dp
ELSE
  fn_val = EXP(rdum)
END IF

RETURN
END FUNCTION exprep

SUBROUTINE rmarin(ij, kl)
!  This subroutine and the next function generate random numbers. See
!  the comments for SA for more information. The only changes from the
!  orginal code is that (1) the test to make sure that RMARIN runs first
!  was taken out since SA assures that this is done (this test didn't
!  compile under IBM's VS Fortran) and (2) typing ivec as integer was
!  taken out since ivec isn't used. With these exceptions, all following
!  lines are original.

! This is the initialization routine for the random number generator
!     RANMAR()
! NOTE: The seed variables can have values between:    0 <= IJ <= 31328
!                                                      0 <= KL <= 30081

INTEGER, INTENT(IN) :: ij, kl

INTEGER :: i, j, k, l, ii, jj, m
REAL    :: s, t

IF( ij < 0  .OR.  ij > 31328  .OR. kl < 0  .OR.  kl > 30081 ) THEN
  WRITE(*, '(A)') ' The first random number seed must have a value ',  &
               'between 0 AND 31328'
  WRITE(*, '(A)') ' The second seed must have a value between 0 and 30081'
  STOP
END IF
i = MOD(ij/177, 177) + 2
j = MOD(ij    , 177) + 2
k = MOD(kl/169, 178) + 1
l = MOD(kl,     169)
DO ii = 1, 97
  s = 0.0
  t = 0.5
  DO jj = 1, 24
    m = MOD(MOD(i*j, 179)*k, 179)
    i = j
    j = k
    k = m
    l = MOD(53*l+1, 169)
    IF (MOD(l*m, 64) >= 32) THEN
      s = s + t
    END IF
    t = 0.5 * t
  END DO
  u(ii) = s
END DO
cc = 362436.0 / 16777216.0
cd = 7654321.0 / 16777216.0
cm = 16777213.0 /16777216.0
i97 = 97
j97 = 33
RETURN
END SUBROUTINE rmarin

FUNCTION ranmar() RESULT(fn_val)
REAL :: fn_val

! Local variable
REAL :: uni

uni = u(i97) - u(j97)
IF( uni < 0.0 ) uni = uni + 1.0
u(i97) = uni
i97 = i97 - 1
IF(i97 == 0) i97 = 97
j97 = j97 - 1
IF(j97 == 0) j97 = 97
cc = cc - cd
IF( cc < 0.0 ) cc = cc + cm
uni = uni - cc
IF( uni < 0.0 ) uni = uni + 1.0
fn_val = uni

RETURN
END FUNCTION ranmar

SUBROUTINE prt1()
!  This subroutine prints intermediate output, as does PRT2 through
!  PRT10. Note that if SA is minimizing the function, the sign of the
!  function value and the directions (up/down) are reversed in all
!  output to correspond with the actual function optimization. This
!  correction is because SA was written to maximize functions and
!  it minimizes by maximizing the negative a function.

WRITE(*, '(/, "  THE STARTING VALUE (X) IS OUTSIDE THE BOUNDS "/,  &
      &     "  (lb AND ub). execution terminated without any"/,  &
      &     "  optimization. respecify x, ub OR lb so that  "/,  &
      &     "  lb(i) < x(i) < ub(i), i = 1, n. "/)')

RETURN
END SUBROUTINE prt1

SUBROUTINE prt2(max, n, x, f)

REAL (dp), INTENT(IN) ::  x(:), f
INTEGER, INTENT(IN)   ::  n
LOGICAL, INTENT(IN)   ::  max

WRITE(*, '("  ")')
CALL prtvec(x,n,'INITIAL X')
IF (max) THEN
  WRITE(*, '("  INITIAL F: ",/, G25.18)') f
ELSE
  WRITE(*, '("  INITIAL F: ",/, G25.18)') -f
END IF

RETURN
END SUBROUTINE prt2

SUBROUTINE prt3(max, n, xp, x, f)

REAL (dp), INTENT(IN) ::  xp(:), x(:), f
INTEGER, INTENT(IN)   ::  n
LOGICAL, INTENT(IN)   ::  max

WRITE(*, '("  ")')
CALL prtvec(x, n, 'CURRENT X')
IF (max) THEN
  WRITE(*, '("  CURRENT F: ", G25.18)') f
ELSE
  WRITE(*, '("  CURRENT F: ", G25.18)') -f
END IF
CALL prtvec(xp, n, 'TRIAL X')
WRITE(*, '("  POINT REJECTED SINCE OUT OF BOUNDS")')

RETURN
END SUBROUTINE prt3

SUBROUTINE prt4(max, n, xp, x, fp, f)

REAL (dp), INTENT(IN) ::  xp(:), x(:), fp, f
INTEGER, INTENT(IN)   ::  n
LOGICAL, INTENT(IN)   ::  max

WRITE(*,'("  ")')
CALL prtvec(x,n,'CURRENT X')
IF (max) THEN
  WRITE(*,'("  CURRENT F: ",G25.18)') f
  CALL prtvec(xp,n,'TRIAL X')
  WRITE(*,'("  RESULTING F: ",G25.18)') fp
ELSE
  WRITE(*,'("  CURRENT F: ",G25.18)') -f
  CALL prtvec(xp,n,'TRIAL X')
  WRITE(*,'("  RESULTING F: ",G25.18)') -fp
END IF

RETURN
END SUBROUTINE prt4

SUBROUTINE prt5()

WRITE(*, '(/, "  TOO MANY FUNCTION EVALUATIONS; CONSIDER "/,  &
      &     "  increasing maxevl OR eps, OR decreasing "/,  &
      &     "  nt OR rt. these results are likely TO be "/, "  poor.",/)')

RETURN
END SUBROUTINE prt5

SUBROUTINE prt6(max)
LOGICAL, INTENT(IN) ::  max

IF (max) THEN
  WRITE(*,'("  THOUGH LOWER, POINT ACCEPTED")')
ELSE
  WRITE(*,'("  THOUGH HIGHER, POINT ACCEPTED")')
END IF

RETURN
END SUBROUTINE prt6

SUBROUTINE prt7(max)
LOGICAL, INTENT(IN) :: max

IF (max) THEN
  WRITE(*,'("  LOWER POINT REJECTED")')
ELSE
  WRITE(*,'("  HIGHER POINT REJECTED")')
END IF

RETURN
END SUBROUTINE prt7

SUBROUTINE prt8(n, vm, xopt, x)

REAL (dp), INTENT(IN) :: vm(:), xopt(:), x(:)
INTEGER, INTENT(IN)   :: n

WRITE(*,'(/, " intermediate results after step length adjustment", /)')
CALL prtvec(vm, n, 'NEW STEP LENGTH (VM)')
CALL prtvec(xopt, n, 'CURRENT OPTIMAL X')
CALL prtvec(x, n, 'CURRENT X')
WRITE(*,'(" ")')

RETURN
END SUBROUTINE prt8

SUBROUTINE prt9(max, n, t, xopt, vm, fopt, nup, ndown, nrej, lnobds, nnew)

REAL (dp), INTENT(IN) :: xopt(:), vm(:), t, fopt
INTEGER, INTENT(IN)   :: n, nup, ndown, nrej, lnobds, nnew
LOGICAL, INTENT(IN)   :: max

! Local variable
INTEGER :: totmov

totmov = nup + ndown + nrej

WRITE(*,'(/," intermediate results before next temperature reduction",/)')
WRITE(*,'("  CURRENT TEMPERATURE:            ",G12.5)') t
IF (max) THEN
  WRITE(*, '("  MAX FUNCTION VALUE SO FAR:  ",G25.18)') fopt
  WRITE(*, '("  TOTAL MOVES:                ",I8)') totmov
  WRITE(*, '("     UPHILL:                  ",I8)') nup
  WRITE(*, '("     ACCEPTED DOWNHILL:       ",I8)') ndown
  WRITE(*, '("     REJECTED DOWNHILL:       ",I8)') nrej
  WRITE(*, '("  OUT OF BOUNDS TRIALS:       ",I8)') lnobds
  WRITE(*, '("  NEW MAXIMA THIS TEMPERATURE:",I8)') nnew
ELSE
  WRITE(*, '("  MIN FUNCTION VALUE SO FAR:  ",G25.18)') -fopt
  WRITE(*, '("  TOTAL MOVES:                ",I8)') totmov
  WRITE(*, '("     DOWNHILL:                ",I8)')  nup
  WRITE(*, '("     ACCEPTED UPHILL:         ",I8)')  ndown
  WRITE(*, '("     REJECTED UPHILL:         ",I8)')  nrej
  WRITE(*, '("  TRIALS OUT OF BOUNDS:       ",I8)')  lnobds
  WRITE(*, '("  NEW MINIMA THIS TEMPERATURE:",I8)')  nnew
END IF
CALL prtvec(xopt, n, 'CURRENT OPTIMAL X')
CALL prtvec(vm, n, 'STEP LENGTH (VM)')
WRITE(*, '(" ")')

RETURN
END SUBROUTINE prt9

SUBROUTINE prt10()

WRITE(*, '(/, "  SA ACHIEVED TERMINATION CRITERIA. IER = 0. ",/)')

RETURN
END SUBROUTINE prt10

SUBROUTINE prtvec(vector, ncols, name)
!  This subroutine prints the double precision vector named VECTOR.
!  Elements 1 thru NCOLS will be printed. NAME is a character variable
!  that describes VECTOR. Note that if NAME is given in the call to
!  PRTVEC, it must be enclosed in quotes. If there are more than 10
!  elements in VECTOR, 10 elements will be printed on each line.

INTEGER, INTENT(IN)           :: ncols
REAL (dp), INTENT(IN)         :: vector(ncols)
CHARACTER (LEN=*), INTENT(IN) :: name

INTEGER :: i, lines, ll

WRITE(*,1001) NAME

IF (ncols > 10) THEN
  lines = INT(ncols/10.)

  DO i = 1, lines
    ll = 10*(i - 1)
    WRITE(*,1000) vector(1+ll:10+ll)
  END DO

  WRITE(*,1000) vector(11+ll:ncols)
ELSE
  WRITE(*,1000) vector(1:ncols)
END IF

1000 FORMAT( 10(g12.5, ' '))
1001 FORMAT(/, 25(' '), a)

RETURN
END SUBROUTINE prtvec

END MODULE simulated_anneal

PROGRAM simann

USE simulated_anneal
IMPLICIT NONE
INTEGER, PARAMETER :: n = 2, neps = 4

REAL (dp)   :: lb(n), ub(n), x(n), xopt(n), c(n), vm(n), t, eps, rt, fopt

INTEGER     :: ns, nt, nfcnev, ier, iseed1, iseed2, i, maxevl, iprint,  &
               nacc, nobds

LOGICAL     :: max

!  Set underflows to zero on IBM mainframes.
!     CALL XUFLOW(0)

!  Set input parameters.
max = .false.
eps = 1.0D-6
rt = .5
iseed1 = 1
iseed2 = 2
ns = 20
nt = 5
maxevl = 100000
iprint = 1
DO i = 1, n
  lb(i) = -1.0D25
  ub(i) =  1.0D25
  c(i) = 2.0
END DO

!  Note start at local, but not global, optima of the Judge function.
x(1) =  2.354471
x(2) = -0.319186

!  Set input values of the input/output parameters.
t = 5.0
vm(1:n) = 1.0

WRITE(*,1000) n, max, t, rt, eps, ns, nt, neps, maxevl, iprint, iseed1, iseed2

CALL prtvec(x, n, 'STARTING VALUES')
CALL prtvec(vm, n, 'INITIAL STEP LENGTH')
CALL prtvec(lb, n, 'LOWER BOUND')
CALL prtvec(ub, n, 'UPPER BOUND')
CALL prtvec(c, n, 'C VECTOR')
WRITE(*, '(/, "  ****   END OF DRIVER ROUTINE OUTPUT   ****"/,  &
      &     "  ****   before CALL TO sa.             ****")')

CALL sa(n, x, max, rt, eps, ns, nt, neps, maxevl, lb, ub, c, iprint, iseed1,  &
        iseed2, t, vm, xopt, fopt, nacc, nfcnev, nobds, ier)

WRITE(*, '(/, "  ****   RESULTS AFTER SA   ****   ")')
CALL prtvec(xopt, n, 'SOLUTION')
CALL prtvec(vm, n, 'FINAL STEP LENGTH')
WRITE(*,1001) fopt, nfcnev, nacc, nobds, t, ier

1000 FORMAT(/,' SIMULATED ANNEALING EXAMPLE',/,/,  &
             ' NUMBER OF PARAMETERS: ',i3,'   MAXIMIZATION: ',l5, /, &
             ' INITIAL TEMP: ', g8.2, '   RT: ',g8.2, '   EPS: ',g8.2, /, &
             ' NS: ',i3, '   NT: ',i2, '   NEPS: ',i2, /,  &
             ' MAXEVL: ',i10, '   IPRINT: ',i1, '   ISEED1: ',i4,  &
             '   ISEED2: ',i4)
1001 FORMAT(/,' OPTIMAL FUNCTION VALUE: ',g20.13  &
            /,' NUMBER OF FUNCTION EVALUATIONS:     ',i10,  &
            /,' NUMBER OF ACCEPTED EVALUATIONS:     ',i10,  &
            /,' NUMBER OF OUT OF BOUND EVALUATIONS: ',i10,  &
            /,' FINAL TEMP: ', g20.13,'  IER: ', i3)

STOP
END PROGRAM simann

SUBROUTINE fcn(n, theta, h)
!  This subroutine is from the example in Judge et al., The Theory and
!  Practice of Econometrics, 2nd ed., pp. 956-7. There are two optima:
!  F(.864,1.23) = 16.0817 (the global minumum) and F(2.35,-.319) = 20.9805.

IMPLICIT NONE
INTEGER, PARAMETER     :: dp = SELECTED_REAL_KIND(14, 60)

INTEGER, INTENT(IN)    :: n
REAL (dp), INTENT(IN)  :: theta(:)
REAL (dp), INTENT(OUT) :: h

! Local variables
INTEGER   :: i
REAL (dp) :: y(20), x2(20), x3(20)

y(1) = 4.284
y(2) = 4.149
y(3) = 3.877
y(4) = 0.533
y(5) = 2.211
y(6) = 2.389
y(7) = 2.145
y(8) = 3.231
y(9) = 1.998
y(10) = 1.379
y(11) = 2.106
y(12) = 1.428
y(13) = 1.011
y(14) = 2.179
y(15) = 2.858
y(16) = 1.388
y(17) = 1.651
y(18) = 1.593
y(19) = 1.046
y(20) = 2.152

x2(1) =  .286
x2(2) =  .973
x2(3) =  .384
x2(4) =  .276
x2(5) =  .973
x2(6) =  .543
x2(7) =  .957
x2(8) =  .948
x2(9) =  .543
x2(10) =  .797
x2(11) =  .936
x2(12) =  .889
x2(13) =  .006
x2(14) =  .828
x2(15) =  .399
x2(16) =  .617
x2(17) =  .939
x2(18) =  .784
x2(19) =  .072
x2(20) =  .889

x3(1) = .645
x3(2) = .585
x3(3) = .310
x3(4) = .058
x3(5) = .455
x3(6) = .779
x3(7) = .259
x3(8) = .202
x3(9) = .028
x3(10) = .099
x3(11) = .142
x3(12) = .296
x3(13) = .175
x3(14) = .180
x3(15) = .842
x3(16) = .039
x3(17) = .103
x3(18) = .620
x3(19) = .158
x3(20) = .704

h = 0.0_dp
DO i = 1, 20
  h = (theta(1) + theta(n)*x2(i) + (theta(n)**2)*x3(i) - y(i))**2 + h
END DO

RETURN
END SUBROUTINE fcn