program main

!*****************************************************************************80
!
!! MAIN is the main program for FIRE_SERIAL.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    30 June 2013.
!
!  Author:
!
!    FORTRAN90 version by John Burkardt
!
  implicit none

  integer ( kind = 4 ), parameter :: forest_size = 20

  integer ( kind = 4 ) forest(forest_size,forest_size)
  logical forest_is_burning
  integer ( kind = 4 ) i
  integer ( kind = 4 ) i_ignite
  integer ( kind = 4 ) i4_uniform_ab
  integer ( kind = 4 ) j_ignite
  real ( kind = 8 ) percent
  real ( kind = 8 ), parameter :: prob_spread = 0.5D+00
  integer ( kind = 4 ) seed
  real ( kind = 8 ) u

  call timestamp ( )
  write ( *, '(a)' ) ''
  write ( *, '(a)' ) 'FIRE_SERIAL'
  write ( *, '(a)' ) '  FORTRAN90 version'
  write ( *, '(a)' ) '  A probabilistic simulation of a forest fire.'
  write ( *, '(a,g14.6)' ) '  The probability of tree-to-tree spread is ', prob_spread
!
!  Initialize the random number generator.
!
  call get_seed ( seed )
  write ( *, '(a,i12)' ) '  The random number generator is seeded by ', seed
!
!  Initialize the values in the forest.
!
  call forest_initialize ( forest_size, forest )
!
!  Choose a tree at random where the fire will start.
!
  i_ignite = i4_uniform_ab ( 1, forest_size, seed )
  j_ignite = i4_uniform_ab ( 1, forest_size, seed )
  call tree_ignite ( forest_size, forest, i_ignite, j_ignite )
  write ( *, '(a)' ) ''
  write ( *, '(a,i2,a,i2,a)' ) '  Fire starts at tree(', i_ignite, ',', j_ignite, ')'
!
!  Let time run until nothing is burning any more.
!
  do while ( forest_is_burning ( forest_size, forest ) )
    call forest_burns ( forest_size, forest, seed, prob_spread )
  end do
!
!  Display the final forest state.
!
  call forest_print ( forest_size, forest, i_ignite, j_ignite )
!
!  Report the percentage of forest burned.
!
  call get_percent_burned ( forest_size, forest, percent )

  write ( *, '(a)' ) ''
  write ( *, '(a,g14.6)' ) '  Percentage of forest burned = ', percent
!
!  Terminate.
!
  write ( *, '(a)' ) ''
  write ( *, '(a)' ) 'FIRE_SERIAL:'
  write ( *, '(a)' ) '  Normal end of execution.'
  write ( *, '(a)' ) ''
  call timestamp ( )

  stop
end
function fire_spreads ( seed, prob_spread )

!*****************************************************************************80
!
!! FIRE_SPREADS determines whether the fire spreads.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    30 June 2013
!
!  Author:
!
!    FORTRAN90 version by John Burkardt
!
!  Parameters:
!
!    Input/output, integer ( kind = 4 ) SEED, a seed for the random
!    number generator.
!
!    Input, real ( kind = 8 ) PROB_SPREAD, the probability of spreading.
!
!    Output, logical FIRE_SPREADS, is TRUE if the fire spreads.
!
  implicit none

  real ( kind = 8 ) prob_spread
  logical fire_spreads
  real ( kind = 8 ) r8_uniform_01
  integer ( kind = 4 ) seed
  real ( kind = 8 ) u

  u = r8_uniform_01 ( seed )

  if ( u < prob_spread ) then
    fire_spreads = .true.
  else
    fire_spreads = .false.
  end if

  return
end
subroutine forest_burns ( forest_size, forest, seed, prob_spread )

!*****************************************************************************80
!
!! FOREST_BURNS models a single time step of the burning forest.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    30 June 2013
!
!  Author:
!
!    FORTRAN90 version by John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) FOREST_SIZE, the linear dimension of the forest.
!
!    Input/output, integer ( kind = 4 ) FOREST(FOREST_SIZE,FOREST_SIZE), an
!    array with an entry for each tree in the forest.
!
!    Input/output, integer ( kind = 4 ) SEED, a seed for the random
!    number generator.
!
!    Input, real ( kind = 8 ) PROB_SPREAD, the probability that the fire will
!    spread from a burning tree to an unburnt one.
!
  implicit none

  integer ( kind = 4 ) forest_size

  integer ( kind = 4 ), parameter :: BURNING = 2
  integer ( kind = 4 ), parameter :: BURNT = 3
  logical fire_spreads
  integer ( kind = 4 ) forest(forest_size,forest_size)
  integer ( kind = 4 ) i
  integer ( kind = 4 ) j
  real ( kind = 8 ) prob_spread
  integer ( kind = 4 ) seed
  integer ( kind = 4 ), parameter :: SMOLDERING = 1
  integer ( kind = 4 ), parameter :: UNBURNT = 0
!
!  Burning trees burn down;
!  Smoldering trees ignite;
!
  do j = 1, forest_size
    do i = 1, forest_size
      if ( forest(i,j) == BURNING ) then
        forest(i,j) = BURNT
      else if ( forest(i,j) == SMOLDERING ) then
        forest(i,j) = BURNING
      end if
    end do
  end do
!
!  Unburnt trees might catch fire.
!
  do j = 1, forest_size
    do i = 1, forest_size

      if ( forest(i,j) == BURNING ) then
!
!  North.
!
        if ( 1 < i ) then
          if ( fire_spreads ( seed, prob_spread ) .and. forest(i-1,j) == UNBURNT ) then
            forest(i-1,j) = SMOLDERING
          end if
        end if
!
!  South.
!
        if ( i < forest_size ) then
          if ( fire_spreads ( seed, prob_spread ) .and. forest(i+1,j) == UNBURNT ) then
            forest(i+1,j) = SMOLDERING
          end if
        end if
!
!  West.
!
        if ( 1 < j ) then
          if ( fire_spreads ( seed, prob_spread ) .and. forest(i,j-1) == UNBURNT ) then
            forest(i,j-1) = SMOLDERING
          end if
        end if
!
!  East.
!
        if ( j < forest_size ) then
          if ( fire_spreads ( seed, prob_spread ) .and. forest(i,j+1) == UNBURNT ) then
            forest(i,j+1) = SMOLDERING
          end if
        end if

      end if

    end do
  end do

  return
end
subroutine forest_initialize ( forest_size, forest )

!*****************************************************************************80
!
!! FOREST_INITIALIZE initializes the forest values.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    30 June 2013
!
!  Author:
!
!    FORTRAN90 version by John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) FOREST_SIZE, the linear dimension of the forest.
!
!    Output, integer ( kind = 4 ) FOREST(FOREST_SIZE,FOREST_SIZE), an array
!    with an entry for each tree in the forest.
!
  implicit none

  integer ( kind = 4 ) forest_size

  integer ( kind = 4 ) forest(forest_size,forest_size)
  integer ( kind = 4 ), parameter :: UNBURNT = 0

  forest(1:forest_size,1:forest_size) = UNBURNT

  return
end
function forest_is_burning ( forest_size, forest )

!*****************************************************************************80
!
!! FOREST_IS_BURNING reports whether any trees in the forest are burning.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    30 June 2013
!
!  Author:
!
!    FORTRAN90 version by John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) FOREST_SIZE, the linear dimension of the forest.
!
!    Input, integer ( kind = 4 ) FOREST(FOREST_SIZE,FOREST_SIZE), an array
!    with an entry for each tree in the forest.
!
!    Output, logical FOREST_IS_BURNING, is TRUE if any tree in the forest
!    is in the SMOLDERING or BURNING state.
!
  implicit none

  integer ( kind = 4 ) forest_size

  integer ( kind = 4 ), parameter :: BURNING = 2
  integer ( kind = 4 ) forest(forest_size,forest_size)
  logical forest_is_burning
  integer ( kind = 4 ) i
  integer ( kind = 4 ) j
  integer ( kind = 4 ), parameter :: SMOLDERING = 1
  logical value

  value = .false.

  do j = 1, forest_size
    do i = 1, forest_size
      if ( forest(i,j) == SMOLDERING .or. forest(i,j) == BURNING ) then
        value = .true.
      end if
    end do
  end do

  forest_is_burning = value

  return
end
subroutine forest_print ( forest_size, forest, i_ignite, j_ignite )

!*****************************************************************************80
!
!! FOREST_PRINT prints the state of the trees in the forest.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    30 June 2013
!
!  Author:
!
!    FORTRAN90 version by John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) FOREST_SIZE, the linear dimension of the forest.
!
!    Input, integer ( kind = 4 ) FOREST(FOREST_SIZE,FOREST_SIZE), an array
!    with an entry for each tree in the forest.
!
!    Input, integer ( kind = 4 ) I_IGNITE, J_IGNITE, the location of the start
!    of the fire.
!
  implicit none

  integer ( kind = 4 ) forest_size

  integer ( kind = 4 ), parameter :: BURNT = 3
  integer ( kind = 4 ) forest(forest_size,forest_size)
  integer ( kind = 4 ) i
  integer ( kind = 4 ) i_ignite
  integer ( kind = 4 ) j
  integer ( kind = 4 ) j_ignite

  write ( *, '(a)' ) ''
  write ( *, '(a)' ) '  Map of fire damage.'
  write ( *, '(a)' ) '  Fire started at "*".'
  write ( *, '(a)' ) '  Burned trees are indicated by ".".'
  write ( *, '(a)' ) '  Unburned trees are indicated by "X".'
  write ( *, '(a)' ) ''

  do i = 1, forest_size
    write ( *, '(a)', ADVANCE='NO' ) '  '
    do j = 1, forest_size
      if ( i == i_ignite .and. j == j_ignite ) then
        write ( *, '(a)', ADVANCE='NO' ) '*'
      else if ( forest(i,j) == BURNT ) then
        write ( *, '(a)', ADVANCE='NO' ) '.'
      else
        write ( *, '(a)', ADVANCE='NO' ) 'X'
      end if
    end do
    write ( *, '(a)' ) ''
  end do

  return
end
subroutine get_percent_burned ( forest_size, forest, percent )

!*****************************************************************************80
!
!! GET_PERCENT_BURNED computes the percentage of the forest that burned.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    30 June 2013
!
!  Author:
!
!    FORTRAN90 version by John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) FOREST_SIZE, the linear dimension of the forest.
!
!   Input, integer ( kind = 4 ) FOREST(FOREST_SIZE,FOREST_SIZE), an array
!    with an entry for each tree in the forest.
!
!    Output, real ( kind = 8 ) PERCENT, the percentage of the forest
!    that burned.
!
  implicit none

  integer ( kind = 4 ) forest_size

  integer ( kind = 4 ), parameter :: BURNT = 3
  integer ( kind = 4 ) forest(forest_size,forest_size)
  integer ( kind = 4 ) i
  integer ( kind = 4 ) j
  real ( kind = 8 ) percent
  integer ( kind = 4 ) total

  total = 0
  do j = 1, forest_size
    do i = 1, forest_size
      if ( forest(i,j) == BURNT ) then
        total = total + 1
      end if
    end do
  end do

  percent = real ( total, kind = 8 ) &
    / real ( forest_size * forest_size, kind = 8 )

  return
end
subroutine get_seed ( seed )

!*****************************************************************************80
!
!! GET_SEED returns a seed for the random number generator.
!
!  Discussion:
!
!    The seed depends on the current time, and ought to be (slightly)
!    different every millisecond.  Once the seed is obtained, a random
!    number generator should be called a few times to further process
!    the seed.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    02 August 2004
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Output, integer ( kind = 4 ) SEED, a pseudorandom seed value.
!
  implicit none

  integer ( kind = 4 ), parameter :: i4_huge = 2147483647
  integer ( kind = 4 ) seed
  real ( kind = 8 ) temp
  character ( len = 10 ) time
  character ( len = 8 ) today
  integer ( kind = 4 ) values(8)
  character ( len = 5 ) zone

  call date_and_time ( today, time, zone, values )

  temp = 0.0D+00

  temp = temp + real ( values(2) - 1, kind = 8 ) /  11.0D+00
  temp = temp + real ( values(3) - 1, kind = 8 ) /  30.0D+00
  temp = temp + real ( values(5),     kind = 8 ) /  23.0D+00
  temp = temp + real ( values(6),     kind = 8 ) /  59.0D+00
  temp = temp + real ( values(7),     kind = 8 ) /  59.0D+00
  temp = temp + real ( values(8),     kind = 8 ) / 999.0D+00
  temp = temp                                    /   6.0D+00

  do while ( temp <= 0.0D+00 )
    temp = temp + 1.0D+00
  end do

  do while ( 1.0D+00 < temp )
    temp = temp - 1.0D+00
  end do

  seed = int ( real ( i4_huge, kind = 8 ) * temp )
