subroutine a_log ( rule, a )

!*****************************************************************************80
!
!! A_LOG returns the value of A for an Alpert rule for log singular functions.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    01 December 2015
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) RULE, the index of the rule, between 1 and 10.
!
!    Output, integer ( kind = 4 ) A, the value of A.
!
  implicit none

  integer ( kind = 4 ) a
  integer ( kind = 4 ), dimension ( 10 ) :: a_vec = (/ &
    1, 2, 2, 3, 3, &
    5, 6, 7, 9, 10 /)
  integer ( kind = 4 ) rule

  if ( rule < 1 .or. 10 < rule ) then
    write ( *, '(a)' ) ''
    write ( *, '(a)' ) 'A_LOG - Fatal error!'
    write ( *, '(a)' ) '  Input value of RULE is not between 1 and 10.'
    stop 1
  end if

  a = a_vec(rule)

  return
end
subroutine a_power ( rule, a )

!*****************************************************************************80
!
!! A_POWER returns A for an Alpert rule for power singular functions.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    01 December 2015
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) RULE, the index of the rule, between 1 and 12.
!
!    Output, integer ( kind = 4 ) A, the value of A.
!
  implicit none

  integer ( kind = 4 ) a
  integer ( kind = 4 ), dimension ( 12 ) :: a_vec = (/ &
    1,  2,  2,  2,  2, &
    3,  4,  5,  6,  8, &
    9, 10 /)
  integer ( kind = 4 ) rule

  if ( rule < 1 .or. 12 < rule ) then
    write ( *, '(a)' ) ''
    write ( *, '(a)' ) 'A_POWER - Fatal error!'
    write ( *, '(a)' ) '  Input value of RULE is not between 1 and 12.'
    stop 1
  end if

  a = a_vec(rule)

  return
end
subroutine a_regular ( rule, a )

!*****************************************************************************80
!
!! A_REGULAR returns the value of A for an Alpert rule for regular functions.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    01 December 2015
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) RULE, the index of the rule, between 1 and 12.
!
!    Output, integer ( kind = 4 ) A, the value of A.
!
  implicit none

  integer ( kind = 4 ) a
  integer ( kind = 4 ), dimension ( 12 ) :: a_vec = (/ &
     1,  2,  2,  3,  3, &
     4,  5,  7,  9, 10, &
    12, 14 /)
  integer ( kind = 4 ) rule

  if ( rule < 1 .or. 12 < rule ) then
    write ( *, '(a)' ) ''
    write ( *, '(a)' ) 'A_REGULAR - Fatal error!'
    write ( *, '(a)' ) '  Input value of RULE is not between 1 and 12.'
    stop 1
  end if

  a = a_vec(rule)

  return
end
subroutine integral_log ( value )

!*****************************************************************************80
!
!! INTEGRAL_LOG evaluates the test integral with logarithmic singularity.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    01 December 2015
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Output, real ( kind = 8 ) VALUE, the integral of the test integrand
!    from 0 to 1.
!
!
!  1/200 (-Sin[3/10] + Sin[2003/10] - SinIntegral[200])
!
  implicit none

  real ( kind = 8 ) value

  value = -0.012771107587415899716D+00

  return
end
subroutine integral_power ( value )

!*****************************************************************************80
!
!! INTEGRAL_POWER evaluates the test integral with power singularity.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    01 December 2015
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Output, real ( kind = 8 ) VALUE, the integral of the test integrand
!    from 0 to 1.
!
!  ( 20 * sqrt ( pi ) * FresnelC(20/sqrt(pi)) - sin(3/10) + sin(2003/10))/200
!
  implicit none

  real ( kind = 8 ) value

  value = 0.079321002746971411182D+00

  return
end
subroutine integral_regular ( value )

!*****************************************************************************80
!
!! INTEGRAL_REGULAR evaluates the regular test integral.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    01 December 2015
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Output, real ( kind = 8 ) VALUE, the integral of the test integrand
!    from 0 to 1.
!
!
!  1/200 (-Sin[3/10] + Sin[200] + Sin[2003/10])
!
  implicit none

  real ( kind = 8 ) value

  value = ( - sin ( 0.3D+00 ) + sin ( 200.0D+00 ) &
    + sin ( 200.3D+00 ) ) / 200.0D+00

  return
end
subroutine integrand_log ( n, x, f )

!*****************************************************************************80
!
!! INTEGRAND_LOG evaluates the test integrand with logarithmic singularity.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    01 December 2015
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) N, the number of evaluation points.
!
!    Input, real ( kind = 8 ) X(N), the evaluation points.
!
!    Output, real ( kind = 8 ) F(N), the integrand at the evaluation points.
!
  implicit none

  integer ( kind = 4 ) n

  real ( kind = 8 ) f(n)
  real ( kind = 8 ) x(n)

  f(1:n) = cos ( 200.0D+00 * x(1:n) ) * log ( x(1:n) ) &
    + cos ( 200.0D+00 * x(1:n) + 0.3D+00 )

  return
end
subroutine integrand_power ( n, x, f )

!*****************************************************************************80
!
!! INTEGRAND_POWER evaluates the test integrand with power singularity.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    01 December 2015
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) N, the number of evaluation points.
!
!    Input, real ( kind = 8 ) X(N), the evaluation points.
!
!    Output, real ( kind = 8 ) F(N), the integrand at the evaluation points.
!
  implicit none

  integer ( kind = 4 ) n

  real ( kind = 8 ) f(n)
  real ( kind = 8 ) x(n)

  f(1:n) = cos ( 200.0D+00 * x(1:n) ) * x(1:n) ** ( - 0.5D+00 ) &
    + cos ( 200.0D+00 * x(1:n) + 0.3D+00 )

  return
end
subroutine integrand_regular ( n, x, f )

!*****************************************************************************80
!
!! INTEGRAND_REGULAR evaluates the regular test integrand.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    01 December 2015
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) N, the number of evaluation points.
!
!    Input, real ( kind = 8 ) X(N), the evaluation points.
!
!    Output, real ( kind = 8 ) F(N), the integrand at the evaluation points.
!
  implicit none

  integer ( kind = 4 ) n

  real ( kind = 8 ) f(n)
  real ( kind = 8 ) x(n)

  f(1:n) = cos ( 200.0D+00 * x(1:n) ) + cos ( 200.0D+00 * x(1:n) + 0.3D+00 )

  return
end
subroutine j_log ( rule, j )

!*****************************************************************************80
!
!! J_LOG returns the value of J for an Alpert rule for log singular functions.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    01 December 2015
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) RULE, the index of the rule, between 1 and 10.
!
!    Output, integer ( kind = 4 ) J, the value of J.
!
  implicit none

  integer ( kind = 4 ) j
  integer ( kind = 4 ), dimension ( 10 ) :: j_vec = (/ &
     1,  2,  3,  4,  5, &
     7, 10, 11, 14, 15 /)
  integer ( kind = 4 ) rule

  if ( rule < 1 .or. 10 < rule ) then
    write ( *, '(a)' ) ''
    write ( *, '(a)' ) 'J_LOG - Fatal error!'
    write ( *, '(a)' ) '  Input value of RULE is not between 1 and 10.'
    stop 1
  end if

  j = j_vec(rule)

  return
end
subroutine j_power ( rule, j )

!*****************************************************************************80
!
!! J_POWER returns J for an Alpert rule for power singular functions.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    01 December 2015
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) RULE, the index of the rule, between 1 and 12.
!
!    Output, integer ( kind = 4 ) J, the value of J.
!
  implicit none

  integer ( kind = 4 ) j
  integer ( kind = 4 ), dimension ( 12 ) :: j_vec = (/ &
      1,  2,  2,  3,  3, &
      4,  6,  8, 10, 12, &
     14, 16 /)
  integer ( kind = 4 ) rule

  if ( rule < 1 .or. 12 < rule ) then
    write ( *, '(a)' ) ''
    write ( *, '(a)' ) 'J_POWER - Fatal error!'
    write ( *, '(a)' ) '  Input value of RULE is not between 1 and 12.'
    stop 1
  end if

  j = j_vec(rule)

  return
end
subroutine j_regular ( rule, j )

!*****************************************************************************80
!
!! J_REGULAR returns the value of J for an Alpert rule for regular functions.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    01 December 2015
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) RULE, the index of the rule, between 1 and 12.
!
!    Output, integer ( kind = 4 ) J, the value of J.
!
  implicit none

  integer ( kind = 4 ) j
  integer ( kind = 4 ), dimension ( 12 ) :: j_vec = (/ &
     1,  2,  2,  3,  3, &
     4,  6,  8, 10, 12, &
    14, 16 /)
  integer ( kind = 4 ) rule

  if ( rule < 1 .or. 12 < rule ) then
    write ( *, '(a)' ) ''
    write ( *, '(a)' ) 'J_REGULAR - Fatal error!'
    write ( *, '(a)' ) '  Input value of RULE is not between 1 and 12.'
    stop 1
  end if

  j = j_vec(rule)

  return
end
subroutine num_log ( num )

!*****************************************************************************80
!
!! NUM_LOG returns the number of Alpert rules for log singular functions.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    01 December 2015
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Output, integer ( kind = 4 ) NUM, the number of rules.
!
  implicit none

  integer ( kind = 4 ) num

  num = 10

  return
end
subroutine num_power ( num )

!*****************************************************************************80
!
!! NUM_POWER returns the number of Alpert rules for power singular functions.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    01 December 2015
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Output, integer ( kind = 4 ) NUM, the number of rules.
!
  implicit none

  integer ( kind = 4 ) num

  num = 12

  return
end
subroutine num_regular ( num )

!*****************************************************************************80
!
!! NUM_REGULAR returns the number of Alpert rules for regular functions.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    01 December 2015
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Output, integer ( kind = 4 ) NUM, the number of rules.
!
  implicit none

  integer ( kind = 4 ) num

  num = 12

  return
end
subroutine order_log ( rule, order )

!*****************************************************************************80
!
!! ORDER_LOG returns the order of an Alpert rule for log singular functions.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    01 December 2015
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) RULE, the index of the rule, between 1 and 10.
!
!    Output, integer ( kind = 4 ) ORDER, the order of the rule.
!
  implicit none

  integer ( kind = 4 ) order
  integer ( kind = 4 ), dimension ( 10 ) :: order_vec = (/ &
     2,  3,  4,  5,  6, &
     8, 10, 12, 14, 16 /)
  integer ( kind = 4 ) rule

  if ( rule < 1 .or. 10 < rule ) then
    write ( *, '(a)' ) ''
    write ( *, '(a)' ) 'ORDER_LOG - Fatal error!'
    write ( *, '(a)' ) '  Input value of RULE is not between 1 and 10.'
    stop 1
  end if

  order = order_vec(rule)

  return
end
subroutine order_power ( rule, order )

!*****************************************************************************80
!
!! ORDER_POWER returns the order of an Alpert rule for power singular functions.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    01 December 2015
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) RULE, the index of the rule, between 1 and 10.
!
!    Output, real ( kind = 8 ) ORDER, the order of the rule.
!
  implicit none

  real ( kind = 8 ) order
  real ( kind = 8 ), dimension ( 12 ) :: order_vec = (/ &
     1.5,  2.0,  2.5,  3.0,  3.5, &
     4.0,  6.0,  8.0, 10.0, 12.0, &
    14.0, 16.0 /)
  integer ( kind = 4 ) rule

  if ( rule < 1 .or. 12 < rule ) then
    write ( *, '(a)' ) ''
    write ( *, '(a)' ) 'ORDER_POWER - Fatal error!'
    write ( *, '(a)' ) '  Input value of RULE is not between 1 and 12.'
    stop 1
  end if

  order = order_vec(rule)

  return
end
subroutine order_regular ( rule, order )

!*****************************************************************************80
!
!! ORDER_REGULAR returns the order of an Alpert rule for regular functions.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    01 December 2015
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) RULE, the index of the rule, between 1 and 12.
!
!    Output, integer ( kind = 4 ) ORDER, the order of the rule.
!
  implicit none

  integer ( kind = 4 ) order
  integer ( kind = 4 ), dimension ( 12 ) :: order_vec = (/ &
     3,  4,  5,  6,  7, &
     8, 12, 16, 20, 24, &
    28, 32 /)
  integer ( kind = 4 ) rule

  if ( rule < 1 .or. 12 < rule ) then
    write ( *, '(a)' ) ''
    write ( *, '(a)' ) 'ORDER_REGULAR - Fatal error!'
    write ( *, '(a)' ) '  Input value of RULE is not between 1 and 12.'
    stop 1
  end if

  order = order_vec(rule)

  return
end
subroutine r8vec_linspace ( n, a, b, x )

!*****************************************************************************80
!
!! R8VEC_LINSPACE creates a vector of linearly spaced values.
!
!  Discussion:
!
!    An R8VEC is a vector of R8's.
!
!    4 points evenly spaced between 0 and 12 will yield 0, 4, 8, 12.
!
!    In other words, the interval is divided into N-1 even subintervals,
!    and the endpoints of intervals are used as the points.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    14 March 2011
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) N, the number of entries in the vector.
!
!    Input, real ( kind = 8 ) A, B, the first and last entries.
!
!    Output, real ( kind = 8 ) X(N), a vector of linearly spaced data.
!
  implicit none

  integer ( kind = 4 ) n

  real ( kind = 8 ) a
  real ( kind = 8 ) b
  integer ( kind = 4 ) i
  real ( kind = 8 ) x(n)

  if ( n == 1 ) then

    x(1) = ( a + b ) / 2.0D+00

  else

    do i = 1, n
      x(i) = ( real ( n - i,     kind = 8 ) * a   &
             + real (     i - 1, kind = 8 ) * b ) &
             / real ( n     - 1, kind = 8 )
    end do

  end if

  return
end
subroutine r8vec_uniform_01 ( n, seed, r )

!*****************************************************************************80
!
!! R8VEC_UNIFORM_01 returns a unit pseudorandom R8VEC.
!
!  Discussion:
!
!    An R8VEC is a vector of R8's.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    13 August 2014
!
!  Author:
!
!    John Burkardt
!
!  Reference:
!
!    Paul Bratley, Bennett Fox, Linus Schrage,
!    A Guide to Simulation,
!    Springer Verlag, pages 201-202, 1983.
!
!    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, integer ( kind = 4 ) N, the number of entries in the vector.
!
!    Input/output, integer ( kind = 4 ) SEED, the "seed" value, which
!    should NOT be 0.  On output, SEED has been updated.
!
!    Output, real ( kind = 8 ) R(N), the vector of pseudorandom values.
!
  implicit none

  integer ( kind = 4 ) n

  integer ( kind = 4 ) i
  integer ( kind = 4 ), parameter :: i4_huge = 2147483647
  integer ( kind = 4 ) k
  integer ( kind = 4 ) seed
  real ( kind = 8 ) r(n)

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

  do i = 1, n

    k = seed / 127773

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

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

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

  end do

  return
end
subroutine rule_log ( rule, j, x, w )

!*****************************************************************************80
!
!! RULE_LOG returns an Alpert rule for log singular functions.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    01 December 2015
!
!  Author:
!
!    John Burkardt
!
!  Reference:
!
!    Bradley Alpert,
!    Hybrid Gauss-Trapezoidal Quadrature Rules,
!    SIAM Journal on Scientific Computing,
!    Volume 20, Number 5, pages 1551-1584, 1999.
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) RULE, the index of the rule, between 1 and 10.
!
!    Input, integer ( kind = 4 ) J, the number of points in the rule.
!
!    Output, real ( kind = 8 ) X(J), W(J), the points and weights for the rule.
!
  implicit none

  integer ( kind = 4 ) j

  integer ( kind = 4 ) rule
  real ( kind = 8 ) w(j)
  real ( kind = 8 ) x(j)

   if ( rule < 1 .or. 10 < rule ) then
    write ( *, '(a)' ) ''
    write ( *, '(a)' ) 'RULE_LOG - Fatal error!'
    write ( *, '(a)' ) '  Input value of RULE is not between 1 and 10.'
    stop 1
  end if

  if ( rule == 1 ) then

    x(1) = 1.591549430918953D-01

    w(1) = 5.0D-01

  else if ( rule == 2 ) then

    x(1) = 1.150395811972836D-01
    x(2) = 9.365464527949632D-01

    w(1) = 3.913373788753340D-01
    w(2) = 1.108662621124666D+00

  else if ( rule == 3 ) then

    x(1) = 2.379647284118974D-02
    x(2) = 2.935370741501914D-01
    x(3) = 1.023715124251890D+00

    w(1) = 8.795942675593887D-02
    w(2) = 4.989017152913699D-01
    w(3) = 9.131388579526912D-01

  else if ( rule == 4 ) then

    x(1) = 2.339013027203800D-02
    x(2) = 2.854764931311984D-01
    x(3) = 1.005403327220700D+00
    x(4) = 1.994970303994294D+00

    w(1) = 8.609736556158105D-02
    w(2) = 4.847019685417959D-01
    w(3) = 9.152988869123725D-01
    w(4) = 1.013901778984250D+00

  else if ( rule == 5 ) then

    x(1) = 4.004884194926570D-03
    x(2) = 7.745655373336686D-02
    x(3) = 3.972849993523248D-01
    x(4) = 1.075673352915104D+00
    x(5) = 2.003796927111872D+00

    w(1) = 1.671879691147102D-02
    w(2) = 1.636958371447360D-01
    w(3) = 4.981856569770637D-01
    w(4) = 8.372266245578912D-01
    w(5) = 9.841730844088381D-01

  else if ( rule == 6 ) then

    x(1) = 6.531815708567918D-03
    x(2) = 9.086744584657729D-02
    x(3) = 3.967966533375878D-01
    x(4) = 1.027856640525646D+00
    x(5) = 1.945288592909266D+00
    x(6) = 2.980147933889640D+00
    x(7) = 3.998861349951123D+00

    w(1) = 2.462194198995203D-02
    w(2) = 1.701315866854178D-01
    w(3) = 4.609256358650077D-01
    w(4) = 7.947291148621894D-01
    w(5) = 1.008710414337933D+00
    w(6) = 1.036093649726216D+00
    w(7) = 1.004787656533285D+00

  else if ( rule == 7 ) then

    x(1) = 1.175089381227308D-03
    x(2) = 1.877034129831289D-02
    x(3) = 9.686468391426860D-02
    x(4) = 3.004818668002884D-01
    x(5) = 6.901331557173356D-01
    x(6) = 1.293695738083659D+00
    x(7) = 2.090187729798780D+00
    x(8) = 3.016719313149212D+00
    x(9) = 4.001369747872486D+00
    x(10) = 5.000025661793423D+00

    w(1) = 4.560746882084207D-03
    w(2) = 3.810606322384757D-02
    w(3) = 1.293864997289512D-01
    w(4) = 2.884360381408835D-01
    w(5) = 4.958111914344961D-01
    w(6) = 7.077154600594529D-01
    w(7) = 8.741924365285083D-01
    w(8) = 9.661361986515218D-01
    w(9) = 9.957887866078700D-01
    w(10) = 9.998665787423845D-01

  else if ( rule == 8 ) then

    x(1) = 1.674223682668368D-03
    x(2) = 2.441110095009738D-02
    x(3) = 1.153851297429517D-01
    x(4) = 3.345898490480388D-01
    x(5) = 7.329740531807683D-01
    x(6) = 1.332305048525433D+00
    x(7) = 2.114358752325948D+00
    x(8) = 3.026084549655318D+00
    x(9) = 4.003166301292590D+00
    x(10) = 5.000141170055870D+00
    x(11) = 6.000001002441859D+00

    w(1) = 6.364190780720557D-03
    w(2) = 4.723964143287529D-02
    w(3) = 1.450891158385963D-01
    w(4) = 3.021659470785897D-01
    w(5) = 4.984270739715340D-01
    w(6) = 6.971213795176096D-01
    w(7) = 8.577295622757315D-01
    w(8) = 9.544136554351155D-01
    w(9) = 9.919938052776484D-01
    w(10) = 9.994621875822987D-01
    w(11) = 9.999934408092805D-01

  else if ( rule == 9 ) then

    x(1) = 9.305182368545380D-04
    x(2) = 1.373832458434617D-02
    x(3) = 6.630752760779359D-02
    x(4) = 1.979971397622003D-01
    x(5) = 4.504313503816532D-01
    x(6) = 8.571888631101634D-01
    x(7) = 1.434505229617112D+00
    x(8) = 2.175177834137754D+00
    x(9) = 3.047955068386372D+00
    x(10) = 4.004974906813428D+00
    x(11) = 4.998525901820967D+00
    x(12) = 5.999523015116678D+00
    x(13) = 6.999963617883990D+00
    x(14) = 7.999999488130134D+00

    w(1) = 3.545060644780164D-03
    w(2) = 2.681514031576498D-02
    w(3) = 8.504092035093420D-02
    w(4) = 1.854526216643691D-01
    w(5) = 3.251724374883192D-01
    w(6) = 4.911553747260108D-01
    w(7) = 6.622933417369036D-01
    w(8) = 8.137254578840510D-01
    w(9) = 9.235595514944174D-01
    w(10) = 9.821609923744658D-01
    w(11) = 1.000047394596121D+00
    w(12) = 1.000909336693954D+00
    w(13) = 1.000119534283784D+00
    w(14) = 1.000002835746089D+00

  else if ( rule == 10 ) then

    x(1) = 8.371529832014113D-04
    x(2) = 1.239382725542637D-02
    x(3) = 6.009290785739468D-02
    x(4) = 1.805991249601928D-01
    x(5) = 4.142832599028031D-01
    x(6) = 7.964747731112430D-01
    x(7) = 1.348993882467059D+00
    x(8) = 2.073471660264395D+00
    x(9) = 2.947904939031494D+00
    x(10) = 3.928129252248612D+00
    x(11) = 4.957203086563112D+00
    x(12) = 5.986360113977494D+00
    x(13) = 6.997957704791519D+00
    x(14) = 7.999888757524622D+00
    x(15) = 8.999998754306120D+00

    w(1) = 3.190919086626234D-03
    w(2) = 2.423621380426338D-02
    w(3) = 7.740135521653088D-02
    w(4) = 1.704889420286369D-01
    w(5) = 3.029123478511309D-01
    w(6) = 4.652220834914617D-01
    w(7) = 6.401489637096768D-01
    w(8) = 8.051212946181061D-01
    w(9) = 9.362411945698647D-01
    w(10) = 1.014359775369075D+00
    w(11) = 1.035167721053657D+00
    w(12) = 1.020308624984610D+00
    w(13) = 1.004798397441514D+00
    w(14) = 1.000395017352309D+00
    w(15) = 1.000007149422537D+00

  end if

  return
end
subroutine rule_power ( rule, j, x, w )