!
!  Never use a seed of 0 or maximum integer.
!
  if ( seed == 0 ) then
    seed = 1
  end if

  if ( seed == i4_huge ) then
    seed = seed - 1
  end if

  return
end
function i4_uniform_ab ( a, b, seed )

!*****************************************************************************80
!
!! I4_UNIFORM_AB returns a scaled pseudorandom I4 between A and B.
!
!  Discussion:
!
!    An I4 is an integer ( kind = 4 ) value.
!
!    The pseudorandom number will be scaled to be uniformly distributed
!    between A and B.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    02 October 2012
!
!  Author:
!
!    John Burkardt
!
!  Reference:
!
!    Paul Bratley, Bennett Fox, Linus Schrage,
!    A Guide to Simulation,
!    Second Edition,
!    Springer, 1987,
!    ISBN: 0387964673,
!    LC: QA76.9.C65.B73.
!
!    Bennett Fox,
!    Algorithm 647:
!    Implementation and Relative Efficiency of Quasirandom
!    Sequence Generators,
!    ACM Transactions on Mathematical Software,
!    Volume 12, Number 4, December 1986, pages 362-376.
!
!    Pierre L'Ecuyer,
!    Random Number Generation,
!    in Handbook of Simulation,
!    edited by Jerry Banks,
!    Wiley, 1998,
!    ISBN: 0471134031,
!    LC: T57.62.H37.
!
!    Peter Lewis, Allen Goodman, James Miller,
!    A Pseudo-Random Number Generator for the System/360,
!    IBM Systems Journal,
!    Volume 8, Number 2, 1969, pages 136-143.
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) A, B, the limits of the interval.
!
!    Input/output, integer ( kind = 4 ) SEED, the "seed" value, which
!    should NOT be 0.  On output, SEED has been updated.
!
!    Output, integer ( kind = 4 ) I4_UNIFORM_AB, a number between A and B.
!
  implicit none

  integer ( kind = 4 ) a
  integer ( kind = 4 ) b
  integer ( kind = 4 ), parameter :: i4_huge = 2147483647
  integer ( kind = 4 ) i4_uniform_ab
  integer ( kind = 4 ) k
  real ( kind = 4 ) r
  integer ( kind = 4 ) seed
  integer ( kind = 4 ) value

  if ( seed == 0 ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'I4_UNIFORM_AB - Fatal error!'
    write ( *, '(a)' ) '  Input value of SEED = 0.'
    stop
  end if

  k = seed / 127773

  seed = 16807 * ( seed - k * 127773 ) - k * 2836

  if ( seed < 0 ) then
    seed = seed + i4_huge
  end if

  r = real ( seed, kind = 4 ) * 4.656612875E-10
!
!  Scale R to lie between A-0.5 and B+0.5.
!
  r = ( 1.0E+00 - r ) * ( real ( min ( a, b ), kind = 4 ) - 0.5E+00 ) &
    +             r   * ( real ( max ( a, b ), kind = 4 ) + 0.5E+00 )
!
!  Use rounding to convert R to an integer between A and B.
!
  value = nint ( r, kind = 4 )

  value = max ( value, min ( a, b ) )
  value = min ( value, max ( a, b ) )

  i4_uniform_ab = value

  return
end
function r8_uniform_01 ( seed )

!*****************************************************************************80
!
!! R8_UNIFORM_01 returns a unit pseudorandom R8.
!
!  Discussion:
!
!    An R8 is a real ( kind = 8 ) value.
!
!    For now, the input quantity SEED is an integer variable.
!
!    This routine implements the recursion
!
!      seed = 16807 * seed mod ( 2^31 - 1 )
!      r8_uniform_01 = seed / ( 2^31 - 1 )
!
!    The integer arithmetic never requires more than 32 bits,
!    including a sign bit.
!
!    If the initial seed is 12345, then the first three computations are
!
!      Input     Output      R8_UNIFORM_01
!      SEED      SEED
!
!         12345   207482415  0.096616
!     207482415  1790989824  0.833995
!    1790989824  2035175616  0.947702
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    05 July 2006
!
!  Author:
!
!    John Burkardt
!
!  Reference:
!
!    Paul Bratley, Bennett Fox, Linus Schrage,
!    A Guide to Simulation,
!    Springer Verlag, pages 201-202, 1983.
!
!    Pierre L'Ecuyer,
!    Random Number Generation,
!    in Handbook of Simulation,
!    edited by Jerry Banks,
!    Wiley Interscience, page 95, 1998.
!
!    Bennett Fox,
!    Algorithm 647:
!    Implementation and Relative Efficiency of Quasirandom
!    Sequence Generators,
!    ACM Transactions on Mathematical Software,
!    Volume 12, Number 4, pages 362-376, 1986.
!
!    Peter Lewis, Allen Goodman, James Miller
!    A Pseudo-Random Number Generator for the System/360,
!    IBM Systems Journal,
!    Volume 8, pages 136-143, 1969.
!
!  Parameters:
!
!    Input/output, integer ( kind = 4 ) SEED, the "seed" value, which should
!    NOT be 0. On output, SEED has been updated.
!
!    Output, real ( kind = 8 ) R8_UNIFORM_01, a new pseudorandom variate,
!    strictly between 0 and 1.
!
  implicit none

  integer ( kind = 4 ), parameter :: i4_huge = 2147483647
  integer ( kind = 4 ) k
  real ( kind = 8 ) r8_uniform_01
  integer ( kind = 4 ) seed

  if ( seed == 0 ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'R8_UNIFORM_01 - Fatal error!'
    write ( *, '(a)' ) '  Input value of SEED = 0.'
    stop
  end if

  k = seed / 127773

  seed = 16807 * ( seed - k * 127773 ) - k * 2836

  if ( seed < 0 ) then
    seed = seed + i4_huge
  end if

  r8_uniform_01 = real ( seed, kind = 8 ) * 4.656612875D-10

  return
end
subroutine timestamp ( )

!*****************************************************************************80
!
!! TIMESTAMP prints the current YMDHMS date as a time stamp.
!
!  Example:
!
!    31 May 2001   9:45:54.872 AM
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    18 May 2013
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    None
!
  implicit none

  character ( len = 8 ) ampm
  integer ( kind = 4 ) d
  integer ( kind = 4 ) h
  integer ( kind = 4 ) m
  integer ( kind = 4 ) mm
  character ( len = 9 ), parameter, dimension(12) :: month = (/ &
    'January  ', 'February ', 'March    ', 'April    ', &
    'May      ', 'June     ', 'July     ', 'August   ', &
    'September', 'October  ', 'November ', 'December ' /)
  integer ( kind = 4 ) n
  integer ( kind = 4 ) s
  integer ( kind = 4 ) values(8)
  integer ( kind = 4 ) y

  call date_and_time ( values = values )

  y = values(1)
  m = values(2)
  d = values(3)
  h = values(5)
  n = values(6)
  s = values(7)
  mm = values(8)

  if ( h < 12 ) then
    ampm = 'AM'
  else if ( h == 12 ) then
    if ( n == 0 .and. s == 0 ) then
      ampm = 'Noon'
    else
      ampm = 'PM'
    end if
  else
    h = h - 12
    if ( h < 12 ) then
      ampm = 'PM'
    else if ( h == 12 ) then
      if ( n == 0 .and. s == 0 ) then
        ampm = 'Midnight'
      else
        ampm = 'AM'
      end if
    end if
  end if

  write ( *, '(i2,1x,a,1x,i4,2x,i2,a1,i2.2,a1,i2.2,a1,i3.3,1x,a)' ) &
    d, trim ( month(m) ), y, h, ':', n, ':', s, '.', mm, trim ( ampm )

  return
end
subroutine tree_ignite ( forest_size, forest, i_ignite, j_ignite )

!*****************************************************************************80
!
!! TREE_IGNITE sets a given tree to the SMOLDERING state.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    30 June 2013
!
!  Author:
!
!    FORTRAN90 version by John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) FOREST_SIZE, the linear dimension of
!    the forest.
!
!    Input, integer ( kind = 4 ) FOREST(FOREST_SIZE,FOREST_SIZE), an array
!    with an entry for each tree in the forest.
!
!    Input, integer ( kind = 4 ) I_IGNITE, J_IGNITE, the coordinates of the
!    tree which is to be set to SMOLDERING.
!
  implicit none

  integer ( kind = 4 ) forest_size

  integer ( kind = 4 ) forest(forest_size,forest_size)
  integer ( kind = 4 ) i_ignite
  integer ( kind = 4 ) j_ignite
  integer ( kind = 4 ), parameter :: SMOLDERING = 1

  forest(i_ignite,j_ignite) = SMOLDERING

  return
end


! { dg-do run { xfail spu-*-*  } }
! Test XFAILed on Darwin because the system's printf() lacks
! proper support for denormals.
!
! This tests that the default formats for formatted I/O of reals are
! wide enough and have enough precision, by checking that values can
! be written and read back.
!
include "default_format_1.inc"

program main
  use test_default_format

  if (test (1.0_4, 0) /= 0) call abort
  if (test (tiny(0.0_4), 1) /= 0) call abort
  if (test (-tiny(0.0_4), -1) /= 0) call abort
  if (test (huge(0.0_4), -1) /= 0) call abort
  if (test (-huge(0.0_4), 1) /= 0) call abort

  if (test (1.0_8, 0) /= 0) call abort
  if (test (tiny(0.0_8), 1) /= 0) call abort
  if (test (-tiny(0.0_8), -1) /= 0) call abort
  if (test (huge(0.0_8), -1) /= 0) call abort
  if (test (-huge(0.0_8), 1) /= 0) call abort
end program main
!
! { dg-final { cleanup-modules "test_default_format" } }


!==========================================================================
elemental function gsw_ct_from_enthalpy_exact (sa, h, p)
!==========================================================================
!
!  Calculates the Conservative Temperature of seawater, given the Absolute
!  Salinity, specific enthalpy, h, and pressure p.
!
!  SA  =  Absolute Salinity                                        [ g/kg ]
!  h   =  specific enthalpy                                        [ J/kg ]
!  p   =  sea pressure                                             [ dbar ]
!         ( i.e. absolute pressure - 10.1325d0 dbar )
!
!  CT  =  Conservative Temperature ( ITS-90)                      [ deg C ]
!--------------------------------------------------------------------------

use gsw_mod_toolbox, only : gsw_ct_freezing_exact, gsw_enthalpy_ct_exact
use gsw_mod_toolbox, only : gsw_enthalpy_first_derivatives_ct_exact

use gsw_mod_error_functions, only : gsw_error_code

use gsw_mod_teos10_constants, only : gsw_cp0

use gsw_mod_kinds

implicit none

real (r8), intent(in) :: sa, h, p

real (r8) :: gsw_ct_from_enthalpy_exact

real (r8) :: ct, ct_freezing, ct_mean, ct_old, f, h_freezing
real (r8) :: h_ct, h_40

real (r8), parameter :: ct_40 = 40.0_r8

character (*), parameter :: func_name = "gsw_ct_from_enthalpy_exact"

ct_freezing = gsw_ct_freezing_exact(sa,p,0.0_r8)

h_freezing = gsw_enthalpy_ct_exact(sa,ct_freezing,p)
if (h .lt. h_freezing - gsw_cp0) then
    ! The input, seawater enthalpy h, is less than the enthalpy at the
    ! freezing temperature, i.e. the water is frozen.
    gsw_ct_from_enthalpy_exact = gsw_error_code(1,func_name)
    return
endif

h_40 = gsw_enthalpy_ct_exact(sa,ct_40,p)
if (h .gt. h_40) then
    ! The input seawater enthalpy is greater than the enthalpy when CT is 40C
    gsw_ct_from_enthalpy_exact = gsw_error_code(2,func_name)
    return
endif

! First guess of ct
ct = ct_freezing + (ct_40 - ct_freezing)*(h - h_freezing)/(h_40 - h_freezing)
call gsw_enthalpy_first_derivatives_ct_exact(sa,ct,p,h_ct=h_ct)

!--------------------------------------------------------------------------
! Begin the modified Newton-Raphson iterative procedure
!--------------------------------------------------------------------------

ct_old = ct
f = gsw_enthalpy_ct_exact(sa,ct_old,p) - h
ct = ct_old - f/h_ct
ct_mean = 0.5_r8*(ct + ct_old)
call gsw_enthalpy_first_derivatives_ct_exact(sa,ct_mean,p,h_ct=h_ct)
ct = ct_old - f/h_ct

! After 1 iteration of this modified Newton-Raphson iteration,
! the error in CT is no larger than 5x10^-14 degrees C, which
! is machine precision for this calculation.

gsw_ct_from_enthalpy_exact = ct

return
end function

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


MODULE ttvfaster

	! Fortran90 version of TTVFaster (Kat Deck & Eric Agol) by David Kipping
	! Please cite the paper (Agol & Deck 2015) if you make use of this code in
	! your research.

 implicit none

 CONTAINS

	! Try to preserve original for loop indices, but update memory allocations +1

 ! =======================================================
 SUBROUTINE compute_ttv(nt1,nt2,time1,time2,param,jmax,model1,model2)

 implicit none

 ! Inputs
 INTEGER, INTENT(IN) :: nt1, nt2, jmax
 REAL(8), DIMENSION(nt1), INTENT(IN) :: time1
 REAL(8), DIMENSION(nt2), INTENT(IN) :: time2
 REAL(8), DIMENSION(10), INTENT(IN) :: param
 ! Intermediate
 INTEGER :: i, j
 REAL(8) :: p1massratio, p1trans0, p1period, p1ecos, p1esin
 REAL(8) :: p2massratio, p2trans0, p2period, p2ecos, p2esin
 REAL(8) :: alpha
 REAL(8), DIMENSION(nt1) :: lam11, lam21, psi1
 REAL(8), DIMENSION(nt2) :: lam12, lam22, psi2
 REAL(8), DIMENSION(5,jmax+2) :: f1, f2
 REAL(8), DIMENSION(nt1) :: ttv1
 REAL(8), DIMENSION(nt2) :: ttv2
 ! Output
 REAL(8), DIMENSION(nt1), INTENT(OUT) :: model1
 REAL(8), DIMENSION(nt2), INTENT(OUT) :: model2
 ! Constants
 REAL(8), PARAMETER :: twopi = 6.283185307179586D0

 ! Planet 1 parameters
 p1massratio = param(1)
 p1trans0 = param(2)
 p1period = param(3)
 p1ecos = param(4)
 p1esin = param(5)
 ! Planet 2 parameters
 p2massratio = param(6)
 p2trans0 = param(7)
 p2period = param(8)
 p2ecos = param(9)
 p2esin = param(10)

 ! Compute the semi-major axis ratio of the planets
 alpha = DABS(p1period/p2period)**(2.0/3.0)
 ! Compute the longitudes of the planets at times of transit of planet 1 (equation 32)
 DO i=1,nt1
	 lam11(i) = twopi*(time1(i)-p1trans0)/p1period + 2.0D0*p1esin
	 lam21(i) = twopi*(time1(i)-p2trans0)/p2period + 2.0D0*p2esin
	 ! Compute the difference in in longitudes at times of transit of planet 1
	 psi1(i) = lam11(i) - lam21(i)
 END DO
 ! Compute the longitudes of the planets at times of transit of planet 2 (equation 32)
 DO i=1,nt2
	 lam12(i) = twopi*(time2(i)-p1trans0)/p1period + 2.0D0*p1esin
	 lam22(i) = twopi*(time2(i)-p2trans0)/p2period + 2.0D0*p2esin
	 ! Compute the difference in in longitudes at times of transit of planet 2
	 psi2(i) = lam12(i) - lam22(i)
 END DO
 ! Compute the coefficients (need one higher than jmax)
 call ttv_succint(jmax+1,alpha,f1,f2)

 ttv1(:) = 0.0D0
 ttv2(:) = 0.0D0
 ! Compute TTVs for inner planet (equation 33)
 DO j=1,jmax ! python does range(1,jmax+1) = 1,2,...,jmax
	 ttv1(:) = ttv1(:) + f1(1+0,1+j)*DSIN(j*psi1(:))
	 ttv1(:) = ttv1(:) + f1(1+1,1+j)*( p1ecos*DSIN( (j-1)*lam11(:) - j*lam21(:) ) + &
	                                   p1esin*DCOS( (j-1)*lam11(:) - j*lam21(:) ) )
	 ttv1(:) = ttv1(:) + f1(1+2,1+j)*( p1ecos*DSIN( (j+1)*lam11(:) - j*lam21(:) ) - &
																     p1esin*DCOS( (j+1)*lam11(:) - j*lam21(:) ) )
	 ttv1(:) = ttv1(:) + f1(1+3,1+j-1)*( p2ecos*DSIN( (j-1)*lam11(:) - j*lam21(:) ) + &
															  	     p2esin*DCOS( (j-1)*lam11(:) - j*lam21(:) ) )
	 ttv1(:) = ttv1(:) + f1(1+4,1+j+1)*( p2ecos*DSIN( (j+1)*lam11(:) - j*lam21(:) ) - &
																       p2esin*DCOS( (j+1)*lam11(:) - j*lam21(:) ) )
 END DO
 ! Now multiply by the mass ratio and divide by mean motion
 ttv1(:) = ttv1(:)*p1period*p2massratio/twopi

 ! Compute TTVs for outer planet (equation 33)
 DO j=1,jmax
	 ttv2(:) = ttv2(:) + f2(1+0,1+j)*DSIN(j*psi2(:))
	 ttv2(:) = ttv2(:) + f2(1+1,1+j)*( p2ecos*DSIN( j*lam12(:) - (j+1)*lam22(:) ) + &
	                                   p2esin*DCOS( j*lam12(:) - (j+1)*lam22(:) ) )
	 ttv2(:) = ttv2(:) + f2(1+2,1+j)*( p2ecos*DSIN( j*lam12(:) - (j-1)*lam22(:) ) - &
																     p2esin*DCOS( j*lam12(:) - (j-1)*lam22(:) ) )
	 ttv2(:) = ttv2(:) + f2(1+3,1+j+1)*( p1ecos*DSIN( j*lam12(:) - (j+1)*lam22(:) ) + &
															  	     p1esin*DCOS( j*lam12(:) - (j+1)*lam22(:) ) )
	 ttv2(:) = ttv2(:) + f2(1+4,1+j-1)*( p1ecos*DSIN( j*lam12(:) - (j-1)*lam22(:) ) - &
																       p1esin*DCOS( j*lam12(:) - (j-1)*lam22(:) ) )
 END DO
 ! Now multiply by the mass ratio and divide by mean motion
 ttv2(:) = ttv2(:)*p2period*p1massratio/twopi

 ! Add the TTVs to the ephemeris and return to user
 DO i=1,nt1
   model1(i) = p1trans0 + (i-1)*p1period + ttv1(i)
 END DO
 DO i=1,nt2
   model2(i) = p2trans0 + (i-1)*p2period + ttv2(i)
 END DO

 END SUBROUTINE compute_ttv
 ! =======================================================

 ! =======================================================
 FUNCTION ufn(gammz,z1,z2)
 ! Define function u (equation 34)

 implicit none

 REAL(8), INTENT(IN) :: gammz, z1, z2
 REAL(8) :: ufn

 ufn = ( ( (3.0+gammz**2)*z1 + 2.0*gammz*z2 ) / &
       gammz**2 / (1.0-gammz**2) )

 RETURN

 END FUNCTION
 ! =======================================================

 ! =======================================================
 FUNCTION vfn(zeta,d1,d2,m)
 ! Define function v (equation 34)

 implicit none

 INTEGER, INTENT(IN) :: m ! m = +/- 1
 REAL(8), INTENT(IN) :: zeta, d1, d2
 REAL(8) :: vfn

 vfn = ((m*(1.0 - zeta**2) + 6.0*zeta)*d1 + &
       (2.0 + zeta**2)*d2) / (zeta*(1.0-zeta**2)* &
	     (zeta+m)*(zeta+2.0*m))

 RETURN

 END FUNCTION
 ! =======================================================

 ! =======================================================
 FUNCTION laplace_wisdom(s,i,j,a)

 ! Code due to Jack Wisdom.
 ! Compute Laplace coefficients and Leverrier derivatives
 !       j
 !  j   d     i
 ! a   ---   b (a)
 !       j    s
 !     da
 ! by series summation.

 REAL(8), INTENT(IN) :: s, a
 INTEGER, INTENT(IN) :: j
 INTEGER :: i
 REAL(8), PARAMETER :: laplaceeps = 1.0D-12
 REAL(8) :: asquare, term
 REAL(8) :: factorone, factortwo, factorthree, factorfour
 INTEGER :: q0, q, k
 REAL(8) :: laplace_wisdom

 asquare = a*a
 i = ABS(i)

 ! compute first term in sum
 IF( j .LE. i ) THEN
   factorfour = 1.0
   DO k=0,j-1 ! python was range(j), so 0,1,2,..,j-1
     factorfour = factorfour*DBLE(i-k)
   END DO
   laplace_wisdom = factorfour
   q0 = 0
 ELSE
   q0 = (j+1-i)/2
   laplace_wisdom = 0.0
   factorfour = 1.0
 END IF

 ! compute factors for terms in sum
 factorone = s
 factortwo = s + DBLE(i)
 factorthree = DBLE(i) + 1.0
 q = 1
 ! no contribution from q = 0
 DO q=1,q0-1 ! python is range (1,q0) so 1,2..,q0-1
   factorone   = factorone*(   s + DBLE(q)     )
   factortwo   = factortwo*(   s + DBLE(i+q)   )
   factorthree = factorthree*(     DBLE(i+q+1) )
 END DO

 term = asquare*factorone*factortwo/(factorthree*DBLE(q))

 ! sum series
 DO WHILE (term*factorfour .GT. laplaceeps)
   factorfour = 1.0
   DO k=0,j-1 ! python was range (j), so 0,1,2,..,j-1
     factorfour = factorfour*( 2.0*DBLE(q) + DBLE(i-k) )
   END DO
   laplace_wisdom = laplace_wisdom + term*factorfour
   factorone   = factorone   + 1.0
   factortwo   = factortwo   + 1.0
   factorthree = factorthree + 1.0
   q = q + 1
   term = term*asquare*factorone*factortwo/(factorthree*DBLE(q))
 END DO

 ! fix coefficient
 DO k=0,i-1 ! python was range(i) so 0,1,2,..,i-1
   laplace_wisdom = laplace_wisdom*(s+DBLE(k)) / (DBLE(k)+1.0)
 END DO

 IF( q0 .LE. 0 ) THEN
   laplace_wisdom = laplace_wisdom*2.0*a**i
 ELSE
   laplace_wisdom = laplace_wisdom*2.0*a**(2*q0 + i - 2)
 END IF

 RETURN

 END FUNCTION
 ! =======================================================

 ! =======================================================
 SUBROUTINE ttv_succint(jmax,alpha,f1,f2)

 implicit none

 INTEGER :: j, k
 INTEGER, INTENT(IN) :: jmax
 REAL(8), INTENT(IN) :: alpha
 REAL(8) :: Pratio, beta, kappa, dj1
 REAL(8) :: Ajaa, Ajba, Ajab, Ajca, Ajbb, Ajac
 REAL(8), DIMENSION(5) :: c1, c2, gammy
 REAL(8), DIMENSION(3,jmax+1) :: b
 REAL(8), DIMENSION(5,jmax+1), INTENT(OUT) :: f1, f2

 ! Succinct form for coefficients of first-order TTV formula
 !    Parameters
 !    ----------
 !    jmax:  maximum value of j over which to compute the coefficients
 !    alpha:  a_1/a_2 of the two planets
 !    Returns
 !    -------
 !    b:  Matrix of Laplace coefficients.
 !    f1:  Coefficients for the inner planet.  For each value of
 !        j=0 to jmax, there are 5 coefficients:
 !        the f_{1,j}^(0), f_{1,j}^(+-1), and
 !        f_{1,j}^(+-2) coefficients.
 !        The +-1 coefficients correspond to
 !        j*(lam_1-lam_2)+-(lam_1-omega_1) arguments.
 !        The +-2 coefficients correspond to
 !        j*(lam_1-lam_2)+-(lam_1-omega_2) arguments.
 !    f2:  Coefficients for the outer planet.  For each value of
 !        j=0 to jmax, there are 5 coefficients:
 !        the f_{1,j}^(0), f_{1,j}^(+-2), and
 !        f_{1,j}^(+-1) coefficients.
 !        The +-1 coefficients correspond to
 !        j*(lam_1-lam_2)+-(lam_2-omega_1) arguments.
 !        The +-2 coefficients correspond to
 !        j*(lam_1-lam_2)+-(lam_2-omega_2) arguments.

 f1(:,:) = 0.0D0
 f2(:,:) = 0.0D0
 Pratio = DSQRT(alpha**3)

 ! Compute the Laplace coefficients
 call laplace_coefficients(jmax,alpha,b)

 ! Now loop over j values
 DO j=0,jmax ! python uses range(jmax+1)=0,1,2,...,jmax
   IF( j .EQ. 1 ) THEN
	   dj1 = 1.0
   ELSE
	   dj1 = 0.0
   END IF
   beta = j*( 1.0 - Pratio )
   kappa = beta/Pratio

   ! Compute the disturbing function [note we have to increase memory indices by 1, and switch order]
   Ajaa = b(1+0,1+j)
   Ajba = alpha*b(1+1,1+j)
   Ajab = -(Ajba + Ajaa)
   Ajca = alpha**2*b(1+2,1+j)
   Ajbb = -(2.0*Ajba + Ajca)
   Ajac = 2.0*Ajaa + 4.0*Ajba + Ajca

   ! Inner planer coefficients
   gammy(1) = beta
   gammy(2) = beta - 1.0
   gammy(3) = beta + 1.0
   gammy(4) = beta - Pratio
   gammy(5) = beta + Pratio

   c1(1) = alpha*j*( Ajaa*1.0 - 0.5*Ajab*0.0 - 0.5*Ajba*0.0 - alpha*dj1*1.0 )
   c1(2) = alpha*j*(-Ajaa*j   - 0.5*Ajab*0.0 - 0.5*Ajba*1.0 + alpha*dj1*1.5 )
   c1(3) = alpha*j*( Ajaa*j   - 0.5*Ajab*0.0 - 0.5*Ajba*1.0 - alpha*dj1*0.5 )
   c1(4) = alpha*j*( Ajaa*j   - 0.5*Ajab*1.0 - 0.5*Ajba*0.0 - alpha*dj1*2.0 )
   c1(5) = alpha*j*(-Ajaa*j   - 0.5*Ajab*1.0 - 0.5*Ajba*0.0 - alpha*dj1*0.0 )

   c2(1) = alpha*( Ajba*1.0 - 0.5*Ajbb*0.0 - 0.5*Ajca*0.0 - alpha*dj1*1.0 )
   c2(2) = alpha*(-Ajba*j   - 0.5*Ajbb*0.0 - 0.5*Ajca*1.0 + alpha*dj1*1.0 )
   c2(3) = alpha*( Ajba*j   - 0.5*Ajbb*0.0 - 0.5*Ajca*1.0 - alpha*dj1*1.0 )
   c2(4) = alpha*( Ajba*j   - 0.5*Ajbb*1.0 - 0.5*Ajca*0.0 - alpha*dj1*2.0 )
   c2(5) = alpha*(-Ajba*j   - 0.5*Ajbb*1.0 - 0.5*Ajca*0.0 - alpha*dj1*0.0 )

   IF( j .GE. 2 ) THEN
     DO k=0,4 ! python does range(5) = 0,1,2,3,4
		   f1(1+k,1+j) = ufn( gammy(1+k), c1(1+k), c2(1+k) )
	   END DO
   ELSE
	   IF( j .EQ. 0 ) THEN
		   f1(1+3,1+j) = ufn( gammy(1+3), c1(1+3), c2(1+3) )
	   ELSE
	     DO k=0,3 ! python does range(4) = 0,1,2,3
		     f1(1+k,1+j) = ufn( gammy(1+k), c1(1+k), c2(1+k) )
	     END DO
     END IF
	 END IF

   ! Add in the k=\pm 1 coefficients (note that d1 & d2 are the same as)
   ! c1 & c2 for k=0
   IF( j .GE. 1 ) THEN
	   f1(1+1,1+j) = f1(1+1,1+j) + vfn( beta, c1(1+0), c2(1+0),-1 )
	   f1(1+2,1+j) = f1(1+2,1+j) + vfn( beta, c1(1+0), c2(1+0), 1 )
   END IF

   ! Now for the outer planet
   ! Outer planet coefficients, in order k=0,-2,2,-1,1 (see Table 1)
	 ! [manual assignments]
	 gammy(1) = kappa
	 gammy(2) = kappa - 1.0
	 gammy(3) = kappa + 1.0
	 gammy(4) = kappa - 1.0/Pratio
	 gammy(5) = kappa + 1.0/Pratio

	 c1(1) = -j*( Ajaa*1.0 - 0.5*Ajab*0.0 - 0.5*Ajba*0.0 - dj1/alpha**2*1.0 )
	 c1(2) = -j*( Ajaa*j   - 0.5*Ajab*1.0 - 0.5*Ajba*0.0 - dj1/alpha**2*0.5 )
	 c1(3) = -j*(-Ajaa*j   - 0.5*Ajab*1.0 - 0.5*Ajba*0.0 + dj1/alpha**2*1.5 )
	 c1(4) = -j*(-Ajaa*j   - 0.5*Ajab*0.0 - 0.5*Ajba*1.0 - dj1/alpha**2*0.0 )
	 c1(5) = -j*( Ajaa*j   - 0.5*Ajab*0.0 - 0.5*Ajba*1.0 - dj1/alpha**2*2.0 )

	 c2(1) = ( Ajab*1.0 - 0.5*Ajbb*0.0 - 0.5*Ajac*0.0 - dj1/alpha**2*1.0 )
	 c2(2) = ( Ajab*j   - 0.5*Ajbb*0.0 - 0.5*Ajac*1.0 - dj1/alpha**2*1.0 )
	 c2(3) = (-Ajab*j   - 0.5*Ajbb*0.0 - 0.5*Ajac*1.0 + dj1/alpha**2*1.0 )
	 c2(4) = (-Ajab*j   - 0.5*Ajbb*1.0 - 0.5*Ajac*0.0 - dj1/alpha**2*0.0 )
	 c2(5) = ( Ajab*j   - 0.5*Ajbb*1.0 - 0.5*Ajac*0.0 - dj1/alpha**2*2.0 )

	 IF( j .GE. 2 ) THEN
		 DO k=0,3 ! python does range(4) = 0,1,2,3
			 f2(1+k,1+j) = ufn( gammy(1+k), c1(1+k), c2(1+k) )
		 END DO
	 ELSE
		 IF( j .EQ. 1 ) THEN
			 DO k=0,2 ! python does range(3) = 0,1,2
				 f2(1+k,1+j) = ufn( gammy(1+k), c1(1+k), c2(1+k) )
			 END DO
		 END IF
	 END IF
	 f2(1+4,1+j) = ufn(gammy(1+4),c1(1+4),c2(1+4))
	 ! Add in the k=\pm 2 coefficients (note that d1 & d2 are the same as
   ! c1 & c2 for k=0)
	 IF( j .GE. 1 ) THEN
	   f2(1+1,1+j) = f2(1+1,1+j) + vfn( kappa, c1(1+0), c2(1+0),-1)
		 f2(1+2,1+j) = f2(1+2,1+j) + vfn( kappa, c1(1+0), c2(1+0), 1)
	 END IF
 END DO

 END SUBROUTINE ttv_succint
 ! =======================================================

 ! =======================================================
 SUBROUTINE laplace_coefficients(j,alpha,b)

 !This computes the Laplace coefficients via recursion.
 ! j spans 0 to jmax
 ! b(1,j+1), b(2,j+1), b(3,j+1) go out

 implicit none

 INTEGER, INTENT(IN) :: j
 REAL(8), INTENT(IN) :: alpha
 INTEGER :: j0
 REAL(8) :: jd
 REAL(8), DIMENSION(3,j+1), INTENT(OUT) :: b

 ! Because of fortran indexing, we have to just add +1 onto
 ! the indices uses by the b array. We swap the indices around
 ! to optimize memory usage

 ! Compute the highest two Laplace coefficients using
 ! Wisdom's series approach
 b(:,:) = 0.0D0
 b(1+0,1+j)   = laplace_wisdom(0.5D0,j,0,alpha)
 b(1+0,1+j-1) = laplace_wisdom(0.5D0,j-1,0,alpha)
 b(1+1,1+j)   = laplace_wisdom(0.5D0,j,1,alpha)/alpha
 b(1+1,1+j-1) = laplace_wisdom(0.5D0,j-1,1,alpha)/alpha
 b(1+2,1+j)   = laplace_wisdom(0.5D0,j,2,alpha)/alpha/alpha
 b(1+2,1+j-1) = laplace_wisdom(0.5D0,j-1,2,alpha)/alpha/alpha

 ! The rest can be found with the recurion formula
 j0 = j - 2
 DO WHILE (j0 .GE. 0)
   ! Recurrence relations (derived on 9/9/14; also see Brouwer & Clemence)
   jd = DBLE(j0)
   b(1+0,1+j0) = (-(2.0*jd+3.0)*b(1+0,1+j0+2) + &
                 (1.0+alpha*alpha)/alpha*2.0*(jd+1.0)*b(1+0,1+j0+1))/(2.0*jd+1.0)
   ! Recurrence for first derivative
   b(1+1,1+j0) = b(1+1,1+j0+2) - (2.0*alpha*(jd+1.0)*b(1+0,1+j0+1) - &
                 jd*b(1+0,1+j0) - (jd+2.0)*b(1+0,1+j0+2) )/alpha
   ! Recurrence for second derivative
   b(1+2,1+j0) = b(1+2,1+j0+2) - 2.0*(jd+1.0)*b(1+1,1+j0+1) - &
                 ( jd*b(1+0,1+j0) + &
			           (jd+2.0)*b(1+0,1+j0+2) )/alpha/alpha + &
			           ( jd*b(1+1,1+j0) + (jd+2.0)*b(1+1,1+j0+2) )/alpha
   j0 = j0 - 1
 END DO

 END SUBROUTINE laplace_coefficients
 ! =======================================================

END MODULE ttvfaster


FUNCTION CSEDRESS(DENBULK,WRSPO,VDRO,VDR,VDRC,IOPT)

  ! CHANGE RECORD

  ! **  CALCULATES SURFACE EROSION RATE OF COHESIVE
  ! **  SEDIMENT AS A FUNCTION OF BED BULK DENSITY
  ! **  IOPT=1  BASED ON
  ! **
  ! **  HWANG, K. N., AND A. J. MEHTA, 1989: FINE SEDIMENT ERODIBILITY
  ! **  IN LAKE OKEECHOBEE FLORIDA. COASTAL AND OCEANOGRAPHIC ENGINEERING
  ! **  DEPARTMENT, UNIVERSITY OF FLORIDA, GAINESVILLE, FL32661
  ! **  IOPT=2  BASED ON J. M. HAMRICK'S MODIFICATION OF
  ! **
  ! **  SANFORD, L.P., AND J. P. Y. MAA, 2001: A UNIFIED EROSION FORMULATION
  ! **  FOR FINE SEDIMENT, MARINE GEOLOGY, 179, 9-23.
  !
  ! **  IOPT=4 & 5 BASED ON J. M. HAMRICK'S PARAMETERIZATION OF SEDFLUME
  !     TEST DATA
  ! **

  IMPLICIT NONE

  INTEGER :: IOPT
  REAL :: CSEDRESS,DENBULK,WRSPO,VDRO,VDR,VDRC
  REAL :: BULKDEN,TMP,TMPVAL,FACTOR

  IF( IOPT == 1 )THEN
    BULKDEN=0.001*DENBULK    ! *** TO PREVENT CORRUPTING THE DENBULK VARIABLE
    IF( BULKDEN <= 1.065 )THEN
      CSEDRESS=0.62
    ELSE
      TMP=0.198/(BULKDEN-1.0023)
      TMP=EXP(TMP)
      CSEDRESS=6.4E-4*(10.**TMP)
    ENDIF
  ELSEIF( IOPT == 2 )THEN
    CSEDRESS=WRSPO*(1.+VDRO)/(1.+VDR)
  ELSEIF( IOPT == 3 )THEN
    CSEDRESS=WRSPO*(1.+VDRO)/(1.+VDRC)
  ELSEIF( IOPT == 4 )THEN
    TMPVAL=(1.+VDRO)/(1.+VDR)
    FACTOR=EXP(-TMPVAL)
    CSEDRESS=FACTOR*WRSPO*(1.+VDRO)/(1.+VDR)
  ELSEIF( IOPT == 5 )THEN
    TMPVAL=(1.+VDRO)/(1.+VDRC)
    FACTOR=EXP(-TMPVAL)
    CSEDRESS=FACTOR*WRSPO*(1.+VDRO)/(1.+VDRC)
  ELSEIF( IOPT >= 99 )THEN
    CSEDRESS=WRSPO
  ENDIF

END FUNCTION


      SUBROUTINE MB03RY( M, N, PMAX, A, LDA, B, LDB, C, LDC, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To solve the Sylvester equation -AX + XB = C, where A and B are
C     M-by-M and N-by-N matrices, respectively, in real Schur form.
C
C     This routine is intended to be called only by SLICOT Library
C     routine MB03RD. For efficiency purposes, the computations are
C     aborted when the infinity norm of an elementary submatrix of X is
C     greater than a given value PMAX.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     M       (input) INTEGER
C             The order of the matrix A and the number of rows of the
C             matrices C and X.  M >= 0.
C
C     N       (input) INTEGER
C             The order of the matrix B and the number of columns of the
C             matrices C and X.  N >= 0.
C
C     PMAX    (input) DOUBLE PRECISION
C             An upper bound for the infinity norm of an elementary
C             submatrix of X (see METHOD).
C
C     A       (input) DOUBLE PRECISION array, dimension (LDA,M)
C             The leading M-by-M part of this array must contain the
C             matrix A of the Sylvester equation, in real Schur form.
C             The elements below the real Schur form are not referenced.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= MAX(1,M).
C
C     B       (input) DOUBLE PRECISION array, dimension (LDB,N)
C             The leading N-by-N part of this array must contain the
C             matrix B of the Sylvester equation, in real Schur form.
C             The elements below the real Schur form are not referenced.
C
C     LDB     INTEGER
C             The leading dimension of array B.  LDB >= MAX(1,N).
C
C     C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
C             On entry, the leading M-by-N part of this array must
C             contain the matrix C of the Sylvester equation.
C             On exit, if INFO = 0, the leading M-by-N part of this
C             array contains the solution matrix X of the Sylvester
C             equation, and each elementary submatrix of X (see METHOD)
C             has the infinity norm less than or equal to PMAX.
C             On exit, if INFO = 1, the solution matrix X has not been
C             computed completely, because an elementary submatrix of X
C             had the infinity norm greater than PMAX. Part of the
C             matrix C has possibly been overwritten with the
C             corresponding part of X.
C
C     LDC     INTEGER
C             The leading dimension of array C.  LDC >= MAX(1,M).
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             = 1:  an elementary submatrix of X had the infinity norm
C                   greater than the given value PMAX.
C
C     METHOD
C
C     The routine uses an adaptation of the standard method for solving
C     Sylvester equations [1], which controls the magnitude of the
C     individual elements of the computed solution [2]. The equation
C     -AX + XB = C can be rewritten as
C                                 p            l-1
C       -A  X   + X  B   = C   + sum  A  X   - sum  X  B
C         kk kl    kl ll    kl  i=k+1  ki il   j=1   kj jl
C
C     for l = 1:q, and k = p:-1:1, where A  , B  , C  , and X  , are
C                                         kk   ll   kl       kl
C     block submatrices defined by the partitioning induced by the Schur
C     form of A and B, and p and q are the numbers of the diagonal
C     blocks of A and B, respectively. So, the elementary submatrices of
C     X are found block column by block column, starting from the
C     bottom. If any such elementary submatrix has the infinity norm
C     greater than the given value PMAX, the calculations are ended.
C
C     REFERENCES
C
C     [1] Bartels, R.H. and Stewart, G.W.  T
C         Solution of the matrix equation A X + XB = C.
C         Comm. A.C.M., 15, pp. 820-826, 1972.
C
C     [2] Bavely, C. and Stewart, G.W.
C         An Algorithm for Computing Reducing Subspaces by Block
C         Diagonalization.
C         SIAM J. Numer. Anal., 16, pp. 359-367, 1979.
C
C     NUMERICAL ASPECTS
C                               2      2
C     The algorithm requires 0(M N + MN ) operations.
C
C     FURTHER COMMENTS
C
C     Let
C
C            ( A   C )       ( I   X )
C        M = (       ),  Y = (       ).
C            ( 0   B )       ( 0   I )
C
C     Then
C
C         -1      ( A   0 )
C        Y  M Y = (       ),
C                 ( 0   B )
C
C     hence Y is an non-orthogonal transformation matrix which performs
C     the reduction of M to a block-diagonal form. Bounding a norm of
C     X is equivalent to setting an upper bound to the condition number
C     of the transformation matrix Y.
C
C     CONTRIBUTOR
C
C     V. Sima, Katholieke Univ. Leuven, Belgium, June 1998.
C     Based on the RASP routine SYLSM by A. Varga, German Aerospace
C     Center, DLR Oberpfaffenhofen.
C
C     REVISIONS
C
C     -
C
C     KEYWORDS
C
C     Diagonalization, real Schur form, Sylvester equation.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      INTEGER           INFO, LDA, LDB, LDC, M, N
      DOUBLE PRECISION  PMAX
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LDA,*), B(LDB,*), C(LDC,*)
C     .. Local Scalars ..
      INTEGER           DK, DL, I, IERR, J, K, KK, KK1, L, LL, LM1
      DOUBLE PRECISION  PNORM, SCALE
C     .. Local Arrays ..
      DOUBLE PRECISION  P(4)
C     .. External Functions ..
      DOUBLE PRECISION  DDOT
      EXTERNAL          DDOT
C     .. External Subroutines ..
      EXTERNAL          DGEMM, DGEMV, DLASY2
C     .. Executable Statements ..
C
C     For efficiency reasons, this routine does not check the input
C     parameters for errors.
C
      INFO = 0
C
C     Column loop indexed by L.
C
      L = 1
C     WHILE ( L.LE.N ) DO
   10 IF ( L.LE.N ) THEN
         LM1 = L - 1
         DL = 1
         IF ( L.LT.N ) THEN
            IF ( B(L+1,L).NE.ZERO )
     $         DL = 2
         ENDIF
         LL = LM1 + DL
         IF ( LM1.GT.0 ) THEN
C
C           Update one (or two) column(s) of C.
C
            IF ( DL.EQ.2 ) THEN
               CALL DGEMM( 'No transpose', 'No transpose', M, DL, LM1,
     $                     -ONE, C, LDC, B(1,L), LDB, ONE, C(1,L), LDC )
            ELSE
               CALL DGEMV( 'No transpose', M, LM1, -ONE, C, LDC, B(1,L),
     $                     1, ONE, C(1,L), 1 )
            END IF
         ENDIF
C
C        Row loop indexed by KK.
C
         KK = M
C        WHILE ( KK.GE.1 ) DO
   20    IF ( KK.GE.1 ) THEN
            KK1 = KK + 1
            DK = 1
            IF ( KK.GT.1 ) THEN
               IF ( A(KK,KK-1).NE.ZERO )
     $            DK = 2
            ENDIF
            K = KK1 - DK
            IF ( K.LT.M ) THEN
C
C              Update an elementary submatrix of C.
C
               DO 40 J = L, LL
C
                  DO 30 I = K, KK
                     C(I,J) = C(I,J) +
     $                        DDOT( M-KK, A(I,KK1), LDA, C(KK1,J), 1 )
   30             CONTINUE
C
   40          CONTINUE
C
            ENDIF
            CALL DLASY2( .FALSE., .FALSE., -1, DK, DL, A(K,K), LDA,
     $                   B(L,L), LDB, C(K,L), LDC, SCALE, P, DK, PNORM,
     $                   IERR )
            IF( SCALE.NE.ONE .OR. PNORM.GT.PMAX ) THEN
                INFO = 1
                RETURN
            END IF
            C(K,L) = -P(1)
            IF ( DL.EQ.1 ) THEN
               IF ( DK.EQ.2 )
     $            C(KK,L)  = -P(2)
            ELSE
               IF ( DK.EQ.1 ) THEN
                  C(K,LL)  = -P(2)
               ELSE
                  C(KK,L)  = -P(2)
                  C(K,LL)  = -P(3)
                  C(KK,LL) = -P(4)
               ENDIF
            ENDIF
            KK = KK - DK
            GO TO 20
         END IF
C        END WHILE 20
         L = L + DL
         GO TO 10
      END IF
C     END WHILE 10
      RETURN
C *** Last line of MB03RY ***
      END


MODULE PERIOD_ACCELERATION_MDL
    INTERFACE
         SUBROUTINE ACCELERATION_OF_PERIODS( ALPHAS, &
                                    CURRENT_PERIODS, &
                                    INTERNAL_STRESS, &
                                    EXTERNAL_STRESS, &
                               PERIOD_ACCELERATIONS   )
             IMPLICIT NONE
             REAL*8, INTENT(IN) :: ALPHAS(3),            &
                                   CURRENT_PERIODS(3,3), &
                                   INTERNAL_STRESS(3,3), &
                                   EXTERNAL_STRESS(3,3)
             REAL*8, INTENT(OUT):: PERIOD_ACCELERATIONS(3,3)
         END SUBROUTINE ACCELERATION_OF_PERIODS
    END INTERFACE
END MODULE PERIOD_ACCELERATION_MDL

         SUBROUTINE ACCELERATION_OF_PERIODS( ALPHAS, &
                                    CURRENT_PERIODS, &
                                    INTERNAL_STRESS, &
                                    EXTERNAL_STRESS, &
                               PERIOD_ACCELERATIONS   )
             IMPLICIT NONE
             REAL*8, INTENT(IN) :: ALPHAS(3),            &
                                   CURRENT_PERIODS(3,3), &
                                   INTERNAL_STRESS(3,3), &
                                   EXTERNAL_STRESS(3,3)
             REAL*8, INTENT(OUT):: PERIOD_ACCELERATIONS(3,3)
             REAL*8             :: CELL_SURFACES(3,3)
             REAL*8             :: CELL_VOLUME
             INTEGER            :: I, J, K, L, M, N

             DO I = 1, 3
                J = MOD(I, 3) + 1
                K = MOD(J, 3) + 1
                DO L = 1, 3
                   M = MOD(L, 3) + 1
                   N = MOD(M, 3) + 1
                   CELL_SURFACES(L,I) =                              &
                         CURRENT_PERIODS(M,J) * CURRENT_PERIODS(N,K) &
                       - CURRENT_PERIODS(N,J) * CURRENT_PERIODS(M,K)
                END DO
             END DO

             CELL_VOLUME = CELL_SURFACES(1,1) * CURRENT_PERIODS(1,1) &
                         + CELL_SURFACES(2,1) * CURRENT_PERIODS(2,1) &
                         + CELL_SURFACES(3,1) * CURRENT_PERIODS(3,1)

             IF(CELL_VOLUME <= 1.0D-10) THEN
                PRINT*, "Sorry, too small or negative cell volume:"
                PRINT*, CELL_VOLUME
                STOP
             END IF

             DO I = 1, 3
                DO J = 1, 3
                   PERIOD_ACCELERATIONS(J, I) = 0.0D0
                   DO K = 1, 3
                      PERIOD_ACCELERATIONS(J, I) = PERIOD_ACCELERATIONS(J, I) + &
                              (INTERNAL_STRESS(J, K) + EXTERNAL_STRESS(J, K)) * &
                                                          CELL_SURFACES(K, I)
                   END DO
                   PERIOD_ACCELERATIONS(J, I) = PERIOD_ACCELERATIONS(J, I) &
                                              / ALPHAS(I)
                END DO
             END DO

             RETURN
         END SUBROUTINE ACCELERATION_OF_PERIODS


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

module slf_findzer

    use iso_fortran_env, only: r64 => real64
    implicit none

    interface findzer
        module procedure findzer_single, findzer_array
    end interface

    integer, parameter :: findzer_iter = 64
    private :: ramp

contains

    subroutine findzer_single(x, xlo, xhi, delx, f)

        real(r64), intent(inout) :: x
        real(r64), intent(in) :: xlo,xhi,delx

        interface
            pure subroutine f(x,y,dy)
                import r64
                real(r64), intent(in) :: x
                real(r64), intent(out) :: y
                real(r64), intent(out), optional :: dy
            end subroutine
        end interface

        integer :: i
        real(r64) :: dx,yx,y,x1

        main_loop : do i = 1,FINDZER_ITER

            call f(x,y,yx)
            if (yx /= 0) then
                dx = - y / yx
            elseif ( dx == 0 ) then
                exit main_loop
            end if

            x1 = x + dx * ramp(i,findzer_iter)
            if ( x1 > xhi ) x1 = (x + xhi) / 2
            if ( x1 < xlo ) x1 = (x + xlo) / 2
            x = x1

            if (abs(dx) < abs(delx)) exit main_loop

        end do main_loop

    end subroutine

    subroutine findzer_array(x, nx, xlo, xhi, delx, f)

        integer, intent(in) :: nx
        real(r64), intent(inout), dimension(nx) :: x
        real(r64), intent(in), dimension(nx)  :: xlo,xhi
        real(r64), intent(in)  :: delx

        interface
            pure subroutine f(x,y,dy)
                import r64
                real(r64), intent(in), dimension(:)  :: x
                real(r64), intent(out), dimension(size(x))  :: y
                real(r64), intent(out), dimension(size(x)) , optional :: dy
            end subroutine
        end interface

        integer :: i
        real(r64), dimension(nx) :: dx,yx,y,x1
        logical, dimension(nx) :: converged

        converged = .false.
        dx = 0

        main_loop : do i = 1,FINDZER_ITER

            call f(x,y,yx)

            where ( .not. converged )

                where ( yx /= 0 )
                    dx = - y / yx
                elsewhere ( dx == 0 )
                    converged = .true.
                end where

                x1 = x + dx * ramp(i,findzer_iter)
                where ( x1 > xhi ) x1 = (x + xhi) / 2
                where ( x1 < xlo ) x1 = (x + xlo) / 2
                x = x1

                converged = abs(dx) < abs(delx)
            end where

            if (all(converged)) exit main_loop

        end do main_loop

    end subroutine

    elemental function ramp(i,n) result(y)
      integer, intent(in) :: i,n
      real(r64) :: t,y
      t = merge(real(i) / n, 1.0, i .lt. n)
      y = (3 - 2*t) * t**2
    end function

end module

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

module slf_findzermulti

    use ieee_arithmetic
    use iso_fortran_env, only: r64 => real64
    implicit none

contains

    subroutine findzer_multi(x, nx, xlo, xhi, delx, nb, f)

        real(r64), intent(inout) :: x(:)
        real(r64), intent(in) :: xlo,xhi,delx
        integer, intent(in) :: nb
        integer, intent(out) :: nx

        interface
            pure subroutine f(x,y,dy)
                import r64
                real(r64), intent(in) :: x
                real(r64), intent(out) :: y
                real(r64), intent(out), optional :: dy
            end subroutine
        end interface

        real(r64) :: y(nb), dy(nb), x0(nb)
        integer :: i

        do concurrent (i=1:nb)
            x0(i) = (i-1)/(nb-1.) * (xhi - xlo) + xlo
        end do

        call f(x0(1),y(1))
        nx = 0
        scan_for_solutions: do i = 2, nb
            call f(x0(i),y(i))
            if ( y(i-1) * y(i) < 0 ) then
                call linsect(x(nx+1), x0(i-1), x0(i), delx)
                nx = nx + 1
            end if
            if ( nx >= size(x) ) exit scan_for_solutions
        end do scan_for_solutions

    contains

        subroutine linsect(x,xlo0,xhi0,delx)
            real(r64), intent(in) :: xhi0,xlo0,delx
            real(r64), intent(out) :: x
            real(r64) :: xhi,xlo,yhi,ylo,y,s
            integer :: i,n

            n = log(abs((xhi0-xlo0)/delx))/log(2.0)

            xlo = xlo0
            xhi = xhi0

            sect_loop: do i = 1, n
                call f(xlo,ylo)
                call f(xhi,yhi)
                s = sign(real(1,kind=r64),yhi-ylo)

                x = ( yhi * xlo - ylo * xhi ) / ( yhi - ylo )
                call f(x,y)

                if ( y * s > 0 ) then
                    xhi = x
                elseif ( y * s < 0 ) then
                    xlo = x
                else
                    exit sect_loop
                end if

                if ( abs(xhi-xlo) < abs(delx) ) exit sect_loop
            end do sect_loop

        end subroutine

    end subroutine

end module

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

module slf_bisect

    use iso_fortran_env, only: r64 => real64
    implicit none

contains

    subroutine bisect(f,x,xlo0,xhi0,delx)
        real(r64), intent(in) :: xhi0,xlo0,delx
        real(r64), intent(out) :: x
        real(r64) :: xhi,xlo,yhi,ylo,y,s
        integer :: i,n

        interface
            pure subroutine f(x,y)
                import r64
                real(r64), intent(in) :: x
                real(r64), intent(out) :: y
            end subroutine
        end interface

        n = log(abs((xhi0-xlo0)/delx))/log(2.0)

        xlo = xlo0
        xhi = xhi0
        call f(xlo,ylo)
        call f(xhi,yhi)
        s = sign(real(1,r64),yhi-ylo)

        sect_loop: do i = 1, n

            x = ( xhi + xlo ) / 2
            call f(x,y)

            if ( y * s > 0 ) then
                xhi = x
            elseif ( y * s < 0 ) then
                xlo = x
            else
                exit sect_loop
            end if

            if ( abs(xhi-xlo) < abs(delx) ) exit sect_loop
        end do sect_loop

    end subroutine

end module

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

module slf_linsect

    use iso_fortran_env, only: r64 => real64
    implicit none

contains

    subroutine linsect(f,x,xlo0,xhi0,delx)
        real(r64), intent(in) :: xhi0,xlo0,delx
        real(r64), intent(out) :: x
        real(r64) :: xhi,xlo,yhi,ylo,y,s
        integer :: i,n

        interface
            pure subroutine f(x,y)
                import r64
                real(r64), intent(in) :: x
                real(r64), intent(out) :: y
            end subroutine
        end interface

        n = log(abs((xhi0-xlo0)/delx))/log(2.0)

        xlo = xlo0
        xhi = xhi0

        sect_loop: do i = 1, n
            call f(xlo,ylo)
            call f(xhi,yhi)
            s = sign(real(1,r64),yhi-ylo)

            x = ( yhi * xlo - ylo * xhi ) / ( yhi - ylo )
            call f(x,y)

            if ( y * s > 0 ) then
                xhi = x
            elseif ( y * s < 0 ) then
                xlo = x
            else
                exit sect_loop
            end if

            if ( abs(xhi-xlo) < abs(delx) ) exit sect_loop
        end do sect_loop

    end subroutine

end module

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


      subroutine mkspl2zb(fun,x,nx,th,nth,fspl,nf2,
     >   ibcxmin,bcxmin,ibcxmax,bcxmax,
     >   wk,inwk,ilinx,ilinth,ier)
C
C  create a bicubic periodic spline with knots at grid points and
C  function values from the callable function `fun' passed.
C
C  use bpsplinb to setup the spline coefficients
C
C  periodic boundary condition for theta grid;
C  boundary condition data may be specified at x(1) and x(nx)
C     ibcxmin=0 ==> "not a knot" boundary condition, cf cubspl.for
C     ibcxmin=1 ==> match slope, bcxmin(ith) gives df/dx at x(1),th(ith).
C     ibcxmin=2 ==> match 2nd derivative, given at x(1),th(ith) by bcxmin(ith)
C
C     ibcxmax,bcxmax have analogous interpretation -- at x(nx)
C
      external fun                      ! passed real function(x,th)
      real x(nx)                        ! x coordinate array
      real th(nth)                      ! th coordinate array
C
      real fspl(4,nf2,nth)              ! function data / spline coeff array
      real wk(inwk)                     ! workspace for bpsplinb
C
      integer ibcxmin                   ! boundary condition indicator
      real bcxmin(nth)                  ! boundary condition data
      integer ibcxmax                   ! boundary condition indicator
      real bcxmax(nth)                  ! boundary condition data
C
      integer ilinx                     ! output =1 if x(...) evenly spaced
      integer ilinth                    ! output =1 if th(...) evenly spaced
C
      integer ier                       ! completion code from bpspline
C
C----------------------------
C
      ier=0
      if(nf2.lt.nx) then
         write(6,'('' ?mkspl2pb -- array dim error, nf2.lt.nx'')')
         ier=1
      endif
C
      do ix=1,nx
         do ith=1,nth
            fspl(1,ix,ith)=fun(x(ix),th(ith))
         enddo
      enddo
C
      call mkbicubw(x,nx,th,nth,fspl,nf2,
     >   ibcxmin,bcxmin,ibcxmax,bcxmax,
     >   -1,zdummy,-1,zdummy,
     >   wk,inwk,ilinx,ilinth,ier)
C
      return
      end


! DART software - Copyright UCAR. This open source software is provided
! by UCAR, "as is", without charge, subject to all terms of use at
! http://www.image.ucar.edu/DAReS/DART/DART_download
!
! $Id$

program correl_error

use      types_mod, only : r8
use random_seq_mod, only : random_seq_type, init_random_seq, twod_gaussians

implicit none

! version controlled file description for error handling, do not edit
character(len=256), parameter :: source   = &
   "$URL$"
character(len=32 ), parameter :: revision = "$Revision$"
character(len=128), parameter :: revdate  = "$Date$"

!!!integer, parameter :: sample_size = 1000000
integer, parameter :: sample_size = 100000
type (random_seq_type) :: ran_id
real(r8) :: zero_2(2) = 0.0, cov(2, 2)
real(r8) :: t_correl, correl_mean, sample_correl, ratio_mean, correl_mean2, correl_sd
real(r8) :: ratio_mean2, ratio_sd
real(r8), allocatable :: pairs(:, :), obs_inc(:), unobs_inc(:), new_unobs(:)
real(r8) :: s_mean(2), s_var(2), new_mean, new_var, a, expected_ratio
integer i, j, k, lji, ens_size

call init_random_seq(ran_id)

! Loop through a range of ensemble sizes
do lji = 4, 48, 4
   ens_size = lji
   if(lji > 32) ens_size = 32 + (lji - 32) * 4
   if(lji > 40) ens_size = 64 + (lji - 40) * 8
   !!!ens_size = 2**lji

   !!!ens_size = 20
   !!!ens_size = 128

   allocate(pairs(2, ens_size), obs_inc(ens_size), unobs_inc(ens_size), new_unobs(ens_size))
   write(*, *) 'stats for ensemble size ', ens_size
   ! Loop through real correlations every 0.05
   !!!do j = 0, 50
   do j = 0, 0
      ! Loop through a large number of samples to get mean
      correl_mean  = 0.0_r8
      correl_mean2 = 0.0_r8
      ratio_mean   = 0.0_r8
      ratio_mean2  = 0.0_r8
      do k = 1, sample_size
         t_correl = j * 0.02_r8

         ! Generate the covariance matrix for this correlation
         cov(1, 1) = 1.0;    cov(2, 2) = 1.0_r8
         cov(1, 2) = t_correl; cov(2, 1) = t_correl

         ! Loop to generate an ensemble size sample from this correl
         ! Generate a random sample of size ens_size from something with this correlation
         do i = 1, ens_size
            call twod_gaussians(ran_id, zero_2, cov, pairs(:, i))
         enddo

         ! Compute the sample correlation
         call comp_correl(pairs, ens_size, sample_correl)

         ! Keep a sum of the sample_correl
         correl_mean = correl_mean + abs(sample_correl)
         correl_mean2 = correl_mean2 + sample_correl**2

         !-----------------
         ! Also interested in finding out what the spurious variance reduction factor is
         ! First need to compute sample s.d. for the obs and unobs variable
         do i = 1, 2
            call sample_mean_var(pairs(i, :), ens_size, s_mean(i), s_var(i))
         enddo
         ! Next, compute the increments for obs variable given reduction in s.d. by a
         a = 0.0_r8
         do i = 1, ens_size
            obs_inc(i) = (a - 1.0_r8) * (pairs(1, i) - s_mean(1))
         enddo

         ! Regress these onto the unobserved variable
         do i = 1, ens_size
            unobs_inc(i) = sample_correl * sqrt(s_var(2) / s_var(1)) * obs_inc(i)
            new_unobs(i) = pairs(2, i) + unobs_inc(i)
         enddo

         ! Now compute the updated variance
         call sample_mean_var(new_unobs, ens_size, new_mean, new_var)

         !write(*, *) 'old and new var ', s_var(2), new_var
         !write(*, *) 'old and new sd ', sqrt(s_var(2)), sqrt(new_var)
         !write(*, *) 'unobs sd ratio ', sqrt(new_var) / sqrt(s_var(2))
         ratio_mean  = ratio_mean  +  sqrt(new_var) / sqrt(s_var(2))
         ratio_mean2 = ratio_mean2 + (sqrt(new_var) / sqrt(s_var(2)))**2

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

      enddo
      correl_mean = correl_mean / sample_size
      correl_sd = sqrt((correl_mean2 - sample_size * correl_mean**2) / (sample_size - 1))
      write(*, *) t_correl, correl_mean, correl_sd
      ratio_mean = ratio_mean / sample_size
      ratio_sd = sqrt((ratio_mean2 - sample_size * ratio_mean**2) / (sample_size - 1))
      write(*, *) 'ratio mean ', ratio_mean, (1 - ratio_mean) / (1.0 - a)
      expected_ratio = 1.0 - ((1.0 - a) * t_correl)
      write(44, 11) ens_size, t_correl, ratio_mean, ratio_sd, correl_mean, correl_sd
      11 format(i8, 6(1x, f10.5))
   enddo
   deallocate(pairs, obs_inc, unobs_inc, new_unobs)
enddo

contains

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

subroutine comp_correl(ens, n, correl)

implicit none

integer, intent(in) :: n
real(r8), intent(in) :: ens(2, n)
real(r8), intent(out) :: correl
real(r8) :: sum_x, sum_y, sum_xy, sum_x2, sum_y2

sum_x = sum(ens(2, :))
sum_y = sum(ens(1, :))
sum_xy = sum(ens(2, :) * ens(1, :))
sum_x2 = sum(ens(2, :) * ens(2, :))

! Computation of correlation
sum_y2 = sum(ens(1, :) * ens(1, :))

correl = (n * sum_xy - sum_x * sum_y) / &
   sqrt((n * sum_x2 - sum_x**2) * (n * sum_y2 - sum_y**2))

end subroutine comp_correl

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

subroutine sample_mean_var(x, n, mean, var)

implicit none

integer, intent(in) :: n
real(r8), intent(in) :: x(:)
real(r8), intent(out) :: mean, var

real(r8) :: sx, s_x2

sx = sum(x)
s_x2 = sum(x * x)
mean = sx / n
var = (s_x2 - sx**2 / n) / (n - 1)

end subroutine sample_mean_var

end program correl_error


!-----------------------------------------------------------------------
!
! Header with QFunctions
!
      include 't535-operator-f.h'
!-----------------------------------------------------------------------
      program test
      implicit none
      include 'ceed/fortran.h'

      integer ceed,err,i,j,k
      integer stridesu(3),stridesqd(3)
      integer erestrictx,erestrictu,erestrictui,erestrictqi
      integer bx,bu
      integer qf_setup_mass,qf_setup_diff,qf_apply
      integer op_setup_mass,op_setup_diff,op_apply
      integer qdata_mass,qdata_diff,x,a,u,v
      integer nelem,p,q,d
      integer row,col,offset
      parameter(nelem=6)
      parameter(p=3)
      parameter(q=4)
      parameter(d=2)
      integer ndofs,nqpts,nx,ny
      parameter(nx=3)
      parameter(ny=2)
      parameter(ndofs=(nx*2+1)*(ny*2+1))
      parameter(nqpts=nelem*q*q)
      integer indx(nelem*p*p)
      real*8 arrx(d*ndofs),aa(nqpts),uu(ndofs),vv(ndofs),atrue(ndofs)
      integer*8 xoffset,aoffset,uoffset,voffset

      character arg*32

      external setup_mass,setup_diff,apply,apply_lin

      call getarg(1,arg)

      call ceedinit(trim(arg)//char(0),ceed,err)

! DoF Coordinates
      do i=0,nx*2
        do j=0,ny*2
          arrx(i+j*(nx*2+1)+0*ndofs+1)=1.d0*i/(2*nx)
          arrx(i+j*(nx*2+1)+1*ndofs+1)=1.d0*j/(2*ny)
        enddo
      enddo
      call ceedvectorcreate(ceed,d*ndofs,x,err)
      xoffset=0
      call ceedvectorsetarray(x,ceed_mem_host,ceed_use_pointer,arrx,xoffset,err)

! Qdata Vector
      call ceedvectorcreate(ceed,nqpts,qdata_mass,err)
      call ceedvectorcreate(ceed,nqpts*d*(d+1)/2,qdata_diff,err)

! Element Setup
      do i=0,nelem-1
        col=mod(i,nx)
        row=i/nx
        offset=col*(p-1)+row*(nx*2+1)*(p-1)
        do j=0,p-1
          do k=0,p-1
            indx(p*(p*i+k)+j+1)=offset+k*(nx*2+1)+j
          enddo
        enddo
      enddo

! Restrictions
      call ceedelemrestrictioncreate(ceed,nelem,p*p,d,ndofs,d*ndofs,&
     & ceed_mem_host,ceed_use_pointer,indx,erestrictx,err)

      call ceedelemrestrictioncreate(ceed,nelem,p*p,1,1,ndofs,&
     & ceed_mem_host,ceed_use_pointer,indx,erestrictu,err)
      stridesu=[1,q*q,q*q]
      call ceedelemrestrictioncreatestrided(ceed,nelem,q*q,1,nqpts,&
     & stridesu,erestrictui,err)

      stridesqd=[1,q*q,q*q*d*(d+1)/2]
      call ceedelemrestrictioncreatestrided(ceed,nelem,q*q,d*(d+1)/2,&
     & d*(d+1)/2*nqpts,stridesqd,erestrictqi,err)

! Bases
      call ceedbasiscreatetensorh1lagrange(ceed,d,d,p,q,ceed_gauss,bx,err)
      call ceedbasiscreatetensorh1lagrange(ceed,d,1,p,q,ceed_gauss,bu,err)

! QFunction - setup mass
      call ceedqfunctioncreateinterior(ceed,1,setup_mass,&
     &SOURCE_DIR&
     &//'t532-operator.h:setup_mass'//char(0),qf_setup_mass,err)
      call ceedqfunctionaddinput(qf_setup_mass,'dx',d*d,ceed_eval_grad,err)
      call ceedqfunctionaddinput(qf_setup_mass,'_weight',1,ceed_eval_weight,err)
      call ceedqfunctionaddoutput(qf_setup_mass,'qdata',1,ceed_eval_none,err)

! Operator - setup mass
      call ceedoperatorcreate(ceed,qf_setup_mass,ceed_qfunction_none,&
     & ceed_qfunction_none,op_setup_mass,err)
      call ceedoperatorsetfield(op_setup_mass,'dx',erestrictx,&
     & bx,ceed_vector_active,err)
      call ceedoperatorsetfield(op_setup_mass,'_weight',&
     & ceed_elemrestriction_none,bx,ceed_vector_none,err)
      call ceedoperatorsetfield(op_setup_mass,'qdata',erestrictui,&
     & ceed_basis_collocated,ceed_vector_active,err)

! QFunction - setup diff
      call ceedqfunctioncreateinterior(ceed,1,setup_diff,&
     &SOURCE_DIR&
     &//'t532-operator.h:setup_diff'//char(0),qf_setup_diff,err)
      call ceedqfunctionaddinput(qf_setup_diff,'dx',d*d,ceed_eval_grad,err)
      call ceedqfunctionaddinput(qf_setup_diff,'_weight',1,ceed_eval_weight,err)
      call ceedqfunctionaddoutput(qf_setup_diff,'qdata',&
     & d*(d+1)/2,ceed_eval_none,err)

! Operator - setup diff
      call ceedoperatorcreate(ceed,qf_setup_diff,ceed_qfunction_none,&
     & ceed_qfunction_none,op_setup_diff,err)
      call ceedoperatorsetfield(op_setup_diff,'dx',erestrictx,&
     & bx,ceed_vector_active,err)
      call ceedoperatorsetfield(op_setup_diff,'_weight',&
     & ceed_elemrestriction_none,bx,ceed_vector_none,err)
      call ceedoperatorsetfield(op_setup_diff,'qdata',erestrictqi,&
     & ceed_basis_collocated,ceed_vector_active,err)

! Apply Setup Operators
      call ceedoperatorapply(op_setup_mass,x,qdata_mass,&
     & ceed_request_immediate,err)
      call ceedoperatorapply(op_setup_diff,x,qdata_diff,&
     & ceed_request_immediate,err)

! QFunction - apply
      call ceedqfunctioncreateinterior(ceed,1,apply,&
     &SOURCE_DIR&
     &//'t532-operator.h:apply'//char(0),qf_apply,err)
      call ceedqfunctionaddinput(qf_apply,'du',d,ceed_eval_grad,err)
      call ceedqfunctionaddinput(qf_apply,'qdata_mass',1,ceed_eval_none,err)
      call ceedqfunctionaddinput(qf_apply,'qdata_diff',&
     & d*(d+1)/2,ceed_eval_none,err)
      call ceedqfunctionaddinput(qf_apply,'u',1,ceed_eval_interp,err)
      call ceedqfunctionaddoutput(qf_apply,'v',1,ceed_eval_interp,err)
      call ceedqfunctionaddoutput(qf_apply,'dv',d,ceed_eval_grad,err)

! Operator - apply
      call ceedoperatorcreate(ceed,qf_apply,ceed_qfunction_none,&
     & ceed_qfunction_none,op_apply,err)
      call ceedoperatorsetfield(op_apply,'du',erestrictu,&
     & bu,ceed_vector_active,err)
      call ceedoperatorsetfield(op_apply,'qdata_mass',erestrictui,&
     & ceed_basis_collocated,qdata_mass,err)
      call ceedoperatorsetfield(op_apply,'qdata_diff',erestrictqi,&
     & ceed_basis_collocated,qdata_diff,err)
      call ceedoperatorsetfield(op_apply,'u',erestrictu,&
     & bu,ceed_vector_active,err)
      call ceedoperatorsetfield(op_apply,'v',erestrictu,&
     & bu,ceed_vector_active,err)
      call ceedoperatorsetfield(op_apply,'dv',erestrictu,&
     & bu,ceed_vector_active,err)

! Assemble Diagonal
      call ceedvectorcreate(ceed,ndofs,a,err)
      call ceedoperatorlinearassemblediagonal(op_apply,a,&
     & ceed_request_immediate,err)

! Manually assemble diagonal
      call ceedvectorcreate(ceed,ndofs,u,err)
      call ceedvectorsetvalue(u,0.d0,err)
      call ceedvectorcreate(ceed,ndofs,v,err)
      do i=1,ndofs
        call ceedvectorgetarray(u,ceed_mem_host,uu,uoffset,err)
        uu(i+uoffset)=1.d0
        if (i>1) then
          uu(i-1+uoffset)=0.d0
        endif
        call ceedvectorrestorearray(u,uu,uoffset,err)

        call ceedoperatorapply(op_apply,u,v,ceed_request_immediate,err)

        call ceedvectorgetarrayread(v,ceed_mem_host,vv,voffset,err)
        atrue(i)=vv(voffset+i)
        call ceedvectorrestorearrayread(v,vv,voffset,err)
      enddo

! Check Output
      call ceedvectorgetarrayread(a,ceed_mem_host,aa,aoffset,err)
      do i=1,ndofs
        if (abs(aa(aoffset+i)-atrue(i))>1.0d-14) then
! LCOV_EXCL_START
          write(*,*) '[',i,'] Error in assembly: ',aa(aoffset+i),' != ',&
     &      atrue(i)
! LCOV_EXCL_STOP
        endif
      enddo
      call ceedvectorrestorearrayread(a,aa,aoffset,err)

! Cleanup
      call ceedqfunctiondestroy(qf_setup_mass,err)
      call ceedqfunctiondestroy(qf_setup_diff,err)
      call ceedqfunctiondestroy(qf_apply,err)
      call ceedoperatordestroy(op_setup_mass,err)
      call ceedoperatordestroy(op_setup_diff,err)
      call ceedoperatordestroy(op_apply,err)
      call ceedelemrestrictiondestroy(erestrictu,err)
      call ceedelemrestrictiondestroy(erestrictx,err)
      call ceedelemrestrictiondestroy(erestrictui,err)
      call ceedelemrestrictiondestroy(erestrictqi,err)
      call ceedbasisdestroy(bu,err)
      call ceedbasisdestroy(bx,err)
      call ceedvectordestroy(x,err)
      call ceedvectordestroy(a,err)
      call ceedvectordestroy(u,err)
      call ceedvectordestroy(v,err)
      call ceedvectordestroy(qdata_mass,err)
      call ceedvectordestroy(qdata_diff,err)
      call ceeddestroy(ceed,err)
      end
!-----------------------------------------------------------------------


program imodel
  !--------------------------------------------------
  !  Icosahedral Model Main Program - Driver
  !
  !   Pedro Peixoto Sept 2015
  !--------------------------------------------------

  !Global constants
  use constants, only: &
       simulcase

  !Data structures
  use datastruct, only: &
       grid_structure

  !Main mesh build and structuring module
  use smeshpack, only: &
       getparameters, &
       meshbuild, &
       printending, &
       printheader

  !Test routines
  use simulpack, only: &
       divergence_test, &
       laplacian_test, &
       rotational_test, &
       meshquality, &
       test_geo2reg, &
       scalar_interpolation_test, &
       test_trsearch, &
       vector_interpolation_test, &
       vector_reconstruction_test, &
       vec_tg_reconstruction_test

  !Transport testing module
  use transport, only: &
       passive_advection, &
       transptests

  !Data structure for multigrid routines
  use datastructmult

  !Multigrid solver routines
  use multigrid

  use swm, only: &
    swm_tests, &
    swm_horiz_loc_trunc_er, &
    swm_normal_mode_analysis

  !Variable declaration
  implicit none

  type(grid_structure) :: mesh
  type(multimesh) :: meshvet

  !Print a header on screen
  call printheader()

  !Create/Load mesh

   !Read mesh user defined parameters and simulation case
   call getparameters(mesh)

  if(simulcase /= 11)then
	  !Call mesh generation and structuring algorithm
    call meshbuild(mesh)
  end if

  !Do a simulation/test with the mesh loaded
  select case(simulcase)
  case(1) !Test geodesic to regular grid conversion tool
     call test_geo2reg(mesh)
  case(2) !Test Search methods
     call test_trsearch(mesh)
  case(3) !Mesh distortion tests
     call meshquality(mesh)
  case(4) !Divergence Tests
     call divergence_test(mesh)
  case(5) !Divergence Tests
     call laplacian_test(mesh)
  case(6)   !Test scalar interpolations
     call scalar_interpolation_test(mesh)
  case(7) !Test vector interpolation
     call vector_interpolation_test(mesh)
  case(8) !Test vector reconstruction
     call vector_reconstruction_test(mesh)
  case(9) !Passive advection simulation
     call passive_advection(mesh)
  case(10) !Transport deformational flow simulation
     call transptests(mesh)
  case(11) !Multigrid tests

    !Generate multigrid meshes
    call mesh_generation(meshvet)

    !Test laplacian
    call laplacian(meshvet)

     !call getparameters_mult()

    !Test relaxation solver
    call relaxac(meshvet)

    !Set mesh relations
    call relation_meshes(meshvet)

    !Test interpolation
    call interpol_linear(meshvet)

    !Test multigrid
    call multigrid_solver(meshvet)

  case(12)!Tg reconstruction test
    call vec_tg_reconstruction_test(mesh)

  case(13) !Curl/rotational discretization tests
    call rotational_test(mesh)

  case(14) !Horizontal Distc Shallow water model disgnostics
    call swm_horiz_loc_trunc_er(mesh)

  case(15) !Shallow water model test cases
    call swm_tests(mesh)

  case default
     print*, "Please select a proper simulation case ...:", simulcase
  end select
  !Print finishing line
  call printending()

end program imodel


Subroutine xnormv(vx, vy, vz)
  Implicit Double Precision (A-H, O-Z)
  Save
  vv = dsqrt(vx**2+vy**2+vz**2)
  vx = vx/vv
  vy = vy/vv
  vz = vz/vv
  Return
End Subroutine xnormv


program test_sddk
use sddk
use mpi
implicit none
integer :: fft_grid_id, gvec_id, fft_id, ierr, num_ranks, rank
integer :: num_gvec_loc, gvec_offset
real(8) :: vk(3)
real(8) :: recip_lat(3, 3)
real(8) :: gmax

call mpi_init(ierr)
call mpi_comm_size(MPI_COMM_WORLD, num_ranks, ierr)
call mpi_comm_rank(MPI_COMM_WORLD, rank, ierr)

call sddk_create_fft_grid((/100, 100, 100/), fft_grid_id)

recip_lat = 0
recip_lat(1, 1) = 1
recip_lat(2, 2) = 1
recip_lat(3, 3) = 1

gmax = 6.0

call sddk_create_gvec((/0.d0, 0.d0, 0.d0/), recip_lat(:, 1), recip_lat(:, 2), recip_lat(:, 3), gmax,&
                      &fft_grid_id, num_ranks, 0, MPI_COMM_WORLD, gvec_id)

call sddk_get_gvec_count(gvec_id, rank, num_gvec_loc)
call sddk_get_gvec_offset(gvec_id, rank, gvec_offset)
write(*,*)"local number of G-vectors and offset: ", num_gvec_loc, gvec_offset

call sddk_create_fft(fft_grid_id, MPI_COMM_WORLD, fft_id)

write(*,*)fft_grid_id, gvec_id, fft_id

call sddk_delete_fft(fft_id)
call sddk_delete_gvec(gvec_id)
call sddk_delete_fft_grid(fft_grid_id)

call sddk_create_fft_grid((/50, 50, 50/), fft_grid_id)
call sddk_create_gvec((/0.d0, 0.d0, 0.d0/), recip_lat(:, 1), recip_lat(:, 2), recip_lat(:, 3), gmax,&
                      &fft_grid_id, num_ranks, 0, MPI_COMM_WORLD, gvec_id)

write(*,*)fft_grid_id, gvec_id

call sddk_delete_gvec(gvec_id)
call sddk_delete_fft_grid(fft_grid_id)

call mpi_finalize(ierr)

end program


! $UWHPSC/codes/openmp/reductions1.f90

program reductions1

   use omp_lib
   implicit none
   integer :: n
   integer :: i, nthreads
   real(kind=8), dimension(100) :: x
   real(kind=8) :: y
   logical :: anyzero

   ! Specify number of threads to use:
   nthreads = 2
   !$ call omp_set_num_threads(nthreads)
   !$ print "('Using OpenMP with ',i3,' threads')", nthreads

   n = 7
   do i=1,n
      x(i) = float(i-3)
      enddo

   y = -1.d300  ! very negative value
   !$omp parallel do reduction(max: y)
   do i=1,n
      y = max(y,x(i))
   enddo
   !$omp end parallel do
   print *, 'max of x = ',y

   anyzero = .false.
   !$omp parallel do reduction(.or.: anyzero)
   do i=1,n
      anyzero = anyzero .or. (x(i) == 0.d0)
      enddo
   print *, 'anyzero = ',anyzero

end program reductions1


module givens

  use nrtype_m

  implicit none

  private

  public :: left_multiply, right_multiply, rotate

contains

subroutine left_multiply(a, i, j, c, s)
  complex(DPC), intent(inout) :: a(:, :, :)
  integer, intent(in) :: i
  integer, intent(in) :: j
  real(DP), intent(in) :: c
  complex(DPC), intent(in) :: s
  integer :: nmat
  integer :: nelem
  integer :: k

  nmat = size(a, dim=1)
  nelem = size(a, dim=2)

  do k=1,nelem
    call zrot(nmat, a(:, i, k), 1, a(:, j, k), 1, c, -s)
  enddo

end subroutine left_multiply

subroutine right_multiply(a, i, j, c, s)
  complex(DPC), intent(inout) :: a(:, :, :)
  integer, intent(in) :: i
  integer, intent(in) :: j
  real(DP), intent(in) :: c
  complex(DPC), intent(in) :: s
  integer :: nmat
  integer :: nelem
  integer :: k

  nmat = size(a, dim=1)
  nelem = size(a, dim=2)

  do k=1,nelem
    call zrot(nmat, a(:, k, j), 1, a(:, k, i), 1, c, s)
  enddo

end subroutine right_multiply

subroutine rotate(a, i, j, c, s)
  complex(DPC), intent(inout) :: a(:, :, :)
  integer, intent(in) :: i
  integer, intent(in) :: j
  real(DP), intent(in) :: c
  complex(DPC), intent(in) :: s
  integer :: nmat
  integer :: nelem
  integer :: k

  nmat = size(a, dim=1)
  nelem = size(a, dim=2)

  do k=1,nelem
    call zrot(nmat, a(:, i, k), 1, a(:, j, k), 1, c, -s)
  enddo
  do k=1,nelem
    call zrot(nmat, a(:, k, j), 1, a(:, k, i), 1, c, s)
  enddo

end subroutine rotate

end module


! **************************************************************************
! ... etools.f90
! ... Quim Ballabrera, February 2013
! ...
! ... System Dynamics:
! ... ETOOLS
! ... Ensemble tools
! ...
! **************************************************************************

subroutine emean (X,m,n,xm)

implicit none

integer, intent(in)                       :: m,n
real(kind=8), dimension(m,n), intent(in)  :: X
real(kind=8), dimension(m), intent(out)   :: xm

integer i
real(kind=8) In

In = 1.0D0/DBLE(n)
do i=1,m
  xm(i) = SUM(X(i,:))*In
enddo

return
end subroutine emean
! ...
! ========================================================================
! ...
subroutine Hforward (x,n,iobs,p,y)

use sysdyn

! ...
! ... This version of Hforward works with the iobs(1:n) vector
! ... of 1 (observed component) and 0 (non-observed component).
! ... p = SUM(iobs) is the number of observations.
! ...

integer, intent(in)                     :: n,p
integer, dimension(p), intent(in)       :: iobs
real(kind=8), dimension(n), intent(in)  :: x
real(kind=8), dimension(p), intent(out) :: y

! ... Local variables:
! ...
integer i,ii

ii = 0
do i=1,n
  if (Iobs(i).gt.0) then
    ii = ii + 1
    y(ii) = x(i)
  endif
enddo
if (ii.NE.p) call stop_error (1,'Incompatible number of observations')

end subroutine Hforward


! PR15620
! Check that evaluating a statement function doesn't affect the value of
! its dummy argument variables.
program st_function_2
  integer fn, a, b
  fn(a, b) = a + b
  if (foo(1) .ne. 43) call abort

  ! Check that values aren't modified when avaluating the arguments.
  a = 1
  b = 5
  if (fn (b + 2, a + 3) .ne. 11) call abort
contains
function foo (x)
  integer z, y, foo, x
  bar(z) = z*z
  z = 42
  t = bar(x)
  foo = t + z
end function
end program


!** Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
!** See https://llvm.org/LICENSE.txt for license information.
!** SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
!
! Tests scalar mask for maxval intrinsic.

	program p
	integer a(10,10)
	logical(8) msk(10,10)
	integer afalse(10), sfalse(10)
        integer atrue(10), strue(10)
        logical(8) rslt(2)
        logical(8) expect(2)
        data expect /.true.,.true./

        do j=1,10
	do i=1,10
	a(i,j) = i*2
	enddo
	enddo

	msk = .false.

!	do i=1,5
!	msk(i,1) = .true.
!	enddo

	sfalse = maxval(a,dim=1,mask=.false.)
	afalse = maxval(a,dim=1,mask=msk)
	strue = maxval(a,dim=1,mask=.true.)
        msk = .true.
        atrue = maxval(a,dim=1,mask=msk)
        rslt(1) = all(sfalse .eq. afalse)
        rslt(2) = all(atrue .eq. strue)
        call check(rslt,expect,2)
	end