!*****************************************************************************80
!
!! RULE_POWER returns an Alpert rule for power singular functions.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    01 December 2015
!
!  Author:
!
!    John Burkardt
!
!  Reference:
!
!    Bradley Alpert,
!    Hybrid Gauss-Trapezoidal Quadrature Rules,
!    SIAM Journal on Scientific Computing,
!    Volume 20, Number 5, pages 1551-1584, 1999.
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) RULE, the index of the rule, between 1 and 12.
!
!    Input, integer ( kind = 4 ) J, the number of points in the rule.
!
!    Output, real ( kind = 8 ) X(J), W(J), the points and weights for the rule.
!
  implicit none

  integer ( kind = 4 ) j

  integer ( kind = 4 ) rule
  real ( kind = 8 ) w(j)
  real ( kind = 8 ) x(j)

  if ( rule < 1 .or. 12 < rule ) then
    write ( *, '(a)' ) ''
    write ( *, '(a)' ) 'RULE_POWER - Fatal error!'
    write ( *, '(a)' ) '  Input value of RULE is not between 1 and 12.'
    stop 1
  end if

  if ( rule == 1 ) then

    x(1) = 1.172258571393266D-01

    w(1) = 5.000000000000000D-01

  else if ( rule == 2 ) then

    x(1) = 9.252112715421378D-02
    x(2) = 1.000000000000000D-00

    w(1) = 4.198079625266162D-01
    w(2) = 1.080192037473384D+00

  else if ( rule == 3 ) then

    x(1) = 6.023873796408450D-02
    x(2) = 8.780704050676215D-01

    w(1) = 2.858439990420468D-01
    w(2) = 1.214156000957953D+00

  else if ( rule == 4 ) then

    x(1) = 7.262978413470474D-03
    x(2) = 2.246325512521893D-01
    x(3) = 1.000000000000000D+00

    w(1) = 3.907638767531813D-02
    w(2) = 4.873484056646474D-01
    w(3) = 9.735752066600344D-01

  else if ( rule == 5 ) then

    x(1) = 1.282368909458828D-02
    x(2) = 2.694286346792474D-01
    x(3) = 1.018414523786358D+00

    w(1) = 6.363996663105925D-02
    w(2) = 5.077434578043636D-01
    w(3) = 9.286165755645772D-01

  else if ( rule == 6 ) then

    x(1) = 1.189242434021285D-02
    x(2) = 2.578220434738662D-01
    x(3) = 1.007750064585281D+00
    x(4) = 2.000000000000000D+00

    w(1) = 5.927215035616424D-02
    w(2) = 4.955981740306228D-01
    w(3) = 9.427131290628058D-01
    w(4) = 1.002416546550407D+00

  else if ( rule == 7 ) then

    x(1) = 3.317925942699451D-03
    x(2) = 8.283019705296352D-02
    x(3) = 4.136094925726231D-01
    x(4) = 1.088744373688402D+00
    x(5) = 2.006482101852379D+00
    x(6) = 3.000000000000000D+00

    w(1) = 1.681780929883469D-02
    w(2) = 1.755244404544475D-01
    w(3) = 5.039350503858001D-01
    w(4) = 8.266241339680867D-01
    w(5) = 9.773065848981277D-01
    w(6) = 9.997919809947032D-01

  else if ( rule == 8 ) then

    x(1) = 1.214130606523435D-03
    x(2) = 3.223952700027058D-02
    x(3) = 1.790935383649920D-01
    x(4) = 5.437663805244631D-01
    x(5) = 1.176116628396759D+00
    x(6) = 2.031848210716014D+00
    x(7) = 3.001961225690812D+00
    x(8) = 4.000000000000000D+00

    w(1) = 6.199844884297793D-03
    w(2) = 7.106286791720044D-02
    w(3) = 2.408930104410471D-01
    w(4) = 4.975929263668960D-01
    w(5) = 7.592446540441226D-01
    w(6) = 9.322446399614420D-01
    w(7) = 9.928171438160095D-01
    w(8) = 9.999449125689846D-01

  else if ( rule == 9 ) then

    x(1) = 1.745862989163252D-04
    x(2) = 8.613670540457314D-03
    x(3) = 6.733385088703690D-02
    x(4) = 2.514488774733840D-01
    x(5) = 6.341845573737690D-01
    x(6) = 1.248404055083152D+00
    x(7) = 2.065688031953401D+00
    x(8) = 3.009199358662542D+00
    x(9) = 4.000416269690208D+00
    x(10) = 5.000000000000000D+00

    w(1) = 1.016950985948944D-03
    w(2) = 2.294670686517670D-02
    w(3) = 1.076657968022888D-01
    w(4) = 2.734577662465576D-01
    w(5) = 4.978815591924992D-01
    w(6) = 7.256208919565360D-01
    w(7) = 8.952638690320078D-01
    w(8) = 9.778157465381624D-01
    w(9) = 9.983390781399277D-01
    w(10) = 9.999916342408948D-01

  else if ( rule == 10 ) then

    x(1) = 5.710218427206990D-04
    x(2) = 1.540424351115548D-02
    x(3) = 8.834248407196555D-02
    x(4) = 2.824462054509770D-01
    x(5) = 6.574869892305580D-01
    x(6) = 1.246541060977993D+00
    x(7) = 2.039218495130811D+00
    x(8) = 2.979333487049800D+00
    x(9) = 3.985772595393049D+00
    x(10) = 4.997240804311428D+00
    x(11) = 5.999868793951190D+00
    x(12) = 7.000000000000000D+00

    w(1) = 2.921018926912141D-03
    w(2) = 3.431130611256885D-02
    w(3) = 1.224669495638615D-01
    w(4) = 2.761108242022520D-01
    w(5) = 4.797809643010337D-01
    w(6) = 6.966555677271379D-01
    w(7) = 8.790077941972658D-01
    w(8) = 9.868622449294327D-01
    w(9) = 1.015142389688201D+00
    w(10) = 1.006209712632210D+00
    w(11) = 1.000528829922287D+00
    w(12) = 1.000002397796838D+00

  else if ( rule == 11 ) then

    x(1) = 3.419821460249725D-04
    x(2) = 9.296593430187960D-03
    x(3) = 5.406214771755252D-02
    x(4) = 1.763945096508648D-01
    x(5) = 4.218486605653738D-01
    x(6) = 8.274022895884040D-01
    x(7) = 1.410287585637014D+00
    x(8) = 2.160997505238153D+00
    x(9) = 3.043504749358223D+00
    x(10) = 4.005692579069439D+00
    x(11) = 4.999732707905968D+00
    x(12) = 5.999875191971098D+00
    x(13) = 6.999994560568667D+00
    x(14) = 8.000000000000000D+00

    w(1) = 1.750957243202047D-03
    w(2) = 2.080726584287380D-02
    w(3) = 7.586830616433430D-02
    w(4) = 1.766020526671851D-01
    w(5) = 3.206624362072232D-01
    w(6) = 4.934405290553812D-01
    w(7) = 6.707497030698472D-01
    w(8) = 8.244959025366557D-01
    w(9) = 9.314646742162802D-01
    w(10) = 9.845768443163154D-01
    w(11) = 9.992852769154770D-01
    w(12) = 1.000273112957723D+00
    w(13) = 1.000022857402321D+00
    w(14) = 1.000000081405180D+00

  else if ( rule == 12 ) then

    x(1) = 2.158438988280793D-04
    x(2) = 5.898432743709196D-03
    x(3) = 3.462795956896131D-02
    x(4) = 1.145586495070213D-01
    x(5) = 2.790344218856415D-01
    x(6) = 5.600113798653321D-01
    x(7) = 9.814091242883119D-01
    x(8) = 1.553594853974655D+00
    x(9) = 2.270179114036658D+00
    x(10) = 3.108234601715371D+00
    x(11) = 4.032930893996553D+00
    x(12) = 5.006803270228157D+00
    x(13) = 6.000815466735179D+00
    x(14) = 7.000045035079542D+00
    x(15) = 8.000000738923901D+00
    x(16) = 9.000000000000000D+00

    w(1) = 1.105804873501181D-03
    w(2) = 1.324499944707956D-02
    w(3) = 4.899842307592144D-02
    w(4) = 1.165326192868815D-01
    w(5) = 2.178586693194957D-01
    w(6) = 3.481766016945031D-01
    w(7) = 4.964027915911545D-01
    w(8) = 6.469026189623831D-01
    w(9) = 7.823688971783889D-01
    w(10) = 8.877772445893361D-01
    w(11) = 9.551665077035583D-01
    w(12) = 9.876285579741800D-01
    w(13) = 9.979929183863017D-01
    w(14) = 9.998470620634641D-01
    w(15) = 9.999962891645340D-01
    w(16) = 9.999999946893169D-01

  end if

  return
end
subroutine rule_regular ( rule, j, x, w )

!*****************************************************************************80
!
!! RULE_REGULAR returns an Alpert rule for regular functions.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    01 December 2015
!
!  Author:
!
!    John Burkardt
!
!  Reference:
!
!    Bradley Alpert,
!    Hybrid Gauss-Trapezoidal Quadrature Rules,
!    SIAM Journal on Scientific Computing,
!    Volume 20, Number 5, pages 1551-1584, 1999.
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) RULE, the index of the rule, between 1 and 12.
!
!    Input, integer ( kind = 4 ) J, the number of points in the rule.
!
!    Output, real ( kind = 8 ) X(J), W(J), the points and weights for the rule.
!
  implicit none

  integer ( kind = 4 ) j

  integer ( kind = 4 ) rule
  real ( kind = 8 ) w(j)
  real ( kind = 8 ) x(j)

  if ( rule < 1 .or. 12 < rule ) then
    write ( *, '(a)' ) ''
    write ( *, '(a)' ) 'RULE_REGULAR - Fatal error!'
    write ( *, '(a)' ) '  Input value of RULE is not between 1 and 12.'
    stop 1
  end if

  if ( rule == 1 ) then

    x(1) = 1.666666666666667D-01

    w(1) = 5.000000000000000D-01

  else if ( rule == 2 ) then

    x(1) = 2.000000000000000D-01
    x(2) = 1.000000000000000D+00

    w(1) = 5.208333333333333D-01
    w(2) = 9.791666666666667D-01

  else if ( rule == 3 ) then

    x(1) = 2.245784979812614D-01
    x(2) = 1.013719374359164D+00

    w(1) = 5.540781643606372D-01
    w(2) = 9.459218356393628D-01

  else if ( rule == 4 ) then

    x(1) = 2.250991042610971D-01
    x(2) = 1.014269060987992D+00
    x(3) = 2.000000000000000D+00

    w(1) = 5.549724327164180D-01
    w(2) = 9.451317411845473D-01
    w(3) = 9.998958260990347D-01

  else if ( rule == 5 ) then

    x(1) = 2.180540672543505D-01
    x(2) = 1.001181873031216D+00
    x(3) = 1.997580526418033D+00

    w(1) = 5.408088967208193D-01
    w(2) = 9.516615045823566D-01
    w(3) = 1.007529598696824D+00

  else if ( rule == 6 ) then

    x(1) = 2.087647422032129D-01
    x(2) = 9.786087373714483D-01
    x(3) = 1.989541386579751D+00
    x(4) = 3.000000000000000D+00

    w(1) = 5.207988277246498D-01
    w(2) = 9.535038018555888D-01
    w(3) = 1.024871626402471D+00
    w(4) = 1.000825744017291D+00

  else if ( rule == 7 ) then

    x(1) = 7.023955461621939D-02
    x(2) = 4.312297857227970D-01
    x(3) = 1.117752734518115D+00
    x(4) = 2.017343724572518D+00
    x(5) = 3.000837842847590D+00
    x(6) = 4.000000000000000D+00

    w(1) = 1.922315977843698D-01
    w(2) = 5.348399530514687D-01
    w(3) = 8.170209442488760D-01
    w(4) = 9.592111521445966D-01
    w(5) = 9.967143408044999D-01
    w(6) = 9.999820119661890D-01

  else if ( rule == 8 ) then

    x(1) = 9.919337841451028D-02
    x(2) = 5.076592669645529D-01
    x(3) = 1.184972925827278D+00
    x(4) = 2.047493467134072D+00
    x(5) = 3.007168911869310D+00
    x(6) = 4.000474996776184D+00
    x(7) = 5.000007879022339D+00
    x(8) = 6.000000000000000D+00

    w(1) = 2.528198928766921D-01
    w(2) = 5.550158230159486D-01
    w(3) = 7.852321453615224D-01
    w(4) = 9.245915673876714D-01
    w(5) = 9.839350200445296D-01
    w(6) = 9.984463448413151D-01
    w(7) = 9.999592378464547D-01
    w(8) = 9.999999686258662D-01

  else if ( rule == 9 ) then

    x(1) = 9.209200446233291D-02
    x(2) = 4.752021947758861D-01
    x(3) = 1.124687945844539D+00
    x(4) = 1.977387385642367D+00
    x(5) = 2.953848957822108D+00
    x(6) = 3.976136786048776D+00
    x(7) = 4.994354281979877D+00
    x(8) = 5.999469539335291D+00
    x(9) = 6.999986704874333D+00
    x(10) = 8.000000000000000D+00

    w(1) = 2.351836144643984D-01
    w(2) = 5.248820509085946D-01
    w(3) = 7.634026409869887D-01
    w(4) = 9.284711336658351D-01
    w(5) = 1.010969886587741D+00
    w(6) = 1.024959725311073D+00
    w(7) = 1.010517534639652D+00
    w(8) = 1.001551595797932D+00
    w(9) = 1.000061681794188D+00
    w(10) = 1.000000135843597D+00

  else if ( rule == 10 ) then

    x(1) = 6.001064731474805D-02
    x(2) = 3.149685016229433D-01
    x(3) = 7.664508240518316D-01
    x(4) = 1.396685781342510D+00
    x(5) = 2.175195903206602D+00
    x(6) = 3.062320575880355D+00
    x(7) = 4.016440988792476D+00
    x(8) = 5.002872064275734D+00
    x(9) = 6.000285453310164D+00
    x(10) = 7.000012964962529D+00
    x(11) = 8.000000175554469D+00
    x(12) = 9.000000000000000D+00

    w(1) = 1.538932104518340D-01
    w(2) = 3.551058128559424D-01
    w(3) = 5.449200036280007D-01
    w(4) = 7.104078497715549D-01
    w(5) = 8.398780940253654D-01
    w(6) = 9.272767950890611D-01
    w(7) = 9.750605697371132D-01
    w(8) = 9.942629650823470D-01
    w(9) = 9.992421778421898D-01
    w(10) = 9.999534370786161D-01
    w(11) = 9.999990854912925D-01
    w(12) = 9.999999989466828D-01

  else if ( rule == 11 ) then

    x(1) = 6.234360533194102D-02
    x(2) = 3.250286721702614D-01
    x(3) = 7.837350794282182D-01
    x(4) = 1.415673112616924D+00
    x(5) = 2.189894250061313D+00
    x(6) = 3.070053877483040D+00
    x(7) = 4.018613756218047D+00
    x(8) = 5.002705902035397D+00
    x(9) = 5.999929741810400D+00
    x(10) = 6.999904720846024D+00
    x(11) = 7.999986894843540D+00
    x(12) = 8.999999373380393D+00
    x(13) = 9.999999992002911D+00
    x(14) = 1.100000000000000D+01

    w(1) = 1.595975279734157D-01
    w(2) = 3.637046028193864D-01
    w(3) = 5.498753177297441D-01
    w(4) = 7.087986792086956D-01
    w(5) = 8.335172275501195D-01
    w(6) = 9.204446510608518D-01
    w(7) = 9.710881776552090D-01
    w(8) = 9.933296578555239D-01
    w(9) = 9.994759087910050D-01
    w(10) = 1.000133030254421D+00
    w(11) = 1.000032915011460D+00
    w(12) = 1.000002261653775D+00
    w(13) = 1.000000042393520D+00
    w(14) = 1.000000000042872D+00

  else if ( rule == 12 ) then

    x(1) = 5.899550614325259D-02
    x(2) = 3.082757062227814D-01
    x(3) = 7.463707253079130D-01
    x(4) = 1.355993726494664D+00
    x(5) = 2.112943217346336D+00
    x(6) = 2.987241496545946D+00
    x(7) = 3.944798920961176D+00
    x(8) = 4.950269202842798D+00
    x(9) = 5.972123043117706D+00
    x(10) = 6.989783558137742D+00
    x(11) = 7.997673019512965D+00
    x(12) = 8.999694932747039D+00
    x(13) = 9.999979225211805D+00
    x(14) = 1.099999938266130D+01
    x(15) = 1.199999999462073D+01
    x(16) = 1.300000000000000D+01

    w(1) = 1.511076023874179D-01
    w(2) = 3.459395921169090D-01
    w(3) = 5.273502805146873D-01
    w(4) = 6.878444094543021D-01
    w(5) = 8.210319140034114D-01
    w(6) = 9.218382875515803D-01
    w(7) = 9.873027487553060D-01
    w(8) = 1.018251913441155D+00
    w(9) = 1.021933430349293D+00
    w(10) = 1.012567983413513D+00
    w(11) = 1.004052289554521D+00
    w(12) = 1.000713413344501D+00
    w(13) = 1.000063618302950D+00
    w(14) = 1.000002486385216D+00
    w(15) = 1.000000030404477D+00
    w(16) = 1.000000000020760D+00

  end if

  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.2,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


!***********************************************************************
!                                                                      *
      REAL(KIND(0.0D0)) FUNCTION ARCTAN (ARG1, ARG2)
!-----------------------------------------------
!                                                                      *
!                   -1                                                 *
!       ARCTAN = tan   (ARG1/ARG2),      0 .LE. ARCTAN .LT. 2*\pi      *
!                                                                      *
!   Written by Farid A Parpia, at Oxford    Last update: 06 Oct 1992   *
!   Editted by C. Froese Fischer after translation                     *
!                                                                      *
!***********************************************************************
!...Translated by Pacific-Sierra Research 77to90  4.3E  10:46:34   2/14/04
!...Modified by Charlotte Froese Fischer
!                     Gediminas Gaigalas  10/05/17
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY:  DOUBLE
      USE DEF_C
!
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      REAL(DOUBLE), INTENT(IN) :: ARG1
      REAL(DOUBLE), INTENT(IN) :: ARG2
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      LOGICAL, SAVE :: FIRST = .TRUE., INTRIN = .TRUE.
!-----------------------------------------------
!
!
!   Determine whether the FORTRAN intrinsic function ATAN2 always
!   returns a positive value
!
      IF (FIRST) THEN
         ARCTAN = ATAN2(-1.0D00,-1.0D00)
         IF (ARCTAN > 0.0D00) THEN
            INTRIN = .TRUE.
         ELSE
            INTRIN = .FALSE.
         ENDIF
         FIRST = .FALSE.
      ENDIF
!
!   Use the intrinsic function if it passes the above test; otherwise
!   add 2*PI to the negative values returned by the intrinsic function
!
      IF (INTRIN) THEN
         ARCTAN = ATAN2(ARG1,ARG2)
      ELSE
         IF (ARG1 >= 0.0D00) THEN
            ARCTAN = ATAN2(ARG1,ARG2)
         ELSE
            ARCTAN = PI + PI + ATAN2(ARG1,ARG2)
         ENDIF
      ENDIF
!
      RETURN
      END FUNCTION ARCTAN


module advance_reaction_module

  use ml_layout_module
  use define_bc_module
  use multifab_physbc_module
  use bc_module
  use chemical_rates_module
  use probin_reactdiff_module, only: nspecies, nreactions, reaction_type, inhomogeneous_bc_fix

  implicit none

  private

  public :: advance_reaction

  ! here we use Mattingly's predictor-corrector with theta=0.5d0 (for rection_type=1).
  ! with these parameters this is actually equivalent to a traditional midpoint scheme.
  real(kind=dp_t), parameter :: theta = 0.5d0
  real(kind=dp_t), parameter :: alpha1 = 2.d0
  real(kind=dp_t), parameter :: alpha2 = 1.d0

contains

  ! this solves dn/dt = f(n) - g (note the minus sign for g)
  ! where f(n) are the chemical production rates (deterministic or stochastic)
  ! and g=ext_src is a constant (in time) *deterministic* source term.
  ! to model stochastic particle production (sources) include g in the definition of f instead.
  ! or add it as a reaction 0->products

  subroutine advance_reaction(mla,n_old,n_new,dx,dt,the_bc_tower,ext_src)

    type(ml_layout), intent(in   ) :: mla
    type(multifab) , intent(in   ) :: n_old(:)
    type(multifab) , intent(inout) :: n_new(:)
    real(kind=dp_t), intent(in   ) :: dx(:,:),dt
    type(bc_tower) , intent(in   ) :: the_bc_tower
    type(multifab) , intent(in   ) :: ext_src(:)

    ! local
    type(multifab) :: rate(mla%nlevel)

    integer :: nlevs, dm, n

    type(bl_prof_timer),save :: bpt

    real(kind=dp_t) :: mattingly_lin_comb_coef(1:2)  ! only used for reaction_type=1

    !!!!!!!!
    ! init !
    !!!!!!!!

    nlevs = mla%nlevel
    dm = mla%dim

    ! if there are no reactions to process, copy n_old to n_new,
    ! account for ext_src and return
    if(nreactions<1) then
       do n=1,nlevs
          call multifab_copy_c(n_new(n),1,n_old(n),1,nspecies,n_new(n)%ng)
          call multifab_saxpy_3(n_new(n),-dt,ext_src(n))
       end do
       return
    end if

    call build(bpt,"advance_reaction")

    do n=1,nlevs
       call multifab_build(rate(n),mla%la(n),nspecies,0)
    end do

    !!!!!!!!!!!!!!!!!!
    ! advancing time !
    !!!!!!!!!!!!!!!!!!

    if (reaction_type .eq. 0) then ! first-order det/tau-leaping/CLE, or SSA

      ! calculate rates
      ! rates could be deterministic or stochastic depending on use_Poisson_rng
      call chemical_rates(mla,n_old,rate,dx,dt)

      ! update
      do n=1,nlevs
        call multifab_copy_c(n_new(n),1,n_old(n),1,nspecies,0)
        call multifab_saxpy_3(n_new(n),dt,rate(n))
        call multifab_saxpy_3(n_new(n),-dt,ext_src(n))  ! note the negative sign

        call multifab_fill_boundary(n_new(n))
        call multifab_physbc(n_new(n),1,scal_bc_comp,nspecies, &
                             the_bc_tower%bc_tower_array(n),dx_in=dx(n,:))
      end do

    else if (reaction_type .eq. 1) then  ! second-order det/tau-leaping/CLE

      !!!!!!!!!!!!!!!
      ! predictor   !
      !!!!!!!!!!!!!!!

      ! calculate rates from a(n_old)
      call chemical_rates(mla,n_old,rate,dx,theta*dt)

      do n=1,nlevs
        call multifab_copy_c(n_new(n),1,n_old(n),1,nspecies,0)
        call multifab_saxpy_3(n_new(n),theta*dt,rate(n))
        call multifab_saxpy_3(n_new(n),-theta*dt,ext_src(n))  ! note the negative sign

        call multifab_fill_boundary(n_new(n))
        call multifab_physbc(n_new(n),1,scal_bc_comp,nspecies, &
                             the_bc_tower%bc_tower_array(n),dx_in=dx(n,:))
      end do

      !!!!!!!!!!!!!!!
      ! corrector   !
      !!!!!!!!!!!!!!!

      ! Here we write this in the form that Mattingly et al do
      !  where we just continue the second half of the time step from where we left

      mattingly_lin_comb_coef(1) = -alpha2
      mattingly_lin_comb_coef(2) = alpha1

      ! calculate rates from 2*a(n_pred)-a(n_old)
      call chemical_rates(mla,n_old,rate,dx,(1.d0-theta)*dt,n_new,mattingly_lin_comb_coef)

      ! update
      do n=1,nlevs
        call multifab_saxpy_3(n_new(n),(1.d0-theta)*dt,rate(n))
        ! note the negative sign
        ! also note that ext_src does not change in the time interval (t,t+dt)
        call multifab_saxpy_3(n_new(n),-dt*(1.d0-theta)*(alpha1-alpha2),ext_src(n))

        call multifab_fill_boundary(n_new(n))
        call multifab_physbc(n_new(n),1,scal_bc_comp,nspecies, &
                             the_bc_tower%bc_tower_array(n),dx_in=dx(n,:))
      end do

    else

      call bl_error("advance_reaction: invalid reaction_type")

    end if

    !!!!!!!!!!!
    ! destroy !
    !!!!!!!!!!!
    do n=1,nlevs
        call multifab_destroy(rate(n))
    end do

    call destroy(bpt)

  end subroutine advance_reaction

end module advance_reaction_module


Program LocalizedAdmitCorr
!------------------------------------------------------------------------------
!
!    This program demonstrates how to calculate localized admittance and
!    correlation functions.
!
!    Copyright (c) 2005, SHTOOLS
!    All rights reserved.
!
!------------------------------------------------------------------------------
    use SHTOOLS
    use PlanetsConstants
    use ftypes

    implicit none

    character(120) :: topography_file, potential_file, outfile
    real(dp) :: header(8), mpr,  r0_pot, gm, mass, lat, lon, pi, theta0, &
                alpha, sn, r
    real(dp), allocatable :: grav(:,:,:), admit(:), corr(:), admit_error(:), &
                             corr_error(:), tapers(:,:), eigenvalues(:), &
                             topo(:,:,:), pot(:,:,:)
    integer :: lmax_topo, lmax_pot, lmax, option1, l, lwin, lmaxwin, &
               astat(5), K, degmax
    integer, allocatable :: taper_order(:)

    pi = acos(-1.0_dp)

    degmax = 360

    topography_file = "../../ExampleDataFiles/MarsTopo719.shape"
    potential_file = "../../ExampleDataFiles/gmm3_120_sha.tab"

    !--------------------------------------------------------------------------
    !
    !   Read topography and gravity fields, and from the header information
    !   determine the mean planetary radius and mass. Verify that these values
    !   are correct as it is possible the input files could be using a
    !   different set of base units (i.e., km instead of meters).
    !
    !--------------------------------------------------------------------------

    allocate(topo(2,degmax+1,degmax+1), stat = astat(1))
    allocate(pot(2,degmax+1,degmax+1), stat = astat(2))
    if (astat(1) /= 0 .or. astat(2) /= 0) then
        print*, "Problem allocating arrays TOPO and POT", astat(1), astat(2)
        stop
    end if

    print*, "Reading = ", topography_file
    call SHRead(topography_file, topo, lmax_topo)

    print*, "Lmax of topography file = ", lmax_topo

    mpr = topo(1,1,1)
    print*, "Mean planetary radius (km) = ", mpr  /1.e3_dp

    print*, "Reading = ", potential_file
    call SHRead(potential_file, pot, lmax_pot, header=header(1:2))

    print*, "Lmax of potential file = ", lmax_pot

    r0_pot = header(1) * 1.e3_dp
    gm = header(2) * 1.e9_dp
    mass = gm/Grav_constant

    print*, "Reference radius of potential coefficients (km) = ", r0_pot / 1.e3_dp

    print*, "Mass of planet (kg) = ", mass
    print*, "Surface gravitational acceleration (m/s2) = ", gm / r0_pot**2

    lmax = min(lmax_topo, lmax_pot)
    print*, "Maximum spherical harmonic degree to be used in calculations = ", lmax

    !--------------------------------------------------------------------------
    !
    !    Get localization parameters from user.
    !
    !--------------------------------------------------------------------------

    print*, "Number of tapers to use > "
    read(*,*) K

    print*, "Latitude of feature of interest (degrees) > "
    read(*,*) lat
    print*, "Longitude (degrees) > "
    read(*,*) lon
    print*, "Angular radius of localization window (degrees) > "
    read(*,*) theta0
    theta0 = theta0*pi / 180.0_dp

    print*, "Create localization window using"
    print*, "(1) Desired concentration factor, alpha"
    print*, "(2) Desired (approximate) Shannon number; (Lwin+1) Theta0 / pi)"
    print*, "(3) Desired Spectral bandwidth (Lwin)"
    read(*,*) option1

    if (option1==1) then
        print*, "Input desired concentration factor of the Kth taper > "
        read(*,*) alpha
        lwin = SHFindLWin(theta0, 0, alpha, K)
        print*, "Corresponding spherical harmonic bandwidth = ", lwin
        print*, "Corresponding approximate Shannon number = ", &
                (lwin+1) * theta0 / pi
    else if (option1==2) then
        print*, "Input Shannon number > "
        read(*,*) sn
        lwin = nint(sn * pi / theta0) - 1
        print*, "Corresponding spherical harmonic bandwidth = ", lwin
    else if (option1==3) then
        print*, "Input Lwin > "
        read(*,*) lwin
        print*, "Corresponding approximate Shannon number = ", &
                (lwin+1) * theta0 / pi
    else
        stop
    end if

    allocate(tapers(lwin+1, (lwin+1)**2), stat = astat(1))
    allocate(taper_order((lwin+1)**2), stat = astat(2))
    allocate(eigenvalues((lwin+1)**2), stat = astat(3))

    if (astat(1) /= 0 .or. astat(2) /= 0 .or. astat(3) /= 0 ) then
        print*, "Problem allocatig arrays for tapers, taper_order, or eigenvalues", &
                astat(1), astat(2), astat(3)
        stop
    end if

    call SHReturnTapers(theta0, lwin, tapers, eigenvalues, taper_order)

    print*, "Concentration factor of first taper = ", eigenvalues(1)
    print*, "Taper order = ", taper_order(1)

    lmaxwin = lmax + lwin

    r = r0_pot

    print*, "Gravity field evaluated at R = (km) ", r0_pot / 1.e3_dp

    print*, "Name of output admittance and correlation file > "
    read(*,*) outfile
    open(12, file=outfile)

    !--------------------------------------------------------------------------
    !
    !    Allocate memory for arrays based on Lmax and Lwin.
    !
    !--------------------------------------------------------------------------

    allocate(grav(2,lmax+1,lmax+1), stat=astat(1))
    allocate(admit(lmax+lwin+1), stat=astat(2))
    allocate(corr(lmax+lwin+1), stat=astat(3))
    allocate(admit_error(lmax+lwin+1), stat=astat(4))
    allocate(corr_error(lmax+lwin+1), stat=astat(5))

    grav = 0.0_dp
    admit = 0.0_dp
    corr = 0.0_dp
    admit_error = 0.0_dp
    corr_error = 0.0_dp

    if (astat(1) /= 0 .or. astat(2) /= 0 .or. astat(3) /= 0 .or. astat(4) /= 0 &
        .or. astat(5) /=0) then
        print*, "Problem allocating memory"
        stop
    end if

    !--------------------------------------------------------------------------
    !
    !    Create gravity coefficients in units of mGals. Convert Topography
    !    coefficients to km.
    !
    !    Cilm(gravity) = 1.d5*G*M*Cilm(potential)*(l+1)*(r0_pot/r)**(l+2)/r0_pot**2
    !
    !--------------------------------------------------------------------------

    do l = 0, lmax
        grav(1:2,l+1,1:l+1) = pot(1:2,l+1,1:l+1) * dble(l+1) * (r0_pot/r)**(l+2)
    end do

    grav = grav * 1.0e5_dp * gm / (r0_pot**2)
    topo = topo / 1.0e3_dp

    !--------------------------------------------------------------------------
    !
    !    Compute localized admittances, and write data to output file.
    !    Units for the admittance are mgals/km.
    !
    !--------------------------------------------------------------------------

    call SHLocalizedAdmitCorr(tapers, taper_order, lwin, lat, lon, grav, topo, &
        lmax, admit, corr, K, admit_error=admit_error, corr_error=corr_error, &
        mtdef=1)

    if (K == 1) then
        do l = 0, lmax - lwin
            write(12,*) l, admit(l+1), corr(l+1)
        end do
    else
        do l = 0, lmax - lwin
            write(12,*) l, admit(l+1), admit_error(l+1), corr(l+1), &
                        corr_error(l+1)
        end do
    end if

    close(12)

    deallocate(grav)
    deallocate(admit)
    deallocate(admit_error)
    deallocate(corr)
    deallocate(corr_error)
    deallocate(tapers)
    deallocate(taper_order)
    deallocate(eigenvalues)
    deallocate(topo)
    deallocate(pot)

end program LocalizedAdmitCorr


! 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$

!> Random number and random sequence routines.  Can generate random draws
!> from a uniform distribution or random draws from differently shaped
!> distributions (e.g. gaussian, gamma, exponential)

module random_seq_mod

! This module now contains both the original contents and the routines
! which used to be in a separate random_nr module.

use     types_mod, only : digits12, i8, r8
use utilities_mod, only : register_module, error_handler, E_ERR

implicit none
private

public :: random_seq_type, &
          init_random_seq, &
          random_uniform, &
          random_gaussian, &
          several_random_gaussians, &
          twod_gaussians, &
          random_gamma, &
          random_inverse_gamma, &
          random_exponential

! 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$"

! Gives ability to generate unique repeatable sequences of random numbers
! using random congruential package. Needed to allow different assim algorithms
! that require random numbers to see identical observational sequences.

! Used to give different sequences a different but repeatable start
! There may be problems with incestuous series here; be cautious of this
! in the future.

integer :: seq_number = -1

! the following routines were transcribed from C to F90, originally
! from the GNU scientific library:  init_ran, ran_unif, ran_gauss,
! ran_gamma

integer, parameter :: N = 624   ! period parameters
integer, parameter :: M = 397

! hexadecimal constants
integer(i8), parameter :: UPPER_MASK  = z'0000000080000000'
integer(i8), parameter :: LOWER_MASK  = z'000000007FFFFFFF'
integer(i8), parameter :: FULL32_MASK = z'00000000FFFFFFFF'
integer(i8), parameter :: magic       = z'000000009908B0DF'
integer(i8), parameter :: C1          = z'000000009D2C5680'
integer(i8), parameter :: C2          = z'00000000EFC60000'

type random_seq_type
   private
   integer     :: mti
   integer(i8) :: mt(0:N-1)
   real(r8)    :: lastg
   logical     :: gset
end type random_seq_type

logical, save :: module_initialized = .false.
character(len=128) :: errstring

contains

!========================================================================
! Public entry points
!========================================================================

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

!> An integer seed can be used to get a particular repeatable sequence.

subroutine init_random_seq(r, seed)

type(random_seq_type), intent(inout) :: r
integer, optional,     intent(in)    :: seed

if ( .not. module_initialized ) call initialize_module

! Initialize the generator; use given seed if present, else sequence
if(present(seed)) then
   call init_ran(r, seed)
else
   call init_ran(r, seq_number)
   seq_number = seq_number - 1
endif

end subroutine init_random_seq

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

!> return a random draw from a uniform distribution
!> between 0.0 and 1.0

function random_uniform(r)

type(random_seq_type), intent(inout) :: r
real(r8)                             :: random_uniform

if ( .not. module_initialized ) call initialize_module

random_uniform = ran_unif(r)

end function random_uniform

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

!> return a random draw from a gaussian distribution
!> with the specified mean and standard deviation.

function random_gaussian(r, mean, standard_deviation)

type(random_seq_type), intent(inout) :: r
real(r8),              intent(in)    :: mean, standard_deviation
real(r8)                             :: random_gaussian

if ( .not. module_initialized ) call initialize_module

random_gaussian = ran_gauss(r) * standard_deviation + mean

end function random_gaussian

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

!> return multiple random draws from a gaussian distribution
!> with the specified mean and standard deviation.

subroutine several_random_gaussians(r, mean, standard_deviation, n, rnum)

type(random_seq_type), intent(inout) :: r
real(r8),              intent(in)    :: mean
real(r8),              intent(in)    :: standard_deviation
integer,               intent(in)    :: n
real(r8),              intent(out)   :: rnum(n)

integer :: i

if ( .not. module_initialized ) call initialize_module

do i = 1, n
   rnum(i) = ran_gauss(r) * standard_deviation + mean
end do

end subroutine several_random_gaussians

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

!> return a random draw from a 2D multivariate gaussian distribution
!> with the specified 2 means and covariances.

subroutine twod_gaussians(r, mean, cov, rnum)

type(random_seq_type), intent(inout) :: r
real(r8),              intent(in)    :: mean(2)
real(r8),              intent(in)    :: cov(2, 2)
real(r8),              intent(out)   :: rnum(2)

real(r8) :: a11, a21, a22, x1, x2

if ( .not. module_initialized ) call initialize_module

! Use method from Knuth, exercise 13, section 3.4.1 to generate random
! numbers with this mean and covariance

a11 = sqrt(cov(1, 1))
a21 = cov(1, 2) / a11
a22 = sqrt(cov(2, 2) - a21**2)

! Two base independent gaussian deviates
x1 = ran_gauss(r)
x2 = ran_gauss(r)

! Use these to generate correlated
rnum(1) = mean(1) + a11 * x1
rnum(2) = mean(2) + a21 * x1 + a22 * x2

end subroutine twod_gaussians

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

!> return a random draw from a gamma distribution
!> with the specified shape and scale parameter, often
!> denoted with the symbols kappa and theta.
!>
!> note that there are multiple common formulations of
!> the second parameter to this function.  if you have
!> 'rate' instead of 'scale' specify:  1.0 / rate
!> for the scale parameter.  shape and rate are often
!> denoted with the symbols alpha and beta.
!>
!> The distribution mean should be: shape * rate,
!> and the variance: shape * (rate^2).

function random_gamma(r, shape, scale)

type(random_seq_type), intent(inout) :: r
real(r8),              intent(in)    :: shape
real(r8),              intent(in)    :: scale
real(r8)                             :: random_gamma

if ( .not. module_initialized ) call initialize_module

if (shape <= 0.0_r8) then
   write(errstring, *) 'Shape parameter must be positive, was ', shape
   call error_handler(E_ERR, 'random_gamma', errstring, source, revision, revdate)
endif

if (scale <= 0.0_r8) then
   write(errstring, *) 'Scale parameter (scale=1/rate) must be positive, was ', scale
   call error_handler(E_ERR, 'random_gamma', errstring, source, revision, revdate)
endif

! internal routine uses shape, scale
random_gamma = ran_gamma(r, shape, scale)

end function random_gamma

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

!> return a random draw from an inverse gamma distribution
!> with the specified shape and scale parameter.
!> NOTE THIS IS DIFFERENT FROM THE RANDOM GAMMA FORUMULATION.
!> gamma uses a rate parameter, inverse gamma uses scale.
!> if you have 'rate' instead of 'scale', specify 1.0 / rate

function random_inverse_gamma(r, shape, scale)

type(random_seq_type), intent(inout) :: r
real(r8),              intent(in)    :: shape
real(r8),              intent(in)    :: scale
real(r8)                             :: random_inverse_gamma

real(r8) :: g

if ( .not. module_initialized ) call initialize_module

if (shape <= 0.0_r8) then
   write(errstring, *) 'Shape parameter must be positive, was ', shape
   call error_handler(E_ERR, 'random_inverse_gamma', errstring, source, revision, revdate)
endif

if (scale <= 0.0_r8) then
   write(errstring, *) 'Scale parameter (scale=1/rate) must be positive, was ', scale
   call error_handler(E_ERR, 'random_inverse_gamma', errstring, source, revision, revdate)
endif

g = ran_gamma(r, shape, scale)

! ran_gamma can't return 0 so its safe to divide by it
random_inverse_gamma = 1.0_r8/g

end function random_inverse_gamma

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

!> return a random draw from an exponential distribution with
!> the specified rate parameter lambda.  if you have a scale parameter,
!> also called the mean, standard deviation, or survival parameter,
!> specify 1.0 / scale for rate.

function random_exponential(r, rate)

type(random_seq_type), intent(inout) :: r
real(r8),              intent(in)    :: rate
real(r8)                             :: random_exponential

if ( .not. module_initialized ) call initialize_module

if (rate <= 0.0_r8) then
   write(errstring, *) 'Rate parameter (rate=1/scale) must be positive, was ', rate
   call error_handler(E_ERR, 'random_exponential', errstring, source, revision, revdate)
endif

! internal routine uses shape, scale
random_exponential = ran_gamma(r, 1.0_r8, 1.0_r8/rate)

end function random_exponential

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

!========================================================================
! Private, internal routines below here
!========================================================================

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

subroutine initialize_module

if ( .not. module_initialized ) then
   call register_module(source, revision, revdate)
   module_initialized = .true.
endif

end subroutine initialize_module

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

!> A random congruential random number generator of the Mersenne Twister type
!> See GNU Scientific Library code.

subroutine init_ran(s, seed)
 integer, intent(in) :: seed
 type(random_seq_type), intent(out) :: s

 integer :: i, sd

! Initialize the generator for use with
! repeatable sequences

sd = seed
if (sd == 0) sd = 4357   ! do not allow seed to be 0, use default

s%mt(0) = iand(int(sd,i8), FULL32_MASK)

! See Knuth's "Art of Computer Programming" Vol. 2, 3rd Ed. p.106
! for multiplier.

do i=1, N-1
   s%mt(i) = 1812433253_i8 * ieor(s%mt(i-1), ishft(s%mt(i-1), -30_i8)) + i

   s%mt(i) = iand(s%mt(i), FULL32_MASK)
end do

s%mti = N
s%lastg = 0.0_r8
s%gset = .false.

end subroutine init_ran

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

!> A random congruential random number generator from
!> the GNU Scientific Library (The Mersenne Twister MT19937 varient.)

function ran_unif(s)
 type(random_seq_type), intent(inout) :: s
 real(r8) :: ran_unif

integer :: kk
integer(i8) :: k, y, m1

! original c code:
!  define MAGIC(y) (((y)&0x1) ? 0x9908b0dfUL : 0)

if (s%mti >= N) then
   ! generate N words at a time
   do kk = 0, N-M-1
      y = ior(iand(s%mt(kk), UPPER_MASK), iand(s%mt(kk + 1), LOWER_MASK))
      if (iand(y,1_i8) == 1_i8) then
         m1 = magic
      else
         m1 = 0_i8
      endif
      s%mt(kk) = ieor(s%mt(kk + M), ieor(ishft(y,-1_i8), m1))

! original c code:
!          unsigned long y = (mt[kk] & UPPER_MASK) | (mt[kk + 1] & LOWER_MASK);
!          mt[kk] = mt[kk + M] ^ (y >> 1) ^ MAGIC(y);

   enddo

   do kk = N-M, N-2
      y = ior(iand(s%mt(kk), UPPER_MASK), iand(s%mt(kk + 1), LOWER_MASK))
      if (iand(y,1_i8) == 1_i8) then
         m1 = magic
      else
         m1 = 0_i8
      endif
      s%mt(kk) = ieor(s%mt(kk + (M-N)), ieor(ishft(y,-1_i8), m1))

! original c code:
!          unsigned long y = (mt[kk] & UPPER_MASK) | (mt[kk + 1] & LOWER_MASK);
!          mt[kk] = mt[kk + (M - N)] ^ (y >> 1) ^ MAGIC(y);

   enddo

   y = ior(iand(s%mt(N-1), UPPER_MASK), iand(s%mt(0), LOWER_MASK))
   if (iand(y,1_i8) == 1_i8) then
      m1 = magic
   else
      m1 = 0_i8
   endif
   s%mt(N-1) = ieor(s%mt(M-1), ieor(ishft(y,-1_i8), m1))

! original c code:
!        unsigned long y = (mt[N - 1] & UPPER_MASK) | (mt[0] & LOWER_MASK);
!        mt[N - 1] = mt[M - 1] ^ (y >> 1) ^ MAGIC(y);

   s%mti = 0
endif

! Tempering

k = s%mt(s%mti)

k = ieor(k, ishft(k, -11_i8))
k = ieor(k, iand(ishft(k, 7_i8),  C1))
k = ieor(k, iand(ishft(k, 15_i8), C2))
k = ieor(k, ishft(k, -18_i8))

! original c code:
!  k ^= (k >> 11);
!  k ^= (k << 7) & 0x9d2c5680UL;
!  k ^= (k << 15) & 0xefc60000UL;
!  k ^= (k >> 18);

s%mti = s%mti + 1

! at this point we have an integer value for k
! this routine returns 0.0 <= real < 1.0, so do
! the divide here.  return range:  [0,1).

ran_unif = real(real(k, digits12) / 4294967296.0_digits12, r8)

end function ran_unif

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

!> Polar (Box-Mueller) method; See Knuth v2, 3rd ed, p122
!> Returns a N(-1, 1) random number draw from a gaussian distribution

function ran_gauss(s)

type(random_seq_type), intent(inout) :: s
real(r8) :: ran_gauss

real(digits12) :: x, y, r2, t
integer :: lc

! each pass through this code generates 2 values.  if we have one
! saved from a previous call, return it without doing any new work.
! otherwise, generate 2 new values; return one and save the other.

if (s%gset) then
   ran_gauss = s%lastg
   s%gset = .false.
else

   lc = 0
10 continue
   lc = lc + 1

   ! choose x,y in uniform square (-1,-1) to (+1,+1)
   x = -1.0_digits12 + 2.0_digits12 * ran_unif(s)
   y = -1.0_digits12 + 2.0_digits12 * ran_unif(s)

   ! repeat if it is outside the unit circle or at origin
   r2 = x*x + y*y
   if (r2 >= 1.0_digits12 .or. r2 == 0.0_digits12) then
      if (lc > 100) then
         write(errstring, *) 'x, y = ', x, y
         call error_handler(E_ERR, 'ran_gauss', &
                            'if both x and y are -1, random number generator probably not initialized', &
                            source, revision, revdate, &
                            text2 = errstring);
      endif
      goto 10
   endif

   t = sqrt(-2.0_digits12 * log(r2) / r2)
   s%lastg   = real(x * t, r8)
   s%gset    = .true.
   ran_gauss = real(y * t, r8)
endif

end function ran_gauss

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

!> Gamma(a,b) generator from the GNU Scientific library.
!>
!> There are three different parameterizations in common use:
!>  1. With a shape parameter k and a scale parameter θ.
!>  2. With a shape parameter α = k and an inverse scale parameter β = 1/θ, called a rate parameter.
!>  3. With a shape parameter k and a mean parameter μ = k/β.
!>
!> warning!
!> this is the private, internal interface and it uses the first
!> parameterization, kappa and theta, like the original GSL code.
!> our public interfaces use the words 'shape', 'scale' and 'rate'
!> to try to be more clear about which parameterization we're using.
!>
!> this internal routine assumes the caller has already verified that
!> the shape and scale are positive.

recursive function ran_gamma (r, shape, scale) result(g)

type(random_seq_type), intent(inout) :: r
real(r8), intent(in) :: shape
real(r8), intent(in) :: scale
real(r8) :: g

real(r8) :: x, v, u
real(r8) :: c, d

! we chose the public interface to take 'rate' since that
! seems to be more common in the kalman world.  but the original
! code is based on a scale parameter, so that's what we use here.

if (shape < 1.0) then
   u = random_uniform (r)
   g = ran_gamma (r, 1.0_r8 + shape, scale) * u ** (1.0_r8 / shape)
   return
endif

d = shape - 1.0_r8 / 3.0_r8
c = (1.0_r8 / 3.0_r8) / sqrt (d)
v = -1.0_r8

OUTER: do while (.true.)
    v = -1.0_r8
    do while (v <= 0.0_r8)
       x = random_gaussian(r, 0.0_r8, 1.0_r8)
       v = 1.0_r8 + c * x
    enddo

    v = v * v * v;
    u = random_uniform (r);

    if (u < 1 - 0.0331_r8 * x * x * x * x) exit OUTER

    if (log (u) < 0.5_r8 * x * x + d * (1 - v + log (v))) exit OUTER

enddo OUTER

g = scale * d * v

end function ran_gamma

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

end module random_seq_mod

! <next few lines under version control, do not edit>
! $URL$
! $Id$
! $Revision$
! $Date$


  !diagonal, spin conserving:
  do iorb=1,Norb
     do kp=1,Nbath
        ms=getBathStride(iorb,kp)
        !
        ! IMP UP <--> BATH UP
        if( (diag_hybr(1,iorb,kp)/=0d0) .AND. (ib(iorb)==1) .AND. (ib(ms)==0) )then
           call c(iorb,m,k1,sg1)
           call cdg(ms,k1,k2,sg2)
           j = binary_search(H%map,k2)
           htmp = diag_hybr(1,iorb,kp)*sg1*sg2
           Hmat(i,j) = Hmat(i,j) + htmp
        endif
        if( (diag_hybr(1,iorb,kp)/=0d0) .AND. (ib(iorb)==0) .AND. (ib(ms)==1) )then
           call c(ms,m,k1,sg1)
           call cdg(iorb,k1,k2,sg2)
           j=binary_search(H%map,k2)
           htmp = diag_hybr(1,iorb,kp)*sg1*sg2
           Hmat(i,j) = Hmat(i,j) + htmp
        endif
        !
        !IMP DW <--> BATH DW
        if( (diag_hybr(Nspin,iorb,kp)/=0d0) .AND. (ib(iorb+Ns)==1) .AND. (ib(ms+Ns)==0) )then
           call c(iorb+Ns,m,k1,sg1)
           call cdg(ms+Ns,k1,k2,sg2)
           j=binary_search(H%map,k2)
           htmp=diag_hybr(Nspin,iorb,kp)*sg1*sg2
           Hmat(i,j) = Hmat(i,j) + htmp
        endif
        if( (diag_hybr(Nspin,iorb,kp)/=0d0) .AND. (ib(iorb+Ns)==0) .AND. (ib(ms+Ns)==1) )then
           call c(ms+Ns,m,k1,sg1)
           call cdg(iorb+Ns,k1,k2,sg2)
           j=binary_search(H%map,k2)
           htmp=diag_hybr(Nspin,iorb,kp)*sg1*sg2
           Hmat(i,j) = Hmat(i,j) + htmp
        endif
     enddo
  enddo


*********************************************************************
      SUBROUTINE check!(un)
      implicit none
      include 'usr.com'
*     LOCAL
      integer i,j,k
      real    un(ndim),fvec(ndim),fvecstar(ndim),del
      real    Achk(ndim,ndim),err(ndim,ndim)
      real    A(ndim,ndim),g05caf
      real    u(0:n  ,0:m,0:l+la+1), v(0:n,0:m  ,0:l+la+1)
      real    w(0:n+1,0:m+1,0:l+la  ), p(0:n+1,0:m+1,0:l+la+1)
      real    t(0:n+1,0:m+1,0:l+la+1), s(0:n+1,0:m+1,0:l+la+1)

      open(14,file='errors')
      open(15,file='berrors')
      call init
      call stpnt(un)
      call allocate_mat  ! allocate matrixarrays
      DO i = 1,ndim
       un(i) = 1.0+0.1*g05caf()
      ENDDO
      call usol(un,u,v,w,p,t,s)

      del = 1.0e-06
      DO j=1,ndim
        call rhs(un,fvec)
        un(j) = un(j)+del
        call rhs(un,fvecstar)
        un(j) = un(j)-del
        DO i=1,ndim
          Achk(i,j)= (fvec(i)-fvecstar(i))/del
        ENDDO
      ENDDO
      call matrix(un,0.0)
      call fillsqmat(A)
      err = A-Achk
      DO i=1,ndim
        DO j=1,ndim
          IF (abs(err(i,j)).GT.del) THEN
          write(14,999) i,j,A(i,j),Achk(i,j),err(i,j)
          END IF
          IF (abs(err(i,j)).GT.(1.0e-03)) THEN
          write(15,999) i,j,A(i,j),Achk(i,j),err(i,j)
          END IF
        ENDDO
      ENDDO
*      stop

 999  format(2i4,3e19.6)
      END
*************************************************************
      SUBROUTINE fillsqmat(A)
      USE m_mat
      implicit none
      include 'usr.com'
!      include 'mat.com'
*      IMPORT/EXPORT
      real     A(ndim,ndim)
      integer  i,v

      A = 0.0
      DO i=1,ndim
       DO v=begA(i),begA(i+1)-1
        IF (abs(coA(v)).GT.1e-10) A(i,jcoA(v)) = coA(v)
       ENDDO
      ENDDO

      END


c     ============================================
      subroutine setaux(maxmx,maxmy,mbc,mx,my,xlow,ylow,dx,dy,
     &                  maux,aux)
c     ============================================
c
c     # set auxiliary arrays
c
c     # aux(i,j,1) = Z(x,y) topography
c     #                     (negative below sea level for topoymetry)
c
c     # If icoordsys=2 then lat-lon coordinates on the sphere and
c     #    aux(i,j,2) = area ratio (capacity function -- set mcapa = 2)
c     #    aux(i,j,3) = length ratio for edge
c

      use geoclaw_module
      use topo_module
      use digclaw_module
      use auxinit_module

      implicit double precision (a-h,o-z)

      dimension aux(1-mbc:maxmx+mbc,1-mbc:maxmy+mbc, maux)
      logical use_phi_bed,use_theta_input,friction_correction

      include "call.i"

      if (icoordsys.eq.2) then
         if (mcapa .ne. 2 .or. maux.lt.3) then
            write(6,*) 'ERROR in setaux:  for icoordsys=2'
            write(6,*) '     need mcapa = 2 and maux >= 3'
            write(6,*) '     have mcapa = ',mcapa,'  maux = ',maux
            stop
            endif
         endif

      do j=1-mbc,my+mbc
         ycell = ylow +(j-0.5d0)*dy
         yjm = ylow +(j-1.d0)*dy
         yjp = ylow + j*dy

         do i=1-mbc,mx+mbc
            xcell= xlow + (i- 0.5d0)*dx
            xim = xlow + (i - 1.d0)*dx
            xip = xlow + i*dx

            if (icoordsys.eq.2) then
c           # for lat-lon grid on sphere:
               deg2rad = pi/180.d0
               aux(i,j,2)= deg2rad*Rearth**2*
     &               (sin(yjp*deg2rad)-sin(yjm*deg2rad))/dy
               aux(i,j,3)= yjm*deg2rad
            else
               aux(i,j,2) = 1.d0
               aux(i,j,3) = 1.d0
            endif

            if (mtopofiles.gt.0) then
               topoint=0.d0
               call cellgridintegrate(topoint,xim,xcell,xip,yjm,ycell,
     &           yjp,xlowtopo,ylowtopo,xhitopo,yhitopo,dxtopo,dytopo,
     &           mxtopo,mytopo,mtopo,i0topo,mtopoorder,
     &           mtopofiles,mtoposize,topowork)
               aux(i,j,1) = topoint/(dx*dy*aux(i,j,2))

            else
               aux(i,j,1) = 0.d0
c               # or set-up your own topo
            endif
c        #------- zero aux variables that will be set by files
            do mf = 1,mauxinitfiles
               aux(i,j,iauxinit(mf)) = 0.d0
            enddo
         !--------zero all d-claw aux variables----
            do mf= i_dig,maux
               aux(i,j,mf) = 0.0
            enddo

         enddo
      enddo

c     --------------integrate auxinit files if they exist---------------
      xhigher = xlow + (mx-0.5d0)*dx
      yhigher = ylow + (my-0.5d0)*dy

      do mf =1,mauxinitfiles
         if ((xlow.le.xhiauxinit(mf).and.
     &                  xhigher.ge.xlowauxinit(mf)).and.
     &                  (ylow.le.yhiauxinit(mf).and.
     &                  yhigher.ge.ylowauxinit(mf))) then

            xintlow = dmax1(xlow,xlowauxinit(mf))
            xinthi  = dmin1(xhigher,xhiauxinit(mf))
            istart  = max(1-mbc,int(0.5 + (xintlow-xlow)/dx)-mbc)
            iend    = min(mx+mbc,int(1.0 + (xinthi-xlow)/dx)+mbc)

            yintlow = dmax1(ylow,ylowauxinit(mf))
            yinthi  = dmin1(yhigher,yhiauxinit(mf))
            jstart  = max(1-mbc,int(0.5 + (yintlow-ylow)/dy)-mbc)
            jend    = min(my+mbc,int(1.0 + (yinthi-ylow)/dy)+mbc)

            do i=istart,iend
               x = xlow + (i-0.5d0)*dx
               xim = x - 0.5d0*dx
               xip = x + 0.5d0*dx
               do j=jstart,jend
                  y = ylow + (j-0.5d0)*dy
                  yjm = y - 0.5d0*dy
                  yjp = y + 0.5d0*dy

                  if (xip.gt.xlowauxinit(mf)
     &                     .and.xim.lt.xhiauxinit(mf)
     &                     .and.yjp.gt.ylowauxinit(mf)
     &                     .and.yjm.lt.yhiauxinit(mf)) then

                     xipc=dmin1(xip,xhiauxinit(mf))
                     ximc=dmax1(xim,xlowauxinit(mf))
                     xc=0.5d0*(xipc+ximc)

                     yjpc=dmin1(yjp,yhiauxinit(mf))
                     yjmc=dmax1(yjm,ylowauxinit(mf))
                     yc=0.5d0*(yjmc+yjpc)

                     daux =topointegral(ximc,xc,xipc,yjmc,yc,yjpc,
     &                        xlowauxinit(mf),ylowauxinit(mf),
     &                        dxauxinit(mf),dyauxinit(mf),
     &                        mxauxinit(mf),myauxinit(mf),
     &                        auxinitwork
     &                      (i0auxinit(mf):i0auxinit(mf)+mauxinit(mf)-1)
     &                        ,1)
                     daux=daux/((xipc-ximc)*(yjpc-yjmc)*aux(i,j,2))
                     aux(i,j,iauxinit(mf)) = aux(i,j,iauxinit(mf))+daux
                  endif
               enddo
            enddo
         endif
      enddo

      use_phi_bed = .true.
      use_theta_input = .true.
      do mf = 1,mauxinitfiles
         if (iauxinit(mf).eq.i_phi) use_phi_bed = .false.
         if (iauxinit(mf).eq.i_theta) use_theta_input = .false.
      enddo

      if (use_phi_bed) then
         do j=1-mbc,my+mbc
            do i=1-mbc,mx+mbc
               aux(i,j,i_phi) = phi_bed
            enddo
         enddo
      endif

      if (use_theta_input) then
         do j=1-mbc,my+mbc
            do i=1-mbc,mx+mbc
               aux(i,j,i_theta) = theta_input
            enddo
         enddo
      endif

      friction_correction = .false.
      if (friction_correction) then
        do j=1-mbc+1,my+mbc-1
            do i=1-mbc+1,mx+mbc-1
              b_x = (aux(i+1,j,1)-aux(i-1,j,1))/(2.d0*dx)
              b_y = (aux(i,j+1,1)-aux(i,j-1,1))/(2.d0*dy)
              gradang = atan(sqrt(b_x**2+b_y**2))
              kappa=1.d0
              phi_tread = tan(aux(i,j,i_phi)-gradang)
     &            +2.d0*kappa*tan(gradang)
              aux(i,j,i_phi) = phi_tread
            enddo
         enddo
      endif

c     -----------------------------------------------------------------

      return

c     # output aux array for debugging:
      open(23, file='fort.aux',status='unknown',form='formatted')
      write(23,*) 'Setting aux arrays'
      write(23,*) ' '
      do i=1,mx
        do j=1,my
           write(*,*) i,j,(aux(i,j,m),m=1,maux)
           !write(23,231) i,j,(aux(i,j,m),m=1,maux)
           enddo
        enddo
 231  format(2i4,4d15.3)
      close(23)

      end


  module Mod_lmn_ComputeGradientProjection
   use typre
   use Mod_lmn_BaseElmope
   implicit none
   private
   public SetPointersComputeGradientProjection

   real(rp), allocatable :: wgrpro(:,:)
   real(rp), allocatable :: elrhgr(:,:)
   real(rp), allocatable :: elgrv(:,:,:), elgrt(:,:)

   integer(ip), allocatable :: kfl_IsSet

contains

   !----------------------------------------------------------------------------
   !Setting Pointers
   subroutine SetPointersComputeGradientProjection(itask)
      implicit none
      integer(ip) :: itask
      select case (itask)

      case(0)
         allocate(kfl_IsSet)
         call a%Memor%allocObj(0,'kfl_IsSet','InitProcedurePointer',1)
         kfl_IsSet = -1

      case(1)
         if (kfl_IsSet == -1) then
            kfl_IsSet = 1

            call ConcatenateProcedures(ProcHook%Initializations,AllocateGradProj)
            call ConcatenateProcedures(ProcHook%Finalizations,DeallocateGradProj)

            call ConcatenateProcedures(ProcHook%ElmatsToZero,GradProjElmatsToZero)

            !Now we assembly everything for computing the projection
            call ConcatenateProcedures(ProcHook%InGaussElmatsAssembly,GradProjToElGradProj)

            call ConcatenateProcedures(ProcHook%AssemblyEndite,AssemblyGradProj)
            call ConcatenateProcedures(ProcHook%PostLoop,ProjectGradient)

         endif
      case(100)
         deallocate(kfl_IsSet)
         call a%Memor%deallocObj(0,'kfl_IsSet','InitProcedurePointer',1)

      end select
   end subroutine

   !-------------------------------------------------------------------
   !Gradient Orthogonal Projection calculation

   subroutine AllocateGradProj
      implicit none

      integer(ip) :: npoin,ngrdf
      call a%Mesh%GetNpoin(npoin)

      ngrdf = (e%ndime+1)*e%ndime
      call a%Memor%alloc(ngrdf,npoin,wgrpro,'wgrpro','lmn_EndElmope')
      call a%Memor%alloc(ngrdf,e%mnode,elrhgr,'elrhgr','lmn_EndElmope')
      call a%Memor%alloc(e%ndime,e%ndime,e%mnode,elgrv,'elgrv','lmn_EndElmope')
      call a%Memor%alloc(e%ndime,e%mnode,elgrt,'elgrt','lmn_EndElmope')

      wgrpro = 0.0_rp

   end subroutine

   subroutine DeallocateGradProj
      implicit none
      integer(ip) :: ngrdf

      ngrdf = (e%ndime+1)*e%ndime
      call a%Memor%dealloc(ngrdf,e%mnode,elrhgr,'elrhgr','lmn_EndElmope')
      call a%Memor%dealloc(e%ndime,e%ndime,e%mnode,elgrv,'elgrv','lmn_EndElmope')
      call a%Memor%dealloc(e%ndime,e%mnode,elgrt,'elgrt','lmn_EndElmope')

   end subroutine

   !----------------------------------------------------------
   subroutine GradProjElmatsToZero

      !ElmatsToZero
      elrhgr=0.0_rp
      elgrv=0.0_rp
      elgrt=0.0_rp

   end subroutine

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

   subroutine GradProjToElGradProj

       call grad_proj(e,e%ndime,dvol,grvel,elgrv)
       call grad_proj(e,1_ip,dvol,grtem,elgrt)

   end subroutine

   !----------------------------------------------------------
   subroutine AssemblyGradProj
      implicit none
      integer(ip) :: idime,jdime

      do jdime=1,e%ndime
         do idime=1,e%ndime
            elrhgr(e%ndime*(idime-1)+jdime,1:e%pnode) = elgrv(idime,jdime,1:e%pnode) &
                  + elrhgr(e%ndime*(idime-1)+jdime,1:e%pnode)
         end do
         elrhgr(e%ndime*e%ndime+jdime,1:e%pnode) = elgrt(jdime,1:e%pnode) &
              + elrhgr(e%ndime*e%ndime+jdime,1:e%pnode)
      end do

      !GlobalAssembly

      call a%Mesh%AssemblyToArray(e,size(wgrpro,1),elrhgr,wgrpro)

   end subroutine

   !----------------------------------------------------------
   subroutine ProjectGradient
      implicit none
      integer(ip) :: idime,jdime
      integer(ip) :: ndime,npoin

      call a%Mesh%GetNdime(ndime)
      call a%Mesh%GetNpoin(npoin)

      call a%Project(size(wgrpro,1),wgrpro)

      do idime=1,ndime+1
         do jdime=1,ndime
            a%grprj(idime,jdime,:) = wgrpro(ndime*(idime-1)+jdime,:)
         end do
      end do

      !Dealloc wrepro
      call a%Memor%dealloc((ndime+1)*ndime,npoin,wgrpro,'wgrpro','lmn_EndElmope')

   end subroutine

end module


      real function getz(pval,nt,vr,cdf,zmin,zmax,ltail,ltpar,
     +                   utail,utpar)
C%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
C                                                                      %
C Copyright (C) 1996, The Board of Trustees of the Leland Stanford     %
C Junior University.  All rights reserved.                             %
C                                                                      %
C The programs in GSLIB are distributed in the hope that they will be  %
C useful, but WITHOUT ANY WARRANTY.  No author or distributor accepts  %
C responsibility to anyone for the consequences of using them or for   %
C whether they serve any particular purpose or work at all, unless he  %
C says so in writing.  Everyone is granted permission to copy, modify  %
C and redistribute the programs in GSLIB, but only under the condition %
C that this notice and the above copyright notice remain intact.       %
C                                                                      %
C%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
c-----------------------------------------------------------------------
c
c           Back Transform Univariate Data from Normal Scores
c           *************************************************
c
c This subroutine backtransforms a standard normal deviate from a
c specified back transform table and option for the tails of the
c distribution.  Call once with "first" set to true then set to false
c unless one of the options for the tail changes.
c
c
c
c INPUT VARIABLES:
c
c   pval             probability value to use
c   nt               number of values in the back transform tbale
c   vr(nt)           original data values that were transformed
c   cdf(nt)          the corresponding transformed values
c   zmin,zmax        limits possibly used for linear or power model
c   ltail            option to handle values less than cdf(1)
c   ltpar            parameter required for option ltail
c   utail            option to handle values greater than cdf(nt)
c   utpar            parameter required for option utail
c
c
c
c-----------------------------------------------------------------------
      parameter(EPSLON=1.0e-20)
      dimension vr(nt),cdf(nt)
      real      ltpar,utpar,lambda
      integer   ltail,utail
c
c Value in the lower tail?    1=linear, 2=power, (3 and 4 are invalid):
c
      if(pval.le.cdf(1)) then
                  getz = vr(1)
            if(ltail.eq.1) then
                  getz = powint(0.0,cdf(1),zmin,vr(1),pval,1.0)
            else if(ltail.eq.2) then
                  cpow = 1.0 / ltpar
                  getz = powint(0.0,cdf(1),zmin,vr(1),pval,cpow)
            endif
c
c Value in the upper tail?     1=linear, 2=power, 4=hyperbolic:
c
      else if(pval.ge.cdf(nt)) then
                  cdfhi  = cdf(nt)
                  getz   = vr(nt)
            if(utail.eq.1) then
                  getz   = powint(cdfhi,1.0,vr(nt),zmax,pval,1.0)
            else if(utail.eq.2) then
                  cpow   = 1.0 / utpar
                  getz   = powint(cdfhi,1.0,vr(nt),zmax,pval,cpow)
            else if(utail.eq.4) then
                  lambda = (vr(nt)**utpar)*(1.0-cdf(nt))
                  getz   = (lambda/(1.0-pval))**(1.0/utpar)
            endif
      else
c
c Value within the transformation table:
c
            call locate(cdf,nt,1,nt,pval,j)
            j    = max(min((nt-1),j),1)
            getz = powint(cdf(j),cdf(j+1),vr(j),vr(j+1),pval,1.0)
      endif
      if(getz.lt.zmin) getz = zmin
      if(getz.gt.zmax) getz = zmax
      return
      end


module empirical
implicit none
public:: empirical_relation

contains
subroutine empirical_relation(vsz,vpz,rhoz)bind(c,name="empirical_relation")
  use,intrinsic :: iso_c_binding

  real(c_float), intent(in) ::  vsz
  real(c_float),intent(out) ::vpz,rhoz

  vpz=0.9409 + 2.0947*vsz - 0.8206*vsz**2+ &
          0.2683*vsz**3 - 0.0251*vsz**4
  rhoz=1.6612*vpz- 0.4721*vpz**2 + &
          0.0671*vpz**3 - 0.0043*vpz**4 + &
          0.000106*vpz**5

end subroutine empirical_relation
end module empirical

module sparsemat
use,intrinsic                 :: iso_c_binding
implicit none

real(c_float),ALLOCATABLE     :: val(:)
INTEGER(c_int),ALLOCATABLE    :: rw(:),col(:)
INTEGER(c_int)                :: nonzeros

contains
subroutine aprod(x,y,m,n) ! y = y + A * x
  implicit none
  INTEGER,INTENT(IN)          :: m,n
  real(c_float),INTENT(INOUT) :: y(m),x(n)

  INTEGER                     ::i

  y(1:m) = 0.0
  do i=1,nonzeros
    y(rw(i)) = y(rw(i)) + val(i) * x(col(i))
  enddo
end subroutine aprod

subroutine forward(nx,ny,nz,vr,vt,m,dsyn)
  use empirical,only                     : empirical_relation
  implicit none
  integer(c_int),INTENT(IN)              :: nx,ny,nz,m
  real(c_float),INTENT(IN)               :: vr(nx,ny,nz),vt(nx,ny,nz)
  real(c_float),INTENT(INOUT)            :: dsyn(m)

  ! local variables
  real(c_float)                          :: rho,vp,vs
  real(c_float),ALLOCATABLE              :: drho(:)
  INTEGER(c_int)                         :: i,j,k,nn,n

  n = (nx -2) * (ny -2) * (nz -1)
  ALLOCATE(drho(n))

  ! compute density difference
  do k=1,nz-1
    do j=1,ny-2
      do i=1,nx-2
        nn = (k-1) * (nx-2) * (ny -2) + (j-1) * (nx-2) + i
        vs = vr(i+1,j+1,k)
        call empirical_relation(vs,vp,rho)
        drho(nn) = rho
        vs = vt(i+1,j+1,k)
        call empirical_relation(vs,vp,rho)
        drho(nn) = -drho(nn) + rho
      enddo
    enddo
  enddo

  ! compute gravity
  dsyn(1:m) = 0.0
  call aprod(drho,dsyn,m,n)

  DEALLOCATE(drho)
  return;
end subroutine forward

end module sparsemat

program main
  use sparsemat
  implicit none

  CHARACTER(50)               :: refmod,truemod,paramfile,obsgrav,gravmat
  CHARACTER(50)               :: outfile,flag_remove_mean
  real(c_float),ALLOCATABLE   :: vr(:,:,:),vt(:,:,:),dsyn(:),lat(:),lon(:)
  INTEGER(c_int)              :: nx,ny,nz,m,eof
  real(c_float)               :: a,b,c,mean
  INTEGER(c_int)              :: i,j,k,dataid,num,rm_mean
  CHARACTER(256)              :: line
  CHARACTER                   :: dummy

  ! extract input args
  if(iargc() /= 7) then
    print*,"please run ./this paramfile refmod truemod obsgrav gravmat &
            remove_mean(false or true) outfile"
    stop
  else
    call getarg(1,paramfile)
    call getarg(2,refmod)
    call getarg(3,truemod)
    call getarg(4,obsgrav)
    call getarg(5,gravmat)
    call getarg(6,flag_remove_mean)
    call getarg(7,outfile)

    if(flag_remove_mean == "true") then
        rm_mean = 1
    else if (flag_remove_mean == "false")then
        rm_mean = 0
    else
        print*, "remove_mean should be one of [true,false]!"
        stop
    endif
  endif

  ! read no. of nodes in each direction
  open(11,file=paramfile)
  read(11,*)nx,ny,nz
  close(11)
  ALLOCATE(vr(nx,ny,nz),vt(nx,ny,nz))

  ! read reference model,format is same to MOD
  open(11,file=refmod)
  read(11,*)(vr(1,1,i),i=1,nz)
  do k=1,nz
    do j=1,ny
      read(11,*)(vr(i,j,k),i=1,nx)
    enddo
    ! remove mean if required
    if(rm_mean == 1) then
      mean = sum(vr(2:nx-1,2:ny-1,k)) / real((nx-2)*(ny-2))
      vr(:,:,k) = mean
    endif
  enddo
  close(11)

  ! read true model( read from results)
  open(11,file=truemod)
  do k=1,nz
    do j=1,ny
      do i=1,nx
        read(11,*)a,b,c,vt(i,j,k)
      enddo
    enddo
  enddo
  close(11)
  print*,'finish reading reference and final model'

  ! read gravity data
  m = 0
  open(11,file=obsgrav)
  do
    read(11,*,iostat=eof)
    if(eof==0) then
      m = m + 1
    else
      exit
    endif
  enddo
  close(11)
  ALLOCATE(lon(m),lat(m),dsyn(m))
  open(11,file=obsgrav)
  do i=1,m
    read(11,*)lon(i),lat(i)
  enddo
  close(11)
  print*,'finish reading gravity data'

  ! read gravity matrix
  nonzeros = 0
  open(11,file=gravmat)
  do
    read(11,'(a)',iostat=eof) line
    if(eof==0) then
      if(line(1:1) /= '#') nonzeros = nonzeros + 1
    else
      exit
    endif
  enddo
  close(11)
  ALLOCATE(rw(nonzeros),val(nonzeros),col(nonzeros))
  i = 1
  open(11,file=gravmat)
  do
    read(11,'(a)',iostat=eof) line
    if(eof/=0) exit
    read(line,*) dummy,dataid,num
    rw(i:i+num-1) = dataid + 1
    do j=0,num - 1
      read(11,*)col(i + j),val(i + j)
      col(i+j) = col(i+j) + 1
    enddo
    i = i + num
  enddo
  close(11)
  print*,'finish reading gravity matrix, now begin forward computing'

  ! compute gravity
  call forward(nx,ny,nz,vr,vt,m,dsyn)
  mean = sum(dsyn(1:m)) / real(m)
  dsyn(1:m) = dsyn(1:m) - mean

  ! write
  open(11,file=outfile)
  do i=1,m
    write(11,'(3f10.4)')lon(i),lat(i),dsyn(i)
  enddo
  close(11)

  DEALLOCATE(rw,col,val,lat,lon,vr,vt,dsyn)
end program main


      PROGRAM ADVECT3D
      IMPLICIT NONE
      INTEGER nx, ng, tt

      parameter (nx = 256)
      parameter (ng = 9)
      parameter (tt = 1)
        REAL x(1-ng:nx+ng), y(1-ng:nx+ng), z(1-ng:nx+ng)
	REAL dx, dis
	REAL pi, Ad1, Ad2
	REAL  A0(1-ng:nx+1+ng, 1-ng:nx+1+ng)
	REAL  An(1-ng:nx  +ng, 1-ng:nx+  ng,1-ng:nx+  ng)
	REAL  Ao(1-ng:nx  +ng, 1-ng:nx+  ng,1-ng:nx+  ng)
        REAL  Ai(1-ng:nx  +ng, 1-ng:nx+  ng,1-ng:nx+  ng)
	REAL   u(1-ng:nx  +ng, 1-ng:nx+1+ng,1-ng:nx+  ng)
	REAL   v(1-ng:nx  +ng, 1-ng:nx+  ng,1-ng:nx+1+ng)
	REAL   w(1-ng:nx+1+ng, 1-ng:nx+  ng,1-ng:nx+  ng)
	REAL  u0(1-ng:nx  +ng, 1-ng:nx+1+ng,1-ng:nx+  ng)
	REAL  v0(1-ng:nx  +ng, 1-ng:nx+  ng,1-ng:nx+1+ng)
	REAL  w0(1-ng:nx+1+ng, 1-ng:nx+  ng,1-ng:nx+  ng)
	REAL  ut(1-ng:nx  +ng, 1-ng:nx+1+ng,1-ng:nx+  ng)
	REAL  vt(1-ng:nx  +ng, 1-ng:nx+  ng,1-ng:nx+1+ng)
	REAL  wt(1-ng:nx+1+ng, 1-ng:nx+  ng,1-ng:nx+  ng)
	REAL  uh(1-ng:nx  +ng, 1-ng:nx+1+ng,1-ng:nx+  ng)
	REAL  vh(1-ng:nx  +ng, 1-ng:nx+  ng,1-ng:nx+1+ng)
	REAL  wh(1-ng:nx+1+ng, 1-ng:nx+  ng,1-ng:nx+  ng)
        REAL X0, Y0, Z0, rad
        REAL dt
        REAL maxi
	INTEGER i,j,k,t,m, imgT
        INTEGER iloc, jloc, kloc
	real xl, yl, zl, third, half
        PARAMETER (dt = 0.005)
        PARAMETER (pi = 3.1415926)
        PARAMETER (X0 = 0.00)
	PARAMETER (Y0 = 0.00)
	PARAMETER (Z0 = 0.00)
        PARAMETER (rad = 0.15)
        imgT = Tt/4
        dx = 1./REAL(nx)
        maxi = 0.0
	third = 1./3.
	half = 0.5

	do i=1-ng,nx+ng
	   x(i) = -.5 + dx*REAL(i)
	   y(i) = -.5 + dx*REAL(i)
	   z(i) = -.5 + dx*REAL(i)
	end do
	xl = REAL(nx) * dx * .5
	yl = REAL(nx) * dx * .5
	zl = REAL(nx) * dx * .5

        do j=1,nx
          do i=1,nx
            do k=1,nx
              u0(k,i,j) =  1.0 * (x(k) - 0.5*dx)
              v0(k,i,j) = 0.
              w0(k,i,j) = -1.0 * (z(i) - 0.5*dx)
            end do
          end do
        end do

        Ad1 = 0.
	 do j=1,nx
           do i=1,nx
	     do k=1,nx
	     dis = SQRT( (x(i) -.5*dx - X0)**2 +
     +                   (y(j) -.5*dx - Y0)**2 +
     +                   (z(k) -.5*dx - Z0)**2)
                Ao(k,i,j) = (20. * 0.5 * (1. + COS(dis*pi/rad)))*
     +                    (.5+sign(.5,rad-dis))
              Ai(k,i,j) = Ao(k,i,j)
              An(k,i,j) = 0.0
              Ad1 = Ad1 + Ao(k,i,j)
	    end do
	  end do
	end do
	do i=1-ng,nx+ng
           do k=1-ng,nx+ng
              do m = 0, 1-ng
                 Ao(k,i,m) = Ao(k,i,1)
              enddo
              do m = nx + 1, nx + ng
                 Ao(k,i,m) = Ao(k,i,nx)
              enddo
           enddo
        enddo
        do j=1-ng,nx+ng
           do k=1-ng,nx+ng
	   do m = 0, 1-ng
              Ao(k,m,j) = Ao(k,1 ,j)
	   enddo
           do m = nx+1, nx+ng
              Ao(k,m,j) = Ao(k,nx,j)
           enddo
        enddo

           do i=1,nx
	   do k=1-ng,nx+ng
              maxi = MAX(maxi,Ao(k,i,j))
	      if(Ao(k,i,j) .EQ. maxi) then
		 iloc = i
		 jloc = j
		 kloc = k
	      endif
           end do
           end do
        end do
         write(*,*) maxi, 'max val start ',iloc,jloc,kloc
        maxi = 0.0
	print *, '( nx, ng, tt ) = ', '(', nx, ',', ng, ',', tt, ')'
        write (*,*) Tt
        do t=1, 5
            call twostages(Ao, An, u0, v0, w0, u0, v0, w0,
     &                      dt, dx, dx, dx, nx, nx, nx, ng)

            do j = 1, nx
               do i = 1, nx
                  do k = 1, nx
                     Ao(k,i,j) = An(k,i,j)
                  enddo
               enddo
            enddo
        end do
        write(*,*) An(kloc,jloc,iloc), ' val @ finish for initial max '
        Ad2 = 0.
        do j=1,nx
          do i=1,nx
	   do k=1-ng,nx+ng
              maxi = MAX(maxi,Ao(k,i,j))
	      if(Ao(k,i,j) .EQ. maxi) then
		 iloc = i
		 jloc = j
		 kloc = k
	      endif
	      Ad2 = Ad2 + An(k,i,j)
           end do
          end do
        end do
        write(*,*) maxi, 'max val finish ',iloc,jloc
        maxi = 0.0
        do j = 1, nx
           do i = 1, nx
              do k = 1, nx
                 Ai(k, i, j) = An(k, i, k) - Ai(k, i, j)
              enddo
           enddo
        enddo
        do j=1,nx
          do i=1,nx
	    do k=1-ng,nx+ng
              maxi = MAX(maxi,Ai(k,i,j))
	      if(Ai(k,i,j) .EQ. maxi) then
		 iloc = i
		 jloc = j
		 kloc = k
	      endif
           end do
          end do
        end do
         write(*,*) 'max error finish: ',maxi,iloc,jloc
         write(*,*) 'Starting amount:  ',Ad1
         write(*,*) 'Finishing amount: ',Ad2
         write(*,*) 'Percent conserved: ',Ad2/Ad1 * 100.

       END