subroutine cc_abscissas ( n, x )

!*****************************************************************************80
!
!! CC_ABSCISSAS computes the Clenshaw Curtis abscissas.
!
!  Discussion:
!
!    The interval is [ -1, 1 ].
!
!    The abscissas are the cosines of equally spaced angles between
!    180 and 0 degrees, including the endpoints.
!
!      X(I) = cos ( ( ORDER - I ) * PI / ( ORDER - 1 ) )
!
!    except for the basic case ORDER = 1, when
!
!      X(1) = 0.
!
!    If the value of ORDER is increased in a sensible way, then
!    the new set of abscissas will include the old ones.  One such
!    sequence would be ORDER(K) = 2*K+1 for K = 0, 1, 2, ...
!
!    When doing interpolation with Lagrange polynomials, the Clenshaw Curtis
!    abscissas can be a better choice than regularly spaced abscissas.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    04 December 2007
!
!  Author:
!
!    John Burkardt
!
!  Reference:
!
!    Charles Clenshaw, Alan Curtis,
!    A Method for Numerical Integration on an Automatic Computer,
!    Numerische Mathematik,
!    Volume 2, Number 1, December 1960, pages 197-205.
!
!    Philip Davis, Philip Rabinowitz,
!    Methods of Numerical Integration,
!    Second Edition,
!    Dover, 2007,
!    ISBN: 0486453391,
!    LC: QA299.3.D28.
!
!    Joerg Waldvogel,
!    Fast Construction of the Fejer and Clenshaw-Curtis Quadrature Rules,
!    BIT Numerical Mathematics,
!    Volume 43, Number 1, 2003, pages 1-18.
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) N, the order of the rule.
!
!    Output, real ( kind = 8 ) X(N), the abscissas.
!
  implicit none

  integer ( kind = 4 ) n

  integer ( kind = 4 ) i
  real ( kind = 8 ), parameter :: pi = 3.141592653589793D+00
  real ( kind = 8 ) theta(n)
  real ( kind = 8 ) x(n)

  if ( n < 1 ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'CC_ABSCISSA - Fatal error!'
    write ( *, '(a)' ) '  N < 1.'
    stop
  end if

  if ( n == 1 ) then
    x(1) = 0.0D+00
    return
  end if

  do i = 1, n
    theta(i) = real ( n - i, kind = 8 ) * pi &
             / real ( n - 1, kind = 8 )
  end do

  x(1:n) = cos ( theta(1:n) )

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

!*****************************************************************************80
!
!! CC_ABSCISSAS_AB computes Clenshaw Curtis abscissas for the interval [A,B].
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    29 December 2007
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, real ( kind = 8 ) A, B, the endpoints of the interval.
!
!    Input, integer ( kind = 4 ) N, the order of the rule.
!
!    Output, real ( kind = 8 ) X(N), the abscissas.
!
  implicit none

  integer ( kind = 4 ) n

  real ( kind = 8 ) a
  real ( kind = 8 ) b
  integer ( kind = 4 ) i
  real ( kind = 8 ), parameter :: pi = 3.141592653589793D+00
  real ( kind = 8 ) theta(n)
  real ( kind = 8 ) x(n)

  if ( n < 1 ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'CC_ABSCISSAS_AB - Fatal error!'
    write ( *, '(a)' ) '  N < 1.'
    stop
  end if

  if ( n == 1 ) then
    x(1) = 0.5D+00 * ( b + a )
    return
  end if

  do i = 1, n
    theta(i) = real ( n - i, kind = 8 ) * pi &
             / real ( n - 1, kind = 8 )
  end do

  x(1:n) = 0.5D+00 * ( ( b + a ) + ( b - a ) * cos ( theta(1:n) ) )

  return
end
subroutine f1_abscissas ( n, x )

!*****************************************************************************80
!
!! F1_ABSCISSAS computes Fejer type 1 abscissas.
!
!  Discussion:
!
!    The interval is [ -1, +1 ].
!
!    The abscissas are the cosines of equally spaced angles, which
!    are the midpoints of N equal intervals between 0 and PI.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    29 December 2007
!
!  Author:
!
!    John Burkardt
!
!  Reference:
!
!    Philip Davis, Philip Rabinowitz,
!    Methods of Numerical Integration,
!    Second Edition,
!    Dover, 2007,
!    ISBN: 0486453391,
!    LC: QA299.3.D28.
!
!    Walter Gautschi,
!    Numerical Quadrature in the Presence of a Singularity,
!    SIAM Journal on Numerical Analysis,
!    Volume 4, Number 3, 1967, pages 357-362.
!
!    Joerg Waldvogel,
!    Fast Construction of the Fejer and Clenshaw-Curtis Quadrature Rules,
!    BIT Numerical Mathematics,
!    Volume 43, Number 1, 2003, pages 1-18.
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) N, the order of the rule.
!
!    Output, real ( kind = 8 ) X(N), the abscissas.
!
  implicit none

  integer ( kind = 4 ) n

  integer ( kind = 4 ) i
  real ( kind = 8 ) :: pi = 3.141592653589793D+00
  real ( kind = 8 ) theta(n)
  real ( kind = 8 ) x(n)

  if ( n < 1 ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'F1_ABSCISSAS - Fatal error!'
    write ( *, '(a)' ) '  N < 1.'
    stop
  end if

  if ( n == 1 ) then
    x(1) = 0.0D+00
    return
  end if

  do i = 1, n
    theta(i) = real ( 2 * n - 2 * i + 1, kind = 8 ) * pi &
             / real ( 2 * n,             kind = 8 )
  end do

  x(1:n) = cos ( theta(1:n) )

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

!*****************************************************************************80
!
!! F1_ABSCISSAS_AB computes Fejer type 1 abscissas for the interval [A,B].
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    29 December 2007
!
!  Author:
!
!    John Burkardt
!
!  Reference:
!
!    Philip Davis, Philip Rabinowitz,
!    Methods of Numerical Integration,
!    Second Edition,
!    Dover, 2007,
!    ISBN: 0486453391,
!    LC: QA299.3.D28.
!
!    Walter Gautschi,
!    Numerical Quadrature in the Presence of a Singularity,
!    SIAM Journal on Numerical Analysis,
!    Volume 4, Number 3, 1967, pages 357-362.
!
!    Joerg Waldvogel,
!    Fast Construction of the Fejer and Clenshaw-Curtis Quadrature Rules,
!    BIT Numerical Mathematics,
!    Volume 43, Number 1, 2003, pages 1-18.
!
!  Parameters:
!
!    Input, real ( kind = 8 ) A, B, the endpoints of the interval.
!
!    Input, integer ( kind = 4 ) N, the order of the rule.
!
!    Output, real ( kind = 8 ) X(N), the abscissas.
!
  implicit none

  integer ( kind = 4 ) n

  real ( kind = 8 ) a
  real ( kind = 8 ) b
  integer ( kind = 4 ) i
  real ( kind = 8 ) :: pi = 3.141592653589793D+00
  real ( kind = 8 ) theta(n)
  real ( kind = 8 ) x(n)

  if ( n < 1 ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'F1_ABSCISSAS_AB - Fatal error!'
    write ( *, '(a)' ) '  N < 1.'
    stop
  end if

  if ( n == 1 ) then
    x(1) = 0.5D+00 * ( b + a )
    return
  end if

  do i = 1, n
    theta(i) = real ( 2 * n - 2 * i + 1, kind = 8 ) * pi &
             / real ( 2 * n,             kind = 8 )
  end do

  x(1:n) = 0.5D+00 * ( ( b + a ) + ( b - a ) * cos ( theta(1:n) ) )

  return
end
subroutine f2_abscissas ( n, x )

!*****************************************************************************80
!
!! F2_ABSCISSAS computes Fejer Type 2 abscissas.
!
!  Discussion:
!
!    The interval is [-1,+1].
!
!    The abscissas are the cosines of equally spaced angles.
!    The angles are computed as N+2 equally spaced values between 0 and PI,
!    but with the first and last angle omitted.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    29 December 2007
!
!  Author:
!
!    John Burkardt
!
!  Reference:
!
!    Philip Davis, Philip Rabinowitz,
!    Methods of Numerical Integration,
!    Second Edition,
!    Dover, 2007,
!    ISBN: 0486453391,
!    LC: QA299.3.D28.
!
!    Walter Gautschi,
!    Numerical Quadrature in the Presence of a Singularity,
!    SIAM Journal on Numerical Analysis,
!    Volume 4, Number 3, 1967, pages 357-362.
!
!    Joerg Waldvogel,
!    Fast Construction of the Fejer and Clenshaw-Curtis Quadrature Rules,
!    BIT Numerical Mathematics,
!    Volume 43, Number 1, 2003, pages 1-18.
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) N, the order of the rule.
!
!    Output, real ( kind = 8 ) X(N), the abscissas.
!
  implicit none

  integer ( kind = 4 ) n

  integer ( kind = 4 ) i
  real ( kind = 8 ) :: pi = 3.141592653589793D+00
  real ( kind = 8 ) theta(n)
  real ( kind = 8 ) x(n)

  if ( n < 1 ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'F2_ABSCISSAS - Fatal error!'
    write ( *, '(a)' ) '  N < 1.'
    stop
  end if

  if ( n == 1 ) then
    x(1) = 0.0D+00
    return
  else if ( n == 2 ) then
    x(1) = -0.5D+00
    x(2) =  0.5D+00
    return
  end if

  do i = 1, n
    theta(i) = real ( n + 1 - i, kind = 8 ) * pi &
             / real ( n + 1,     kind = 8 )
  end do

  x(1:n) = cos ( theta(1:n) )

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

!*****************************************************************************80
!
!! F2_ABSCISSAS_AB computes Fejer Type 2 abscissas for the interval [A,B].
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    29 December 2007
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, real ( kind = 8 ) A, B, the endpoints of the interval.
!
!    Input, integer ( kind = 4 ) N, the order of the rule.
!
!    Output, real ( kind = 8 ) X(N), the abscissas.
!
  implicit none

  integer ( kind = 4 ) n

  real ( kind = 8 ) a
  real ( kind = 8 ) b
  integer ( kind = 4 ) i
  real ( kind = 8 ) :: pi = 3.141592653589793D+00
  real ( kind = 8 ) theta(n)
  real ( kind = 8 ) x(n)

  if ( n < 1 ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'F2_ABSCISSAS_AB - Fatal error!'
    write ( *, '(a)' ) '  N < 1.'
    stop
  end if

  do i = 1, n
    theta(i) = real ( n + 1 - i, kind = 8 ) * pi &
             / real ( n + 1,     kind = 8 )
  end do

  x(1:n) = 0.5D+00 * ( ( b + a ) + ( b - a ) * cos ( theta(1:n) ) )

  return
end
subroutine interp_lagrange ( m, data_num, t_data, p_data, interp_num, &
  t_interp, p_interp )

!*****************************************************************************80
!
!! INTERP_LAGRANGE: Lagrange polynomial interpolant to a curve in M dimensions.
!
!  Discussion:
!
!    From a space of M dimensions, we are given a sequence of
!    DATA_NUM points, which are presumed to be successive samples
!    from a curve of points P.
!
!    We are also given a parameterization of this data, that is,
!    an associated sequence of DATA_NUM values of a variable T.
!
!    Thus, we have a sequence of values P(T), where T is a scalar,
!    and each value of P is of dimension M.
!
!    We are then given INTERP_NUM values of T, for which values P
!    are to be produced, by linear interpolation of the data we are given.
!
!    The user may request extrapolation.  This occurs whenever
!    a T_INTERP value is less than the minimum T_DATA or greater than the
!    maximum T_DATA.  In that case, extrapolation is used.
!
!    For each spatial component, a polynomial of degree
!    ( DATA_NUM - 1 ) is generated for the interpolation.  In most cases,
!    such a polynomial interpolant begins to oscillate as DATA_NUM
!    increases, even if the original data seems well behaved.  Typically,
!    values of DATA_NUM should be no greater than 10!
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    03 December 2007
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) M, the spatial dimension.
!
!    Input, integer ( kind = 4 ) DATA_NUM, the number of data points.
!
!    Input, real ( kind = 8 ) T_DATA(DATA_NUM), the value of the
!    independent variable at the sample points.
!
!    Input, real ( kind = 8 ) P_DATA(M,DATA_NUM), the value of the
!    dependent variables at the sample points.
!
!    Input, integer ( kind = 4 ) INTERP_NUM, the number of points
!    at which interpolation is to be done.
!
!    Input, real ( kind = 8 ) T_INTERP(INTERP_NUM), the value of the
!    independent variable at the interpolation points.
!
!    Output, real ( kind = 8 ) P_INTERP(M,DATA_NUM), the interpolated
!    values of the dependent variables at the interpolation points.
!
  implicit none

  integer ( kind = 4 ) data_num
  integer ( kind = 4 ) m
  integer ( kind = 4 ) interp_num

  real ( kind = 8 ) l_interp(data_num,interp_num)
  real ( kind = 8 ) p_data(m,data_num)
  real ( kind = 8 ) p_interp(m,interp_num)
  real ( kind = 8 ) t_data(data_num)
  real ( kind = 8 ) t_interp(interp_num)
!
!  Evaluate the DATA_NUM Lagrange polynomials associated with T_DATA(1:DATA_NUM)
!  for the interpolation points T_INTERP(1:INTERP_NUM).
!
  call lagrange_value ( data_num, t_data, interp_num, t_interp, l_interp )
!
!  Multiply P_DATA(1:M,1:DATA_NUM) * L_INTERP(1:DATA_NUM,1:INTERP_NUM)
!  to get P_INTERP(1:M,1:INTERP_NUM).
!
  p_interp(1:m,1:interp_num) = &
    matmul ( p_data(1:m,1:data_num), l_interp(1:data_num,1:interp_num) )

  return
end
subroutine interp_linear ( m, data_num, t_data, p_data, interp_num, &
  t_interp, p_interp )

!*****************************************************************************80
!
!! INTERP_LINEAR: piecewise linear interpolation to a curve in M dimensions.
!
!  Discussion:
!
!    From a space of M dimensions, we are given a sequence of
!    DATA_NUM points, which are presumed to be successive samples
!    from a curve of points P.
!
!    We are also given a parameterization of this data, that is,
!    an associated sequence of DATA_NUM values of a variable T.
!    The values of T are assumed to be strictly increasing.
!
!    Thus, we have a sequence of values P(T), where T is a scalar,
!    and each value of P is of dimension M.
!
!    We are then given INTERP_NUM values of T, for which values P
!    are to be produced, by linear interpolation of the data we are given.
!
!    Note that the user may request extrapolation.  This occurs whenever
!    a T_INTERP value is less than the minimum T_DATA or greater than the
!    maximum T_DATA.  In that case, linear extrapolation is used.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    03 December 2007
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) M, the spatial dimension.
!
!    Input, integer ( kind = 4 ) DATA_NUM, the number of data points.
!
!    Input, real ( kind = 8 ) T_DATA(DATA_NUM), the value of the
!    independent variable at the sample points.  The values of T_DATA
!    must be strictly increasing.
!
!    Input, real ( kind = 8 ) P_DATA(M,DATA_NUM), the value of the
!    dependent variables at the sample points.
!
!    Input, integer ( kind = 4 ) INTERP_NUM, the number of points
!    at which interpolation is to be done.
!
!    Input, real ( kind = 8 ) T_INTERP(INTERP_NUM), the value of the
!    independent variable at the interpolation points.
!
!    Output, real ( kind = 8 ) P_INTERP(M,DATA_NUM), the interpolated
!    values of the dependent variables at the interpolation points.
!
  implicit none

  integer ( kind = 4 ) data_num
  integer ( kind = 4 ) m
  integer ( kind = 4 ) interp_num

  integer ( kind = 4 ) interp
  integer ( kind = 4 ) left
  real ( kind = 8 ) p_data(m,data_num)
  real ( kind = 8 ) p_interp(m,interp_num)
  logical r8vec_ascends_strictly
  integer ( kind = 4 ) right
  real ( kind = 8 ) t
  real ( kind = 8 ) t_data(data_num)
  real ( kind = 8 ) t_interp(interp_num)

  if ( .not. r8vec_ascends_strictly ( data_num, t_data ) ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'INTERP_LINEAR - Fatal error!'
    write ( *, '(a)' ) &
      '  Independent variable array T_DATA is not strictly increasing.'
    stop
  end if

  do interp = 1, interp_num

    t = t_interp(interp)
!
!  Find the interval [ TDATA(LEFT), TDATA(RIGHT) ] that contains, or is
!  nearest to, TVAL.
!
    call r8vec_bracket ( data_num, t_data, t, left, right )

    p_interp(1:m,interp) = &
      ( ( t_data(right) - t                ) * p_data(1:m,left)   &
      + (                 t - t_data(left) ) * p_data(1:m,right) ) &
      / ( t_data(right)     - t_data(left) )

  end do

  return
end
subroutine interp_nearest ( m, data_num, t_data, p_data, interp_num, &
  t_interp, p_interp )

!*****************************************************************************80
!
!! INTERP_NEAREST: Nearest neighbor interpolation to a curve in M dimensions.
!
!  Discussion:
!
!    From a space of M dimensions, we are given a sequence of
!    DATA_NUM points, which are presumed to be successive samples
!    from a curve of points P.
!
!    We are also given a parameterization of this data, that is,
!    an associated sequence of DATA_NUM values of a variable T.
!
!    Thus, we have a sequence of values P(T), where T is a scalar,
!    and each value of P is of dimension M.
!
!    We are then given INTERP_NUM values of T, for which values P
!    are to be produced, by nearest neighbor interpolation.
!
!    The user may request extrapolation.  This occurs whenever
!    a T_INTERP value is less than the minimum T_DATA or greater than the
!    maximum T_DATA.  In that case, extrapolation is used.
!
!    The resulting interpolant is piecewise constant.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    01 July 2012
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) M, the spatial dimension.
!
!    Input, integer ( kind = 4 ) DATA_NUM, the number of data points.
!
!    Input, real ( kind = 8 ) T_DATA(DATA_NUM), the value of the
!    independent variable at the sample points.
!
!    Input, real ( kind = 8 ) P_DATA(M,DATA_NUM), the value of the
!    dependent variables at the sample points.
!
!    Input, integer ( kind = 4 ) INTERP_NUM, the number of points
!    at which interpolation is to be done.
!
!    Input, real ( kind = 8 ) T_INTERP(INTERP_NUM), the value of the
!    independent variable at the interpolation points.
!
!    Output, real ( kind = 8 ) P_INTERP(M,DATA_NUM), the interpolated
!    values of the dependent variables at the interpolation points.
!
  implicit none

  integer ( kind = 4 ) data_num
  integer ( kind = 4 ) m
  integer ( kind = 4 ) interp_num

  integer ( kind = 4 ) jd
  integer ( kind = 4 ) ji
  real ( kind = 8 ) p_data(m,data_num)
  real ( kind = 8 ) p_interp(m,interp_num)
  integer ( kind = 4 ) r8vec_sorted_nearest
  real ( kind = 8 ) t_data(data_num)
  real ( kind = 8 ) t_interp(interp_num)
!
!  For each interpolation point, find the index of the nearest data point.
!
  do ji = 1, interp_num
    jd = r8vec_sorted_nearest ( data_num, t_data, t_interp(ji) )
    p_interp(1:m,ji) = p_data(1:m,jd)
  end do

  return
end
subroutine lagrange_value ( data_num, t_data, interp_num, t_interp, l_interp )

!*****************************************************************************80
!
!! LAGRANGE_VALUE evaluates the Lagrange polynomials.
!
!  Discussion:
!
!    Given DATA_NUM distinct abscissas, T_DATA(1:DATA_NUM),
!    the I-th Lagrange polynomial L(I)(T) is defined as the polynomial of
!    degree DATA_NUM - 1 which is 1 at T_DATA(I) and 0 at the DATA_NUM - 1
!    other abscissas.
!
!    A formal representation is:
!
!      L(I)(T) = Product ( 1 <= J <= DATA_NUM, I /= J )
!       ( T - T(J) ) / ( T(I) - T(J) )
!
!    This routine accepts a set of INTERP_NUM values at which all the Lagrange
!    polynomials should be evaluated.
!
!    Given data values P_DATA at each of the abscissas, the value of the
!    Lagrange interpolating polynomial at each of the interpolation points
!    is then simple to compute by matrix multiplication:
!
!      P_INTERP(1:INTERP_NUM) =
!        P_DATA(1:DATA_NUM) * L_INTERP(1:DATA_NUM,1:INTERP_NUM)
!
!    or, in the case where P is multidimensional:
!
!      P_INTERP(1:M,1:INTERP_NUM) =
!        P_DATA(1:M,1:DATA_NUM) * L_INTERP(1:DATA_NUM,1:INTERP_NUM)
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    03 December 2007
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) DATA_NUM, the number of data points.
!    DATA_NUM must be at least 1.
!
!    Input, real ( kind = 8 ) T_DATA(DATA_NUM), the data points.
!
!    Input, integer ( kind = 4 ) INTERP_NUM, the number of
!    interpolation points.
!
!    Input, real ( kind = 8 ) T_INTERP(INTERP_NUM), the
!    interpolation points.
!
!    Output, real ( kind = 8 ) L_INTERP(DATA_NUM,INTERP_NUM), the values
!    of the Lagrange polynomials at the interpolation points.
!
  implicit none

  integer ( kind = 4 ) data_num
  integer ( kind = 4 ) interp_num

  integer ( kind = 4 ) i
  integer ( kind = 4 ) j
  real ( kind = 8 ) l_interp(data_num,interp_num)
  real ( kind = 8 ) t_data(data_num)
  real ( kind = 8 ) t_interp(interp_num)
!
!  Evaluate the polynomial.
!
  l_interp(1:data_num,1:interp_num) = 1.0D+00

  do i = 1, data_num

    do j = 1, data_num

      if ( j /= i ) then

        l_interp(i,1:interp_num) = l_interp(i,1:interp_num) &
          * ( t_interp(1:interp_num) - t_data(j) ) / ( t_data(i) - t_data(j) )

      end if

    end do

  end do

  return
end
subroutine ncc_abscissas ( n, x )

!*****************************************************************************80
!
!! NCC_ABSCISSAS computes the Newton Cotes Closed abscissas.
!
!  Discussion:
!
!    The interval is [ -1, 1 ].
!
!    The abscissas are the equally spaced points between -1 and 1,
!    including the endpoints.
!
!    If N is 1, however, the single abscissas is X = 0.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    29 December 2007
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) N, the order of the rule.
!
!    Output, real ( kind = 8 ) X(N), the abscissas.
!
  implicit none

  integer ( kind = 4 ) n

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

  if ( n < 1 ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'NCC_ABSCISSAS - Fatal error!'
    write ( *, '(a)' ) '  N < 1.'
    stop
  end if

  if ( n == 1 ) then
    x(1) = 0.0D+00
    return
  end if

  do i = 1, n
    x(i) = ( real ( n - i,     kind = 8 ) * ( -1.0D+00 )   &
           + real (     i - 1, kind = 8 ) * ( +1.0D+00 ) ) &
           / real ( n     - 1, kind = 8 )
  end do

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

!*****************************************************************************80
!
!! NCC_ABSCISSAS_AB computes the Newton Cotes Closed abscissas for [A,B].
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    29 December 2007
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, real ( kind = 8 ) A, B, the endpoints of the interval.
!
!    Input, integer ( kind = 4 ) N, the order of the rule.
!
!    Output, real ( kind = 8 ) X(N), the abscissas.
!
  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
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'NCC_ABSCISSAS_AB - Fatal error!'
    write ( *, '(a)' ) '  N < 1.'
    stop
  end if

  if ( n == 1 ) then
    x(1) = 0.5D+00 * ( b + a )
    return
  end if

  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

  return
end
subroutine nco_abscissas ( n, x )

!*****************************************************************************80
!
!! NCO_ABSCISSAS computes the Newton Cotes Open abscissas.
!
!  Discussion:
!
!    The interval is [ -1, 1 ].
!
!    The abscissas are the equally spaced points between -1 and 1,
!    not including the endpoints.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    29 December 2007
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) N, the order of the rule.
!
!    Output, real ( kind = 8 ) X(N), the abscissas.
!
  implicit none

  integer ( kind = 4 ) n

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

  if ( n < 1 ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'NCO_ABSCISSAS - Fatal error!'
    write ( *, '(a)' ) '  N < 1.'
    stop
  end if

  do i = 1, n
    x(i) = ( real ( n - i + 1, kind = 8 ) * ( -1.0D+00 )   &
           + real (     i,     kind = 8 ) * ( +1.0D+00 ) ) &
           / real ( n     + 1, kind = 8 )
  end do

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

!*****************************************************************************80
!
!! NCO_ABSCISSAS_AB computes the Newton Cotes Open abscissas for [A,B].
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    29 December 2007
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, real ( kind = 8 ) A, B, the endpoints of the interval.
!
!    Input, integer ( kind = 4 ) N, the order of the rule.
!
!    Output, real ( kind = 8 ) X(N), the abscissas.
!
  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
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'NCO_ABSCISSAS_AB - Fatal error!'
    write ( *, '(a)' ) '  N < 1.'
    stop
  end if

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

  return
end
subroutine parameterize_arc_length ( m, data_num, p_data, t_data )

!*****************************************************************************80
!
!! PARAMETERIZE_ARC_LENGTH parameterizes data by pseudo-arclength.
!
!  Discussion:
!
!    A parameterization is required for the interpolation.
!
!    This routine provides a parameterization by computing the
!    pseudo-arclength of the data, that is, the Euclidean distance
!    between successive points.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    19 May 2007
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) M, the spatial dimension.
!
!    Input, integer ( kind = 4 ) DATA_NUM, the number of data points.
!
!    Input, real ( kind = 8 ) P_DATA(M,DATA_NUM), the data values.
!
!    Output, real ( kind = 8 ) T_DATA(DATA_NUM), parameter values
!    assigned to the data.
!
  implicit none

  integer ( kind = 4 ) data_num
  integer ( kind = 4 ) m

  integer ( kind = 4 ) j
  real ( kind = 8 ) p_data(m,data_num)
  real ( kind = 8 ) t_data(data_num)

  t_data(1) = 0.0D+00
  do j = 2, data_num
    t_data(j) = t_data(j-1) &
      + sqrt ( sum ( ( p_data(1:m,j) - p_data(1:m,j-1) )**2 ) )
  end do

  return
end
subroutine parameterize_index ( m, data_num, p_data, t_data )

!*****************************************************************************80
!
!! PARAMETERIZE_INDEX parameterizes data by its index.
!
!  Discussion:
!
!    A parameterization is required for the interpolation.
!
!    This routine provides a naive parameterization by vector index.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    19 May 2007
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) M, the spatial dimension.
!
!    Input, integer ( kind = 4 ) DATA_NUM, the number of data points.
!
!    Input, real ( kind = 8 ) P_DATA(M,DATA_NUM), the data values.
!
!    Output, real ( kind = 8 ) T_DATA(DATA_NUM), parameter values
!    assigned to the data.
!
  implicit none

  integer ( kind = 4 ) data_num
  integer ( kind = 4 ) m

  integer ( kind = 4 ) j
  real ( kind = 8 ) p_data(m,data_num)
  real ( kind = 8 ) t_data(data_num)

  t_data(1) = 0.0D+00
  do j = 2, data_num
    t_data(j) = real ( j - 1, kind = 8 )
  end do

  return
end
subroutine r8mat_expand_linear2 ( m, n, a, m2, n2, a2 )

!*****************************************************************************80
!
!! R8MAT_EXPAND_LINEAR2 expands an R8MAT by linear interpolation.
!
!  Discussion:
!
!    An R8MAT is an array of R8 values.
!
!    In this version of the routine, the expansion is indicated
!    by specifying the dimensions of the expanded array.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    07 December 2004
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) M, N, the number of rows and columns in A.
!
!    Input, real ( kind = 8 ) A(M,N), a "small" M by N array.
!
!    Input, integer ( kind = 4 ) M2, N2, the number of rows and columns in A2.
!
!    Output, real ( kind = 8 ) A2(M2,N2), the expanded array, which
!    contains an interpolated version of the data in A.
!
  implicit none

  integer ( kind = 4 ) m
  integer ( kind = 4 ) m2
  integer ( kind = 4 ) n
  integer ( kind = 4 ) n2

  real ( kind = 8 ) a(m,n)
  real ( kind = 8 ) a2(m2,n2)
  integer ( kind = 4 ) i
  integer ( kind = 4 ) i1
  integer ( kind = 4 ) i2
  integer ( kind = 4 ) j
  integer ( kind = 4 ) j1
  integer ( kind = 4 ) j2
  real ( kind = 8 ) r
  real ( kind = 8 ) r1
  real ( kind = 8 ) r2
  real ( kind = 8 ) s
  real ( kind = 8 ) s1
  real ( kind = 8 ) s2

  do i = 1, m2

    if ( m2 == 1 ) then
      r = 0.5D+00
    else
      r = real ( i - 1, kind = 8 ) &
        / real ( m2 - 1, kind = 8 )
    end if

    i1 = 1 + int ( r * real ( m - 1, kind = 8 ) )
    i2 = i1 + 1

    if ( m < i2 ) then
      i1 = m - 1
      i2 = m
    end if

    r1 = real ( i1 - 1, kind = 8 ) &
       / real ( m - 1, kind = 8 )

    r2 = real ( i2 - 1, kind = 8 ) &
       / real ( m - 1, kind = 8 )

    do j = 1, n2

      if ( n2 == 1 ) then
        s = 0.5D+00
      else
        s = real ( j - 1, kind = 8 ) &
          / real ( n2 - 1, kind = 8 )
      end if

      j1 = 1 + int ( s * real ( n - 1, kind = 8 ) )
      j2 = j1 + 1

      if ( n < j2 ) then
        j1 = n - 1
        j2 = n
      end if

      s1 = real ( j1 - 1, kind = 8 ) &
         / real ( n - 1, kind = 8 )

      s2 = real ( j2 - 1, kind = 8 ) &
         / real ( n - 1, kind = 8 )

      a2(i,j) = &
        ( ( r2 - r ) * ( s2 - s ) * a(i1,j1) &
        + ( r - r1 ) * ( s2 - s ) * a(i2,j1) &
        + ( r2 - r ) * ( s - s1 ) * a(i1,j2) &
        + ( r - r1 ) * ( s - s1 ) * a(i2,j2) ) &
        / ( ( r2 - r1 ) * ( s2 - s1 ) )

    end do

  end do

  return
end
function r8vec_ascends_strictly ( n, x )

!*****************************************************************************80
!
!! R8VEC_ASCENDS_STRICTLY determines if an R8VEC is strictly ascending.
!
!  Discussion:
!
!    An R8VEC is a vector of R8 values.
!
!    Notice the effect of entry number 6 in the following results:
!
!      X = ( -8.1, 1.3, 2.2, 3.4, 7.5, 7.4, 9.8 )
!      Y = ( -8.1, 1.3, 2.2, 3.4, 7.5, 7.5, 9.8 )
!      Z = ( -8.1, 1.3, 2.2, 3.4, 7.5, 7.6, 9.8 )
!
!      R8VEC_ASCENDS_STRICTLY ( X ) = FALSE
!      R8VEC_ASCENDS_STRICTLY ( Y ) = FALSE
!      R8VEC_ASCENDS_STRICTLY ( Z ) = TRUE
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    03 December 2007
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) N, the size of the array.
!
!    Input, real ( kind = 8 ) X(N), the array to be examined.
!
!    Output, logical R8VEC_ASCENDS_STRICTLY, is TRUE if the
!    entries of X strictly ascend.
!
  implicit none

  integer ( kind = 4 ) n

  integer ( kind = 4 ) i
  logical r8vec_ascends_strictly
  real ( kind = 8 ) x(n)

  do i = 1, n - 1
    if ( x(i+1) <= x(i) ) then
      r8vec_ascends_strictly = .false.
      return
    end if
  end do

  r8vec_ascends_strictly = .true.

  return
end
subroutine r8vec_bracket ( n, x, xval, left, right )

!*****************************************************************************80
!
!! R8VEC_BRACKET searches a sorted R8VEC for successive brackets of a value.
!
!  Discussion:
!
!    An R8VEC is an array of double precision real values.
!
!    If the values in the vector are thought of as defining intervals
!    on the real line, then this routine searches for the interval
!    nearest to or containing the given value.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    06 April 1999
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) N, length of input array.
!
!    Input, real ( kind = 8 ) X(N), an array sorted into ascending order.
!
!    Input, real ( kind = 8 ) XVAL, a value to be bracketed.
!
!    Output, integer ( kind = 4 ) LEFT, RIGHT, the results of the search.
!    Either:
!      XVAL < X(1), when LEFT = 1, RIGHT = 2;
!      X(N) < XVAL, when LEFT = N-1, RIGHT = N;
!    or
!      X(LEFT) <= XVAL <= X(RIGHT).
!
  implicit none

  integer ( kind = 4 ) n

  integer ( kind = 4 ) i
  integer ( kind = 4 ) left
  integer ( kind = 4 ) right
  real ( kind = 8 ) x(n)
  real ( kind = 8 ) xval

  do i = 2, n - 1

    if ( xval < x(i) ) then
      left = i - 1
      right = i
      return
    end if

   end do

  left = n - 1
  right = n

  return
end
subroutine r8vec_expand_linear ( n, x, fat, xfat )

!*****************************************************************************80
!
!! R8VEC_EXPAND_LINEAR linearly interpolates new data into an R8VEC.
!
!  Discussion:
!
!    This routine copies the old data, and inserts NFAT new values
!    between each pair of old data values.  This would be one way to
!    determine places to evenly sample a curve, given the (unevenly
!    spaced) points at which it was interpolated.
!
!    An R8VEC is an array of double precision real values.
!
!  Example:
!
!    N = 3
!    NFAT = 2
!
!    X(1:N)        = (/ 0.0,           6.0,             7.0 /)
!    XFAT(1:2*3+1) = (/ 0.0, 2.0, 4.0, 6.0, 6.33, 6.66, 7.0 /)
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    10 October 2001
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) N, the number of input data values.
!
!    Input, real ( kind = 8 ) X(N), the original data.
!
!    Input, integer ( kind = 4 ) FAT, the number of data values to interpolate
!    between each pair of original data values.
!
!    Output, real ( kind = 8 ) XFAT((N-1)*(FAT+1)+1), the "fattened" data.
!
  implicit none

  integer ( kind = 4 ) fat
  integer ( kind = 4 ) n

  integer ( kind = 4 ) i
  integer ( kind = 4 ) j
  integer ( kind = 4 ) k
  real ( kind = 8 ) x(n)
  real ( kind = 8 ) xfat((n-1)*(fat+1)+1)

  k = 0

  do i = 1, n - 1

    k = k + 1
    xfat(k) = x(i)

    do j = 1, fat
      k = k + 1
      xfat(k) = ( real ( fat - j + 1, kind = 8 ) * x(i)     &
                + real (       j,     kind = 8 ) * x(i+1) ) &
                / real ( fat     + 1, kind = 8 )
    end do

  end do

  k = k + 1
  xfat(k) = x(n)

  return
end
subroutine r8vec_expand_linear2 ( n, x, before, fat, after, xfat )

!*****************************************************************************80
!
!! R8VEC_EXPAND_LINEAR2 linearly interpolates new data into an R8VEC.
!
!  Discussion:
!
!    This routine starts with a vector of data.
!
!    The intent is to "fatten" the data, that is, to insert more points
!    between successive values of the original data.
!
!    There will also be extra points placed BEFORE the first original
!    value and AFTER that last original value.
!
!    The "fattened" data is equally spaced between the original points.
!
!    The BEFORE data uses the spacing of the first original interval,
!    and the AFTER data uses the spacing of the last original interval.
!
!  Example:
!
!    N = 3
!    BEFORE = 3
!    FAT = 2
!    AFTER = 1
!
!    X    = (/                   0.0,           6.0,             7.0       /)
!    XFAT = (/ -6.0, -4.0, -2.0, 0.0, 2.0, 4.0, 6.0, 6.33, 6.66, 7.0, 7.66 /)
!              3 "BEFORE's"      Old  2 "FATS"  Old    2 "FATS"  Old  1 "AFTER"
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    03 December 2007
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) N, the number of input data values.
!    N must be at least 2.
!
!    Input, real ( kind = 8 ) X(N), the original data.
!
!    Input, integer ( kind = 4 ) BEFORE, the number of "before" values.
!
!    Input, integer ( kind = 4 ) FAT, the number of data values to interpolate
!    between each pair of original data values.
!
!    Input, integer ( kind = 4 ) AFTER, the number of "after" values.
!
!    Output, real ( kind = 8 ) XFAT(BEFORE+(N-1)*(FAT+1)+1+AFTER), the
!    "fattened" data.
!
  implicit none

  integer ( kind = 4 ) after
  integer ( kind = 4 ) before
  integer ( kind = 4 ) fat
  integer ( kind = 4 ) n

  integer ( kind = 4 ) i
  integer ( kind = 4 ) j
  integer ( kind = 4 ) k
  real ( kind = 8 ) x(n)
  real ( kind = 8 ) xfat(before+(n-1)*(fat+1)+1+after)

  k = 0
!
!  Points BEFORE.
!
  do j = 1 - before + fat, fat
    k = k + 1
    xfat(k) = ( real ( fat - j + 1, kind = 8 ) * ( x(1) - ( x(2) - x(1) ) ) &
              + real (       j,     kind = 8 ) *   x(1)          ) &
              / real ( fat     + 1, kind = 8 )
  end do
!
!  Original points and FAT points.
!
  do i = 1, n - 1

    k = k + 1
    xfat(k) = x(i)

    do j = 1, fat
      k = k + 1
      xfat(k) = ( real ( fat - j + 1, kind = 8 ) * x(i)     &
                + real (       j,     kind = 8 ) * x(i+1) ) &
                / real ( fat     + 1, kind = 8 )
    end do

  end do

  k = k + 1
  xfat(k) = x(n)
!
!  Points AFTER.
!
  do j = 1, after
    k = k + 1
    xfat(k) = &
      ( real ( fat - j + 1, kind = 8 ) * x(n)     &
      + real (       j,     kind = 8 ) * ( x(n) + ( x(n) - x(n-1) ) ) ) &
      / real ( fat     + 1, kind = 8 )
  end do

  return
end
function r8vec_sorted_nearest ( n, a, value )

!*****************************************************************************80
!
!! R8VEC_SORTED_NEAREST returns the nearest element in a sorted R8VEC.
!
!  Discussion:
!
!    An R8VEC is a vector of R8's.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    29 April 2004
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) N, the number of elements of A.
!
!    Input, real ( kind = 8 ) A(N), a sorted vector.
!
!    Input, real ( kind = 8 ) VALUE, the value whose nearest vector
!    entry is sought.
!
!    Output, integer ( kind = 4 ) R8VEC_SORTED_NEAREST, the index of the nearest
!    entry in the vector.
!
  implicit none

  integer ( kind = 4 ) n

  real ( kind = 8 ) a(n)
  integer ( kind = 4 ) r8vec_sorted_nearest
  integer ( kind = 4 ) hi
  integer ( kind = 4 ) lo
  integer ( kind = 4 ) mid
  real ( kind = 8 ) value

  if ( n < 1 ) then
    r8vec_sorted_nearest = -1
    return
  end if

  if ( n == 1 ) then
    r8vec_sorted_nearest = 1
    return
  end if

  if ( a(1) < a(n) ) then

    if ( value < a(1) ) then
      r8vec_sorted_nearest = 1
      return
    else if ( a(n) < value ) then
      r8vec_sorted_nearest = n
      return
    end if
!
!  Seek an interval containing the value.
!
    lo = 1
    hi = n

    do while ( lo < hi - 1 )

      mid = ( lo + hi ) / 2

      if ( value == a(mid) ) then
        r8vec_sorted_nearest = mid
        return
      else if ( value < a(mid) ) then
        hi = mid
      else
        lo = mid
      end if

    end do
!
!  Take the nearest.
!
    if ( abs ( value - a(lo) ) < abs ( value - a(hi) ) ) then
      r8vec_sorted_nearest = lo
    else
      r8vec_sorted_nearest = hi
    end if

    return
!
!  A descending sorted vector A.
!
  else

    if ( value < a(n) ) then
      r8vec_sorted_nearest = n
      return
    else if ( a(1) < value ) then
      r8vec_sorted_nearest = 1
      return
    end if
!
!  Seek an interval containing the value.
!
    lo = n
    hi = 1

    do while ( lo < hi - 1 )

      mid = ( lo + hi ) / 2

      if ( value == a(mid) ) then
        r8vec_sorted_nearest = mid
        return
      else if ( value < a(mid) ) then
        hi = mid
      else
        lo = mid
      end if

    end do
!
!  Take the nearest.
!
    if ( abs ( value - a(lo) ) < abs ( value - a(hi) ) ) then
      r8vec_sorted_nearest = lo
    else
      r8vec_sorted_nearest = hi
    end if

    return

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


INTEGER, PARAMETER :: dp = SELECTED_REAL_KIND(15)
INTEGER :: i=1, limit=100
REAL(dp) :: d, e, f, x, x1, x2

f(x) = x*x*x - 3.0_dp*x*x + 2.0_dp*x

x1 = -1.0_dp ; x2 = 3.0_dp ; e = 1.0e-15_dp

DO
  IF (i > limit) THEN
    WRITE(*,*) "Function not converging"
    EXIT
  END IF
  d = (x2 - x1) / (f(x2) - f(x1)) * f(x2)
  IF (ABS(d) < e) THEN
    WRITE(*,"(A,F18.15)") "Root found at x = ", x2
    EXIT
  END IF
  x1 = x2
  x2 = x2 - d
  i = i + 1
END DO


subroutine convergencet(t, atw, ate, ats, atn, atp, bt, itmax, jtmax, residualt)
!use variables
use kind_parameters
implicit none

integer, intent(in):: itmax, jtmax
real(kind=dp), dimension(itmax,jtmax):: t, atw, ate, ats, atn, atp, bt
real(kind=dp):: temp1, temp2, sum_nom, sum_den
integer:: it, jt
real(kind=dp), intent(out):: residualt

sum_nom = 0.0d0
sum_den = 0.0d0

do jt=2,jtmax-1

       do it=2,itmax-1

              temp1 = atp(it,jt)*t(it,jt)
              temp2 = atw(it,jt)*t(it-1,jt) + ate(it,jt)*t(it+1,jt) + ats(it,jt)*t(it,jt-1) + atn(it,jt)*t(it,jt+1)
              sum_nom = sum_nom + dabs(temp1 - temp2 - bt(it,jt))
              sum_den = sum_den + dabs(temp1)

       end do

end do

residualt = sum_nom/sum_den

end subroutine


subroutine wind(Nm,Nx,Ny,windy)

implicit none
integer, intent(in) :: Nx,Ny,Nm
real(8), dimension(Nm,Nx,Ny), intent(out) :: windy

integer :: i,j,m
real(8) :: pi = 3.14159265358979d0
real(8), dimension(Nx,Ny) :: tau

tau(:,:)     = 0.d0
windy(:,:,:) = 0.d0

do i=1,Nx
 do j=1,Ny

  tau(i,j) = cos(2.*pi*((j-1.)/(Ny-1.)-0.5))+2.*sin(pi*((j-1.)/(Ny-1.)-0.5))
!  tau(i,j) = -1./(2.*pi)*cos(2.*pi*(j-1.)/(Ny-1.))
!  tau(i,j) = -cos(pi*(j-1.)/(Ny-1.))
!  tau(i,j) = -cos(pi*(j-1.5)/(ny-2.))                                             ! what they had in the code
!  tau(i,j) = -1./pi*cos(pi*(j-1.)/(Ny-1.))                                         ! what I used
!  tau(i,j) = -1./pi*cos(pi*(j-1.)/(ny-1.))*sin(pi*(i-1.)/(ny-1.))                 ! Veronis (1966) ????

 end do
end do

do m=1,Nm
 do i=2,Nx-1
  do j=2,Ny-1

  windy(m,i,j) = -tau(i,j+1)+tau(i,j-1)                                            ! include the whole curl, i.e., also x-derivative for generality ?????

  end do
 end do
end do

!      write(*,*) tau
!      write(*,*) windy

end

!      real(8), allocatable, dimension (:,:) :: wind_term
!      allocate (wind_term(Nx,Ny))
!      call wind(Nx,Ny,wind_term)


      PROGRAM xchder
C     driver for routine chder
      INTEGER NVAL
      REAL PIO2
      PARAMETER(NVAL=40, PIO2=1.5707963)
      INTEGER i,mval
      REAL a,b,chebev,fder,func,x,c(NVAL),cder(NVAL)
      EXTERNAL func,fder
      a=-PIO2
      b=PIO2
      call chebft(a,b,c,NVAL,func)
C     test derivative
10    write(*,*) 'How many terms in Chebyshev evaluation?'
      write(*,'(1x,a,i2,a)') 'Enter n between 6 and ',NVAL,
     *     '. Enter n=0 to END.'
      read(*,*) mval
      if ((mval.le.0).or.(mval.gt.NVAL)) goto 20
      call chder(a,b,c,cder,mval)
      write(*,'(1x,t10,a,t19,a,t28,a)') 'X','Actual','Cheby. Deriv.'
      do 11 i=-8,8,1
        x=i*PIO2/10.0
        write(*,'(1x,3f12.6)') x,fder(x),chebev(a,b,cder,mval,x)
11    continue
      goto 10
20    END
      REAL FUNCTION func(x)
      REAL x
      func=(x**2)*(x**2-2.0)*sin(x)
      END
      REAL FUNCTION fder(x)
C     derivative of FUNC
      REAL x
      fder=4.0*x*((x**2)-1.0)*sin(x)+(x**2)*(x**2-2.0)*cos(x)
      END

NR-Functions/Numerical Recipes- Example & Functions/Examples/xchder.for


	FUNCTION PR_DDEN  ( pres, tmpc )
C************************************************************************
C* PR_DDEN								*
C*									*
C* This function computes DDEN from PRES, TMPC.  The following		*
C* equation is used:							*
C*									*
C*           DDEN = 100 * PRES / ( RDGAS * TMPK )		 	*
C*									*
C*                100:  conversion from millibars to pascals		*
C*									*
C* REAL PR_DDEN  ( PRES, TMPC )						*
C*									*
C* Input parameters:							*
C*	PRES		REAL	 	Pressure in millibars		*
C*	TMPC		REAL		Temperature in Celsius		*
C*									*
C* Output parameters:							*
C*	PR_DDEN		REAL	 	Density of dry air in kg/(m**3)	*
C**									*
C* Log:									*
C* G. Huffman/GSC	8/88	Original PR_DDEN			*
C* G. Krueger/EAI        4/96   Replaced C->K constant with TMCK	*
C************************************************************************
        INCLUDE  	'GEMPRM.PRM'
        INCLUDE  	'ERMISS.FNC'
C------------------------------------------------------------------------
C*	Check for bad data.
C
	IF  ( ERMISS ( pres ) .or. ERMISS ( tmpc )
     *       .or. ( tmpc .lt. -TMCK ) )  THEN
	    pr_dden = RMISSD
	    RETURN
	END IF
C
C*	Convert temperature and compute.
C
	tmpk = PR_TMCK ( tmpc )
	PR_DDEN = 100. * pres / ( RDGAS * tmpk )
C*
	RETURN
	END


module kmod

    contains

    ! Metric distance between two vectors
    ! let's use Euclidean metric
    function distance(a,b) result(c)
        implicit none

        real,intent(in) :: a(:),b(:)
        real            :: c

        integer :: i

        c = 0
        do i = 1,size(a,1)
            c = c + (a(i)-b(i))**2
        end do
        c = sqrt(c)
    end function

    function cost(medoids,dados,labels) result(c)
        implicit none

        real,intent(in)     :: medoids(:,:)
        real,intent(in)     :: dados(:,:)
        integer,intent(in)  :: labels(:)
        real                :: c

        integer :: i

        do i = 1,size(dados,1)
            c = c + distance(dados(i,:),medoids(labels(i),:))
        end do
    end function
end module

program kmed
    use kmod
    implicit none

    integer,parameter   :: datalength = 300
    real                :: data(datalength,2)
    real                :: medoid(3,2)
    real                :: d,d_min
    real                :: c1,c2
    real                :: tmp(2),best(2)
    integer             :: i,j,k(1),swap
    integer             :: label(datalength)
    real                :: s(datalength)
    integer             :: clustersize(3)
    real                :: t(3)
    real                :: a,b

    character(len=50)   :: fname
    logical             :: existent
    logical             :: change

    ! Load image
    open(1,file="data.dat",status="old")

    do i = 1,datalength
        read(1,*) data(i,:)
    end do

    close(1)

    ! Set itial medoids
    medoid(1,:) = data(50,:)
    medoid(2,:) = data(150,:)
    medoid(3,:) = data(250,:)

    swap = 1
    do while(swap > 0)
        ! Assignment step
        do i = 1,datalength
            d_min = 1E5
            do j = 1,3
                d = distance(data(i,:),medoid(j,:))
                if (d < d_min) then
                    label(i) = j
                    d_min = d
                end if
            end do
        end do

        ! For each medoid...
        swap = 0
        do j = 1,3
            c1 = cost(medoid,data,label)
            tmp = medoid(j,:)
            ! ...check if non-medoid point has lower cost, and...
            do i = 1,datalength
                medoid(j,:) = data(i,:)
                c2 = cost(medoid,data,label)
                ! ... remember the best choice.
                if (c2 < c1) then
                    c1 = c2
                    best = medoid(j,:)
                    change = .true.
                end if
            end do
            ! If any non-medoid improved, swap
            if (change) then
                medoid(j,:) = best
                swap = swap + 1
            else
                medoid(j,:) = tmp
            end if
        end do
    end do

    ! Save labels
    fname = "labels.dat"
    inquire(file=fname,exist=existent)

    if (existent) then
        open(1,file=fname,status="old")
    else
        open(1,file=fname,status="new")
    end if

    do i = 1,datalength
        write(1,*) label(i)
    end do

    close(1)
    do i = 1,3
        write(*,*) medoid(i,:)
    end do

    ! Silhouette
    ! find cluster sizes
    clustersize = 0
    s = 0
    t = 0
    do i = 1,datalength
        do j = 1,3
            if (label(i) == j) then
                clustersize(j) = clustersize(j) + 1
            end if
        end do
    end do

    ! Find coefficients a and b
    do i = 1,datalength
        a = 0
        d_min = 1E5
        do j = 1,datalength
            ! If they are from the same cluster
            if (label(j) .eq. label(i)) then
                if (i .ne. j) then
                    a = a + distance(data(i,:),data(j,:))
                end if
            else
                t(label(j)) = t(label(j)) + distance(data(i,:),data(j,:))
            end if
        end do
        if (clustersize(label(i)) .le. 1) then
            s(i) = 0
        else
            a = a/(clustersize(label(i))-1)

            select case(label(i))
                case(1)
                    if (t(2) < t(3)) then
                        b = t(2)/clustersize(2)
                    else
                        b = t(3)/clustersize(3)
                    end if
                case(2)
                    if (t(1) < t(3)) then
                        b = t(1)/clustersize(1)
                    else
                        b = t(3)/clustersize(3)
                    end if
                case(3)
                    if (t(1) < t(2)) then
                        b = t(1)/clustersize(1)
                    else
                        b = t(2)/clustersize(2)
                    end if
            end select

            write(*,*) a,b,a/b

            if (a < b) then
                s(i) = 1.0-a/b
            end if
            if (a == b) then
                s(i) = 0
            end if
            if (a > b) then
                s(i) = b/a-1.0
            end if
        end if
    end do

    ! Save filhouette
    fname = "silhouette.dat"
    inquire(file=fname,exist=existent)

    if (existent) then
        open(1,file=fname,status="old")
    else
        open(1,file=fname,status="new")
    end if

    do i = 1,datalength
        write(1,*) s(i)
    end do

    close(1)

end program


module mod_rootfinding
    use mod_kinds,      only: rk, ik
    use mod_constants,  only: ZERO, ONE, TWO, RKTOL
    use type_point,     only: point_t
    use type_function,  only: function_t
    implicit none

contains

    !>  Use the bisection method to find the root of a function, given
    !!  two locations that are known to bound the root.
    !!
    !!  Note: because functions are defined in ChiDG as functions of space and time, we
    !!        set time here to zero, and use the first coordinate of the point data type
    !!        point%c1_ for our working coordinate.
    !!
    !!  @author Nathan A. Wukie
    !!  @date   4/13/2016
    !!
    !!  @param[in]  fcn         Function definition that can be evaluated.
    !!  @param[in]  xlower      Lower location, smaller than the location of the root.
    !!  @param[in]  xupper      Upper location, larger than the location of the root.
    !!  @param[in]  tol         Optional tolerance on convergnance
    !!
    !------------------------------------------------------------------------------------
    function bisect(fcn, xlower, xupper, tol_in) result(xout)
        class(function_t),  intent(inout)           :: fcn
        real(rk),           intent(in)              :: xlower
        real(rk),           intent(in)              :: xupper
        real(rk),           intent(inout), optional :: tol_in

        logical         :: not_zero
        real(rk)        :: fa, fb, fc, time, tol, xout
        type(point_t)   :: a, b, c

        call a%set(ZERO, ZERO, ZERO)
        call b%set(ZERO, ZERO, ZERO)
        call c%set(ZERO, ZERO, ZERO)
        time = ZERO

        !
        ! Set default tolerance
        !
        if ( present(tol_in) ) then
            tol = tol_in
        else
            tol = RKTOL
        end if

        !
        ! Initialize bounds
        !
        a%c1_ = xlower    ! lower bound - 'a'
        b%c1_ = xupper    ! upper bound - 'b'
        fa = fcn%compute(time,a) ! function value at 'a'
        fb = fcn%compute(time,b) ! function value at 'b'

        !
        ! Bisection iteration
        !
        not_zero = .true.
        do while ( not_zero )

            ! Compute new location
            c%c1_ = (a%c1_ + b%c1_)/TWO

            ! Compute new function value at middle location 'c'
            fc = fcn%compute(time,c)

            ! Check for convergence
            not_zero = ( fc > tol ) .or. ((b%c1_-a%c1_)/TWO > tol)

            ! Update bounds
            if ( int(sign(ONE,fc)) == int(sign(ONE,fa)) ) then
                a = c
                fa = fcn%compute(time,a)
            else
                b = c
                fb = fcn%compute(time,b)
            end if

        end do

        ! Save root
        xout = c%c1_

    end function bisect
    !*************************************************************************************

end module mod_rootfinding


      SUBROUTINE MC01VD( A, B, C, Z1RE, Z1IM, Z2RE, Z2IM, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute the roots of a quadratic equation with real
C     coefficients.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     A       (input) DOUBLE PRECISION
C             The value of the coefficient of the quadratic term.
C
C     B       (input) DOUBLE PRECISION
C             The value of the coefficient of the linear term.
C
C     C       (input) DOUBLE PRECISION
C             The value of the coefficient of the constant term.
C
C     Z1RE    (output) DOUBLE PRECISION
C     Z1IM    (output) DOUBLE PRECISION
C             The real and imaginary parts, respectively, of the largest
C             root in magnitude.
C
C     Z2RE    (output) DOUBLE PRECISION
C     Z2IM    (output) DOUBLE PRECISION
C             The real and imaginary parts, respectively, of the
C             smallest root in magnitude.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             = 1:  if on entry, either A = B = 0.0 or A = 0.0 and the
C                   root -C/B overflows; in this case Z1RE, Z1IM, Z2RE
C                   and Z2IM are unassigned;
C             = 2:  if on entry, A = 0.0; in this case Z1RE contains
C                   BIG and Z1IM contains zero, where BIG is a
C                   representable number near the overflow threshold
C                   of the machine (see LAPACK Library Routine DLAMCH);
C             = 3:  if on entry, either C = 0.0 and the root -B/A
C                   overflows or A, B and C are non-zero and the largest
C                   real root in magnitude cannot be computed without
C                   overflow; in this case Z1RE contains BIG and Z1IM
C                   contains zero;
C             = 4:  if the roots cannot be computed without overflow; in
C                   this case Z1RE, Z1IM, Z2RE and Z2IM are unassigned.
C
C     METHOD
C
C     The routine computes the roots (r1 and r2) of the real quadratic
C     equation
C             2
C        a * x  + b * x + c = 0
C
C     as
C             - b - SIGN(b) * SQRT(b * b - 4 * a * c)             c
C        r1 = ---------------------------------------  and r2 = ------
C                              2 * a                            a * r1
C
C     unless a = 0, in which case
C
C             -c
C        r1 = --.
C              b
C
C     Precautions are taken to avoid overflow and underflow wherever
C     possible.
C
C     NUMERICAL ASPECTS
C
C     The algorithm is numerically stable.
C
C     CONTRIBUTOR
C
C     Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997.
C     Supersedes Release 2.0 routine MC01JD by A.J. Geurts.
C
C     REVISIONS
C
C     -
C
C     KEYWORDS
C
C     Quadratic equation, zeros.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE, FOUR
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0, FOUR=4.0D0 )
C     .. Scalar Arguments ..
      INTEGER           INFO
      DOUBLE PRECISION  A, B, C, Z1IM, Z1RE, Z2IM, Z2RE
C     .. Local Scalars ..
      LOGICAL           OVFLOW
      INTEGER           BETA, EA, EAPLEC, EB, EB2, EC, ED
      DOUBLE PRECISION  ABSA, ABSB, ABSC, BIG, M1, M2, MA, MB, MC, MD,
     $                  SFMIN, W
C     .. External Functions ..
      DOUBLE PRECISION  DLAMCH
      EXTERNAL          DLAMCH
C     .. External Subroutines ..
      EXTERNAL          MC01SW, MC01SY
C     .. Intrinsic Functions ..
      INTRINSIC         ABS, MOD, SIGN, SQRT
C     .. Executable Statements ..
C
C     Detect special cases.
C
      INFO  = 0
      BETA  = DLAMCH( 'Base' )
      SFMIN = DLAMCH( 'Safe minimum' )
      BIG   = ONE/SFMIN
      IF ( A.EQ.ZERO ) THEN
         IF ( B.EQ.ZERO ) THEN
            INFO = 1
         ELSE
            OVFLOW = .FALSE.
            Z2RE   =  ZERO
            IF ( C.NE.ZERO ) THEN
               ABSB = ABS( B )
               IF ( ABSB.GE.ONE ) THEN
                  IF ( ABS( C ).GE.ABSB*SFMIN ) Z2RE = -C/B
               ELSE
                  IF ( ABS( C ).LE.ABSB*BIG ) THEN
                     Z2RE = -C/B
                  ELSE
                     OVFLOW = .TRUE.
                     Z2RE   = BIG
                     IF ( SIGN( ONE, B )*SIGN( ONE, C ).GT.ZERO )
     $                  Z2RE = -BIG
                  END IF
               END IF
            END IF
            IF ( OVFLOW ) THEN
               INFO = 1
            ELSE
               Z1RE = BIG
               Z1IM = ZERO
               Z2IM = ZERO
               INFO = 2
            END IF
         END IF
         RETURN
      END IF
C
      IF ( C.EQ.ZERO ) THEN
         OVFLOW = .FALSE.
         Z1RE   =  ZERO
         IF ( B.NE.ZERO ) THEN
            ABSA = ABS( A )
            IF ( ABSA.GE.ONE ) THEN
               IF ( ABS( B ).GE.ABSA*SFMIN ) Z1RE = -B/A
            ELSE
               IF ( ABS( B ).LE.ABSA*BIG ) THEN
                  Z1RE = -B/A
               ELSE
                  OVFLOW = .TRUE.
                  Z1RE   = BIG
               END IF
            END IF
         END IF
         IF ( OVFLOW ) INFO = 3
         Z1IM = ZERO
         Z2RE = ZERO
         Z2IM = ZERO
         RETURN
      END IF
C
C     A and C are non-zero.
C
      IF ( B.EQ.ZERO ) THEN
         OVFLOW = .FALSE.
         ABSC   = SQRT( ABS( C ) )
         ABSA   = SQRT( ABS( A ) )
         W =  ZERO
         IF ( ABSA.GE.ONE ) THEN
            IF ( ABSC.GE.ABSA*SFMIN ) W = ABSC/ABSA
         ELSE
            IF ( ABSC.LE.ABSA*BIG ) THEN
               W = ABSC/ABSA
            ELSE
               OVFLOW = .TRUE.
               W = BIG
            END IF
         END IF
         IF ( OVFLOW ) THEN
            INFO = 4
         ELSE
            IF ( SIGN( ONE, A )*SIGN( ONE, C ).GT.ZERO ) THEN
               Z1RE = ZERO
               Z2RE = ZERO
               Z1IM =  W
               Z2IM = -W
            ELSE
               Z1RE =  W
               Z2RE = -W
               Z1IM = ZERO
               Z2IM = ZERO
            END IF
         END IF
         RETURN
      END IF
C
C     A, B and C are non-zero.
C
      CALL MC01SW( A, BETA, MA, EA )
      CALL MC01SW( B, BETA, MB, EB )
      CALL MC01SW( C, BETA, MC, EC )
C
C     Compute a 'near' floating-point representation of the discriminant
C     D = MD * BETA**ED.
C
      EAPLEC = EA + EC
      EB2 = 2*EB
      IF ( EAPLEC.GT.EB2 ) THEN
         CALL MC01SY( MB*MB, EB2-EAPLEC, BETA, W, OVFLOW )
         W = W - FOUR*MA*MC
         CALL MC01SW( W, BETA, MD, ED )
         ED = ED + EAPLEC
      ELSE
         CALL MC01SY( FOUR*MA*MC, EAPLEC-EB2, BETA, W, OVFLOW )
         W = MB*MB - W
         CALL MC01SW( W, BETA, MD, ED )
         ED = ED + EB2
      END IF
C
      IF ( MOD( ED, 2 ).NE.0 ) THEN
         ED = ED + 1
         MD = MD/BETA
      END IF
C
C     Complex roots.
C
      IF ( MD.LT.ZERO ) THEN
         CALL MC01SY( -MB/( 2*MA ), EB-EA, BETA, Z1RE, OVFLOW )
         IF ( OVFLOW ) THEN
            INFO = 4
         ELSE
            CALL MC01SY( SQRT( -MD )/( 2*MA ), ED/2-EA, BETA, Z1IM,
     $                   OVFLOW )
            IF ( OVFLOW ) THEN
               INFO = 4
            ELSE
               Z2RE =  Z1RE
               Z2IM = -Z1IM
            END IF
         END IF
         RETURN
      END IF
C
C     Real roots.
C
      MD = SQRT( MD )
      ED = ED/2
      IF ( ED.GT.EB ) THEN
         CALL MC01SY( ABS( MB ), EB-ED, BETA, W, OVFLOW )
         W = W + MD
         M1 = -SIGN( ONE, MB )*W/( 2*MA )
         CALL MC01SY( M1, ED-EA, BETA, Z1RE, OVFLOW )
         IF ( OVFLOW ) THEN
            Z1RE = BIG
            INFO = 3
         END IF
         M2 = -SIGN( ONE, MB )*2*MC/W
         CALL MC01SY( M2, EC-ED, BETA, Z2RE, OVFLOW )
      ELSE
         CALL MC01SY( MD, ED-EB, BETA, W, OVFLOW )
         W  = W + ABS( MB )
         M1 = -SIGN( ONE, MB )*W/( 2*MA )
         CALL MC01SY( M1, EB-EA, BETA, Z1RE, OVFLOW )
         IF ( OVFLOW ) THEN
            Z1RE = BIG
            INFO = 3
         END IF
         M2 = -SIGN( ONE, MB )*2*MC/W
         CALL MC01SY( M2, EC-EB, BETA, Z2RE, OVFLOW )
      END IF
      Z1IM = ZERO
      Z2IM = ZERO
C
      RETURN
C *** Last line of MC01VD ***
      END


module module_math
  use module_globals
  use module_autodiff
  implicit none

  private
  public IntegralTest, load_integral_test, f, Df

  type :: IntegralTest
     real(8) :: st, en, le, cn, seikai
  end type IntegralTest

contains
  !========================================================================================
  subroutine load_integral_test(test)
    type(IntegralTest),intent(out) :: test

    ! int_[a->b](sin(x))dx
    test%st=0.d0
    test%en=30.d0
    test%seikai=-cos(test%en)+cos(test%st)

    !int_[0.01->2](sin(x)/x)dx
    ! test%st=0.01d0
    ! test%en=1.d0
    ! test%seikai=0.93608312592257190411368860853800106052127274d0

    ! !int_[0->30](sin(x)/x)dx
    ! test%st=1.d0
    ! test%en=30.d0
    ! test%seikai=0.620673469663168096042377995183618508711157d0

    ! int_[-1->1] 1/(1+25*x^2) dx
    test%st=-5.d0
    test%en=5.d0
    test%seikai=(atan(5.d0*test%en)-atan(5.d0*test%st))/5.d0

    ! int_[0,1] bessel_j0(x) dx
    ! test%st=0.d0
    ! test%en=1.d0
    ! test%seikai=0.919730410089760239314421194080619970661d0

    ! test%st=0.d0
    ! test%en=2.d0
    ! test%seikai=(test%en**30-test%st**30)/30.d0

    test%le=test%en-test%st
    test%cn=(test%st+test%en)*0.5d0

  end subroutine load_integral_test

  !========================================================================================
  real(8) function f(x)
    real(8),intent(in) :: x
    !f=sin(x)
    !f=sin(x)/x
    !f=sin(x)/x
    f=1.d0/(1.d0+25.d0*x*x)
    !f=bessel_j0(x)
    !f=x**29
  end function f

  !========================================================================================
  type(Dcomplex8) function Df(x)
    type(Dcomplex8),intent(in) :: x
    !Df=sin(x)
    !Df=sin(x)/x
    !Df=sin(x)/x
    Df=1.d0/(1.d0+25.d0*x*x)
    !Df=bessel_j0(x)
    !Df=x**29
  end function Df

end module module_math


     subroutine fort_set_dirichlet_bcs(lo,hi,domlo,domhi, &
                           phi,phi_l1,phi_l2,phi_l3,phi_h1,phi_h2,phi_h3,dx);

     use amrex_fort_module, only : rt => amrex_real
     use bl_constants_module         , only : M_PI
     use probdata_module             , only : a1,a3,center
     use meth_params_module          , only : NVAR
     use fundamental_constants_module, only : Gconst

     implicit none

     integer         ,intent(in   ) :: lo(3),hi(3),domlo(3),domhi(3)
     integer         ,intent(in   ) :: phi_l1,phi_l2,phi_l3,phi_h1,phi_h2,phi_h3
     real(rt),intent(  out) :: phi(phi_l1:phi_h1,phi_l2:phi_h2,phi_l3:phi_h3)
     real(rt),intent(in   ) :: dx(3)

     integer          :: i,j,k
     real(rt) :: x,y,z,rsq,zsq
     real(rt) :: a1sq,a3sq
     real(rt) :: e,esq,b,lambda,h,ah

     a1sq = a1**2
     a3sq = a3**2

     esq = 1.d0 - a3sq/a1sq
      e   = dsqrt(esq)

     if (lo(1).eq.domlo(1)) then
        i = lo(1)-1
        x = 0.d0 - center(1)
        do k = lo(3), hi(3)
           z = (dble(k)+0.5d0)*dx(3) - center(3)
           zsq = z**2
              do j = lo(2), hi(2)
                 y = (dble(j)+0.5d0)*dx(2) - center(2)
                    rsq = x**2 + y**2
                    b = a1sq + a3sq - rsq - zsq
                    lambda = 0.5d0 * ( -b + dsqrt( b**2 - 4.d0 * &
                                     (a1sq * a3sq - rsq * a3sq - zsq * a1sq) ) )
                    h = a1 * e / (dsqrt(a3sq + lambda))
                    ah = datan(h)
                    phi(i,j,k) = &
                       2.d0 * M_PI * Gconst * a1 * a3 / e * ( &
                       ah - 0.5d0 / (a1sq * esq) * &
                       ( rsq * (ah - h / (1.d0+h**2) ) + 2.d0 * zsq * (h - ah) ) )

           end do
        end do
     end if

     if (hi(1).eq.domhi(1)) then
        i = hi(1)+1
        x = 1.d0 - center(1)
        do k = lo(3), hi(3)
           z = (dble(k)+0.5d0)*dx(3) - center(3)
           zsq = z**2
              do j = lo(2), hi(2)
                 y = (dble(j)+0.5d0)*dx(2) - center(2)
                    rsq = x**2 + y**2
                    b = a1sq + a3sq - rsq - zsq
                    lambda = 0.5d0 * ( -b + dsqrt( b**2 - 4.d0 * &
                                     (a1sq * a3sq - rsq * a3sq - zsq * a1sq) ) )
                    h = a1 * e / (dsqrt(a3sq + lambda))
                    ah = datan(h)
                    phi(i,j,k) = &
                       2.d0 * M_PI * Gconst * a1 * a3 / e * ( &
                       ah - 0.5d0 / (a1sq * esq) * &
                       ( rsq * (ah - h / (1.d0+h**2) ) + 2.d0 * zsq * (h - ah) ) )
           end do
        end do
     end if

     if (lo(2).eq.domlo(2)) then
        j = lo(2)-1
        y = 0.d0 - center(2)
        do k = lo(3), hi(3)
           z = (dble(k)+0.5d0)*dx(3) - center(3)
           zsq = z**2
              do i = lo(1), hi(1)
                 x = (dble(i)+0.5d0)*dx(1) - center(1)
                    rsq = x**2 + y**2
                    b = a1sq + a3sq - rsq - zsq
                    lambda = 0.5d0 * ( -b + dsqrt( b**2 - 4.d0 * &
                                     (a1sq * a3sq - rsq * a3sq - zsq * a1sq) ) )
                    h = a1 * e / (dsqrt(a3sq + lambda))
                    ah = datan(h)
                    phi(i,j,k) = &
                       2.d0 * M_PI * Gconst * a1 * a3 / e * ( &
                       ah - 0.5d0 / (a1sq * esq) * &
                       ( rsq * (ah - h / (1.d0+h**2) ) + 2.d0 * zsq * (h - ah) ) )
           end do
        end do
     end if

     if (hi(2).eq.domhi(2)) then
        j = hi(2)+1
        y = 1.d0 - center(2)
        do k = lo(3), hi(3)
           z = (dble(k)+0.5d0)*dx(3) - center(3)
           zsq = z**2
              do i = lo(1), hi(1)
                 x = (dble(i)+0.5d0)*dx(1) - center(1)
                    rsq = x**2 + y**2
                    b = a1sq + a3sq - rsq - zsq
                    lambda = 0.5d0 * ( -b + dsqrt( b**2 - 4.d0 * &
                                     (a1sq * a3sq - rsq * a3sq - zsq * a1sq) ) )
                    h = a1 * e / (dsqrt(a3sq + lambda))
                    ah = datan(h)
                    phi(i,j,k) = &
                       2.d0 * M_PI * Gconst * a1 * a3 / e * ( &
                       ah - 0.5d0 / (a1sq * esq) * &
                       ( rsq * (ah - h / (1.d0+h**2) ) + 2.d0 * zsq * (h - ah) ) )
           end do
        end do
     end if

     if (lo(3).eq.domlo(3)) then
        k = lo(3)-1
        z = 0.d0 - center(3)
        zsq = z**2
        do j = lo(2), hi(2)
           y = (dble(j)+0.5d0)*dx(2) - center(2)
              do i = lo(1), hi(1)
                 x = (dble(i)+0.5d0)*dx(1) - center(1)
                    rsq = x**2 + y**2
                    b = a1sq + a3sq - rsq - zsq
                    lambda = 0.5d0 * ( -b + dsqrt( b**2 - 4.d0 * &
                                     (a1sq * a3sq - rsq * a3sq - zsq * a1sq) ) )
                    h = a1 * e / (dsqrt(a3sq + lambda))
                    ah = datan(h)
                    phi(i,j,k) = &
                       2.d0 * M_PI * Gconst * a1 * a3 / e * ( &
                       ah - 0.5d0 / (a1sq * esq) * &
                       ( rsq * (ah - h / (1.d0+h**2) ) + 2.d0 * zsq * (h - ah) ) )
           end do
        end do
     end if

     if (hi(3).eq.domhi(3)) then
        k = hi(3)+1
        z = 1.d0 - center(3)
        zsq = z**2
        do j = lo(2), hi(2)
           y = (dble(j)+0.5d0)*dx(2) - center(2)
              do i = lo(1), hi(1)
                 x = (dble(i)+0.5d0)*dx(1) - center(1)
                    rsq = x**2 + y**2
                    b = a1sq + a3sq - rsq - zsq
                    lambda = 0.5d0 * ( -b + dsqrt( b**2 - 4.d0 * &
                                     (a1sq * a3sq - rsq * a3sq - zsq * a1sq) ) )
                    h = a1 * e / (dsqrt(a3sq + lambda))
                    ah = datan(h)
                    phi(i,j,k) = &
                       2.d0 * M_PI * Gconst * a1 * a3 / e * ( &
                       ah - 0.5d0 / (a1sq * esq) * &
                       ( rsq * (ah - h / (1.d0+h**2) ) + 2.d0 * zsq * (h - ah) ) )
           end do
        end do
     end if

     end subroutine fort_set_dirichlet_bcs

     subroutine fort_set_homog_bcs(lo,hi,domlo,domhi, &
                                   phi,phi_l1,phi_l2,phi_l3,phi_h1,phi_h2,phi_h3,dx);

     use amrex_fort_module, only : rt => amrex_real
     implicit none

     integer         ,intent(in   ) :: lo(3),hi(3),domlo(3),domhi(3)
     integer         ,intent(in   ) :: phi_l1,phi_l2,phi_l3,phi_h1,phi_h2,phi_h3
     real(rt),intent(  out) :: phi(phi_l1:phi_h1,phi_l2:phi_h2,phi_l3:phi_h3)
     real(rt),intent(in   ) :: dx(3)

     phi = 0.d0

     end subroutine fort_set_homog_bcs

     ! ************************************************************************************
     ! Loops over the particles and adds their monopole contribution to phi outside the boundary
     ! ************************************************************************************

     subroutine fort_add_monopole_bcs(lo,hi,domlo,domhi, &
                                      np,part_locs,part_mass, &
                                      phi,phi_l1,phi_l2,phi_l3,phi_h1,phi_h2,phi_h3,dx);

     use amrex_fort_module, only : rt => amrex_real
     use fundamental_constants_module, only : Gconst

     implicit none

     integer         ,intent(in   ) :: lo(3),hi(3),domlo(3),domhi(3),np
     integer         ,intent(in   ) :: phi_l1,phi_l2,phi_l3,phi_h1,phi_h2,phi_h3
     real(rt),intent(in   ) :: part_locs(0:3*np-1)
     real(rt),intent(in   ) :: part_mass(0:  np-1)
     real(rt),intent(  out) :: phi(phi_l1:phi_h1,phi_l2:phi_h2,phi_l3:phi_h3)
     real(rt),intent(in   ) :: dx(3)

     ! Local variables
     integer          :: i,j,k,n
     real(rt) :: x,y,z,r
     real(rt) :: x0,y0,z0

     phi = 0.d0

     ! Define phi = -G M / r where r is distance from particle and M is mass of particle

     do k = lo(3)-1,hi(3)+1
         do j = lo(2)-1,hi(2)+1
             do i = lo(1)-1,hi(1)+1

                   if (i.lt.domlo(1) .or. i.gt.domhi(1) .or. &
                       j.lt.domlo(2) .or. j.gt.domhi(2) .or. &
                       k.lt.domlo(3) .or. k.gt.domhi(3)) then

                       if (i.lt.domlo(1)) then
                           x0 = (dble(i+1))*dx(1)
                       else if (i.gt.domhi(1)) then
                           x0 = (dble(i))*dx(1)
                       else
                           x0 = (dble(i)+0.5d0)*dx(1)
                       end if

                       if (j.lt.domlo(2)) then
                           y0 = (dble(j+1))*dx(2)
                       else if (j.gt.domhi(2)) then
                           y0 = (dble(j))*dx(2)
                       else
                           y0 = (dble(j)+0.5d0)*dx(2)
                       end if

                       if (k.lt.domlo(3)) then
                           z0 = (dble(k+1))*dx(3)
                       else if (k.gt.domhi(3)) then
                           z0 = (dble(k))*dx(3)
                       else
                           z0 = (dble(k)+0.5d0)*dx(3)
                       end if

                       do n = 0, np-1
                           x = x0 - part_locs(3*n  )
                           y = y0 - part_locs(3*n+1)
                           z = z0 - part_locs(3*n+2)
                           r = sqrt(x*x + y*y + z*z)
                           phi(i,j,k) = phi(i,j,k) - Gconst * part_mass(n) / r
                       end do

                   end if
              end do
         end do
     end do

     end subroutine fort_add_monopole_bcs


!SUBROUTINE INVERSSYMDEF(A,AINV)
!  IMPLICIT REAL*8 (A-H,O-Z)
!  DIMENSION A(3,3),AINV(3,3)
!  det= a(1,1)*a(2,2)*a(3,3)+a(1,2)*a(2,3)*a(3,1)+a(1,3)*a(2,1)*a(3,2)-a(3,1)*a(2,2)*a(1,3)-a(1,1)*a(3,2)*a(2,3)-a(2,1)*a(1,2)*a(3,3)
!  AINV(1,1) =(   A(2,2) * A(3,3) - A(2,3) * A(3,2) ) / det
!  AINV(2,1) =( - A(2,1) * A(3,3) + A(2,3) * A(3,1) ) / det
!  AINV(3,1) =(   A(2,1) * A(3,2) - A(2,2) * A(3,1) ) / det
!  AINV(1,2) =( - A(1,2) * A(3,3) + A(1,3) * A(3,2) ) / det
!  AINV(2,2) =(   A(1,1) * A(3,3) - A(1,3) * A(3,1) ) / det
!  AINV(3,2) =( - A(1,1) * A(3,2) + A(1,2) * A(3,1) ) / det
!  AINV(1,3) =(   A(1,2) * A(2,3) - A(1,3) * A(2,2) ) / det
!  AINV(2,3) =( - A(1,1) * A(2,3) + A(1,3) * A(2,1) ) / det
!  AINV(3,3) =(   A(1,1) * A(2,2) - A(1,2) * A(2,1) ) / det
!  RETURN
!END SUBROUTINE INVERSSYMDEF
SUBROUTINE inv_3x3(A,Ainv)
  IMPLICIT NONE
  REAL*8, intent(in)  :: A(3,3)
  REAL*8, intent(out) :: Ainv(3,3)
  ! locals
  REAL*8 :: det
  det = A(1,1)*A(2,2)*A(3,3) + A(1,2)*A(2,3)*A(3,1) + A(1,3)*A(2,1)*A(3,2) &
      - A(3,1)*A(2,2)*A(1,3) - A(1,1)*A(3,2)*A(2,3) - A(2,1)*A(1,2)*A(3,3)
  Ainv(1,1) =(   A(2,2) * A(3,3) - A(2,3) * A(3,2) ) / det
  Ainv(1,2) =( - A(1,2) * A(3,3) + A(1,3) * A(3,2) ) / det
  Ainv(1,3) =(   A(1,2) * A(2,3) - A(1,3) * A(2,2) ) / det
  Ainv(2,1) =( - A(2,1) * A(3,3) + A(2,3) * A(3,1) ) / det
  Ainv(2,2) =(   A(1,1) * A(3,3) - A(1,3) * A(3,1) ) / det
  Ainv(2,3) =( - A(1,1) * A(2,3) + A(1,3) * A(2,1) ) / det
  Ainv(3,1) =(   A(2,1) * A(3,2) - A(2,2) * A(3,1) ) / det
  Ainv(3,2) =( - A(1,1) * A(3,2) + A(1,2) * A(3,1) ) / det
  Ainv(3,3) =(   A(1,1) * A(2,2) - A(1,2) * A(2,1) ) / det
  RETURN
END SUBROUTINE inv_3x3


PROGRAM EXAMPLE
  IMPLICIT NONE

  INTEGER :: i, j

  DO i = 0, 3
    DO j = 0, 6
       WRITE(*, "(I10)", ADVANCE="NO") Ackermann(i, j)
    END DO
    WRITE(*,*)
  END DO

CONTAINS

  RECURSIVE FUNCTION Ackermann(m, n) RESULT(ack)
    INTEGER :: ack, m, n

    IF (m == 0) THEN
      ack = n + 1
    ELSE IF (n == 0) THEN
      ack = Ackermann(m - 1, 1)
    ELSE
      ack = Ackermann(m - 1, Ackermann(m, n - 1))
    END IF
  END FUNCTION Ackermann

END PROGRAM EXAMPLE


      SUBROUTINE WEIGHT (T, W)
C----------------------------------------------------------------------
C
C     Computes the weights at 0 <= t <= 1 for the spline function and
C     its 1st derivative defined by:
C
C     x  (t) = x1*W11(t) + x2*W21(t) + dx1*W31(t) + dx2*W41(t)
C     x' (t) = x1*W12(t) + x2*W22(t) + dx1*W32(t) + dx2*W42(t)
C     x''(t) = x1*W13(t) + x2*W23(t) + dx1*W33(t) + dx2*W43(t)
C
C                           2                  2
C     W (t) = (1 + 2t) (t-1),   W (t)=  t (t-1)
C      11                        31
C                       2                     2
C     W (t) = (3 - 2t) t    ,   W (t)= (t-1) t
C      21                        41
C
C
C     For t=0 W (:,1)= [ 1, 0, 0, 0],
C             W (:,2)= [ 0, 0, 1, 0],
C             W (:,3)= [-6, 6,-4,-2]
C
C     For t=1 W (:,1)= [ 0, 1, 0, 0],
C             W (:,2)= [ 0, 0, 0, 1],
C             W (:,3)= [ 6,-6, 2, 4]
C
C     x(t), x'(t) and x''(t) are continuous over an element
C     truncation error is O(h^4)
C
C----------------------------------------------------------------------
      IMPLICIT NONE
      INCLUDE 'knd_params.inc'
C
      REAL(KIND=RK) T
      REAL(KIND=RK) W (4, 2)
C
      W (1, 1) = (T - 1.0D0) ** 2 * (1.0D0 + 2.0D0 * T)
      W (2, 1) = T ** 2           * (3.0D0 - 2.0D0 * T)
      W (3, 1) = (T - 1.0D0) ** 2 *  T
      W (4, 1) = T ** 2           * (T - 1.0D0)
      W (1, 2) = 6.0D0 * T * (T - 1.0D0)
      W (2, 2) =-6.0D0 * T * (T - 1.0D0)
      W (3, 2) = (3.0D0 * T - 1.0D0) * (T - 1.0D0)
      W (4, 2) = (3.0D0 * T - 2.0D0) *  T
C
      RETURN
      END


module distributions
    use constants
    contains

    function maxbolt(v,v0)
        ! Maxwell-Boltzmann (MB) probability distribution

        implicit none

        real(kind=8), intent(in) :: v
        real(kind=8), intent(in) :: v0
        real(kind=8) :: maxbolt

        maxbolt = exp(-(v/v0)**2.0d0) / ((pi)**1.5d0 * v0**3.0d0)

    end function maxbolt

    function shm(v, v0, vesc)
        ! Standard halo model probability distribution, i.e.
        ! a MB distribution with a sharp cutoff to recognize the
        ! finite escape speed of the galaxy.

        implicit none

        real(kind=8), intent(in) :: v, v0, vesc
        real(kind=8) :: shm
        real(kind=8) :: Nresc, z, y

        if (v > vesc) then
            shm = 0d0
            return
        end if

        z = vesc / v0
        y = v / v0

        Nresc = erf(z) - 2d0*z * exp(-z*z)/sqrt(pi)
        shm = exp(-y*y) / (Nresc * (pi)**1.5d0 * v0**3d0)

    end function shm

    function sshm(v, ve, v0, vesc)
        ! Smooth standard halo model. Basically a SHM with an extra constant
        ! term meanth to smooth the distribution near vesc.

        implicit none

        real(kind=8), intent(in) :: v, ve, v0, vesc
        real(kind=8) :: sshm
        real(kind=8) :: Nesc, z

        z = vesc / v0

        Nesc = (erf(z)-2d0*z*(1d0+z*z/1.5d0)*exp(-z*z)/sqrt(pi))*pi**1.5d0*v0**3d0
        sshm = (Imbcutoff(v, ve, v0, vesc) - Isccutoff(v, ve, v0, vesc))/Nesc

    end function sshm

    function Imbcutoff(v, ve, v0, vesc)
        ! Integrand for radial part of Maxwell Boltzmann distribution with cutoff

        implicit none

        real(kind=8), intent(in) :: v, ve, v0, vesc
        real(kind=8) :: Imbcutoff

        if (v<vesc-ve) then
            Imbcutoff = g(v-ve,v0)-g(v+ve,v0)
        else ! v>vesc-ve
            Imbcutoff = g(v-ve,v0)-g(vesc,v0)
        end if
        Imbcutoff = Imbcutoff * pi*(v0**2d0/ve)

    end function Imbcutoff

    function Isccutoff(v, ve, v0, vesc)
        ! Integrand for radial part of smooth component with cutoff

        implicit none

        real(kind=8), intent(in) :: v, ve, v0, vesc
        real(kind=8) :: Isccutoff

        if (v<vesc-ve) then
            Isccutoff = 2d0 * v
        else ! v>vesc-ve
            Isccutoff = (vesc**2d0 - (v-ve)**2d0)/(2d0*ve)
        end if
        Isccutoff = Isccutoff * 2d0*pi*g(vesc,v0)

    end function Isccutoff

    function g(v, v0)
        ! Gaussian term

        implicit none

        real(kind=8), intent(in) :: v
        real(kind=8), intent(in) :: v0
        real(kind=8) :: g

        g = exp(-(v/v0)**2d0)

    end function

end module


FUNCTION distance_between_points(x0,y0,z0,x1,y1,z1)
    IMPLICIT NONE
    DOUBLE PRECISION :: distance_between_points
    DOUBLE PRECISION :: x0,y0,z0,x1,y1,z1
    DOUBLE PRECISION :: dx,dy,dz
    dx = x1 - x0
    dy = y1 - y0
    dz = z1 - z0
    distance_between_points = SQRT(dx * dx  + dy * dy + dz * dz)
END FUNCTION

FUNCTION find_nearest_neighbors (npoints,x,y,z,n0,n1,n2)
    IMPLICIT NONE
    INTEGER, INTENT(IN):: npoints
    INTEGER :: i,j, k, kk
    INTEGER :: find_nearest_neighbors
    DOUBLE PRECISION :: x(npoints),y(npoints),z(npoints)
    INTEGER :: n0(npoints),n1(npoints),n2(npoints)
    DOUBLE PRECISION :: r
    DOUBLE PRECISION :: distance_between_points
    INTEGER :: nn_index(3)
    DOUBLE PRECISION :: nn_distance(3)

    DO i = 1, npoints, 1
        DO k = 1, 3
            nn_index(k) = 0
            nn_distance(k) = 0.0
        END DO

        DO j = 1, npoints, 1
            IF (i.NE.j) THEN
                r = distance_between_points(x(i), y(i), z(i), &
                 x(j), y(j), z(j))

                DO k = 1, 3
                    IF (nn_index(k).EQ.0) THEN
                        nn_index(k) = j
                        nn_distance(k) = r
                        EXIT
                    ELSE
                        IF (r.LT.nn_distance(k)) THEN
                            DO kk = 3, k, -1
                                nn_index(kk) = nn_index(kk-1)
                                nn_distance(kk) = nn_distance(kk-1)
                            END DO
                            nn_index(k) = j
                            nn_distance(k) = r
                            EXIT
                        END IF
                    END IF
                END DO
            END IF
        END DO

        n0(i) = nn_index(1)
        n1(i) = nn_index(2)
        n2(i) = nn_index(3)
    END DO

    find_nearest_neighbors = 0
END FUNCTION


C$Procedure      MTXV  ( Matrix transpose times vector, 3x3 )

      SUBROUTINE MTXV ( MATRIX, VIN, VOUT )

C$ Abstract
C
C     MTXV multiplies the transpose of a 3x3 matrix on the left with
C     a vector on the right.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     None.
C
C$ Keywords
C
C     MATRIX
C     VECTOR
C
C$ Declarations

      DOUBLE PRECISION  MATRIX   ( 3,3 )
      DOUBLE PRECISION  VIN      (   3 )
      DOUBLE PRECISION  VOUT     (   3 )

C$ Brief_I/O
C
C     VARIABLE  I/O              DESCRIPTION
C     --------  ---  --------------------------------------------------
C     MATRIX     I   3X3 double precision matrix.
C     VIN        I   3-dimensional double precision vector.
C     VOUT       O   3-dimensional double precision vector. VOUT is
C                    the product MATRIX**T * VIN.
C
C$ Detailed_Input
C
C     MATRIX     is an arbitrary 3x3 double precision matrix.
C                Typically, MATRIX will be a rotation matrix since
C                then its transpose is its inverse (but this is NOT
C                a requirement).
C
C     VIN        is an arbitrary 3-dimensional double precision
C                vector.
C
C$ Detailed_Output
C
C     VOUT       is a 3-dimensional double precision vector. VOUT is
C                the product VOUT = (MATRIX**T)  x (VIN).
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     Error free.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     The code reflects precisely the following mathematical expression
C
C        For each value of the subscript I from 1 to 3:
C
C        VOUT(I) = Summation from K=1 to 3 of  ( MATRIX(K,I) * VIN(K) )
C
C     Note that the reversal of the K and I subscripts in the left-hand
C     matrix MATRIX is what makes VOUT the product of the TRANSPOSE of
C     and not simply of MATRIX itself.
C
C$ Examples
C
C     Typically the matrix MATRIX will be a rotation matrix. Because
C     the transpose of an orthogonal matrix is equivalent to its
C     inverse, applying the rotation to the vector is accomplished by
C     multiplying the vector by the transpose of the matrix.
C
C                -1
C     Let  MATRIX   * VIN = VOUT. If MATRIX is an orthogonal matrix,
C     then  (MATRIX**T) * VIN = VOUT.
C
C
C     If MATRIX  = |  1.0D0  1.0D0  0.0D0 |   and  VIN = |  5.0D0 |
C                  |                      |              |        |
C                  | -1.0D0  1.0D0  0.0D0 |              | 10.0D0 |
C                  |                      |              |        |
C                  |  0.0D0  0.0D0  1.0D0 |              | 15.0D0 |
C
C
C     then the call
C
C        CALL MTXV ( MATRIX, VIN, VOUT )
C
C     produces the vector
C
C
C        VOUT = | -5.0D0 |
C               |        |
C               | 15.0D0 |
C               |        |
C               | 15.0D0 |
C
C
C$ Restrictions
C
C     The user is responsible for checking the magnitudes of the
C     elements of MATRIX and VIN so that a floating point overflow does
C     not occur.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     W.M. Owen       (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.0.2, 23-APR-2010 (NJB)
C
C        Header correction: assertions that the output
C        can overwrite the input have been removed.
C
C-    SPICELIB Version 1.0.1, 10-MAR-1992 (WLT)
C
C        Comment section for permuted index source lines was added
C        following the header.
C
C-    SPICELIB Version 1.0.0, 31-JAN-1990 (WMO)
C
C-&

C$ Index_Entries
C
C     matrix_transpose times 3-dimensional vector
C
C-&

C
C     Local variables
C
      DOUBLE PRECISION  PRODV(3)
      INTEGER           I

C
C  Perform the matrix-vector multiplication
C
      DO I = 1, 3
        PRODV(I) = MATRIX(1,I)*VIN(1) +
     .             MATRIX(2,I)*VIN(2) +
     .             MATRIX(3,I)*VIN(3)
      END DO

C
C  Move the result into VOUT
C
      VOUT(1) = PRODV(1)
      VOUT(2) = PRODV(2)
      VOUT(3) = PRODV(3)

      RETURN
      END


subroutine coarse_to_fine_uface(e_2h, nx, ny, e_h)
use kind_parameters
implicit none

integer, intent(in):: nx, ny
real(kind=dp), intent(in), dimension(nx,ny):: e_2h
real(kind=dp), intent(out), dimension(2*nx-1,2*ny-2):: e_h
integer:: i, j

!write(*,*) nx, ny

! Apply linear interpolation to get values from coarse to fine grid
! Input
! e_2h   Variable in coarse grid
! hx, hy     grid spacing
!
! Output
! e_h     Variable in fine grid

! Author: Pratanu Roy
! History:
! First Written: July 20, 2012

do j = 2,ny-2

    do i = 1,nx-1

        e_h(2*i-1,2*j-1) = (1.0/4.0)*(3.0*e_2h(i,j) + e_2h(i,j+1))
        e_h(2*i,2*j) = (1.0/8.0)*(3.0*e_2h(i,j+1) + 3.0*e_2h(i+1,j+1) + e_2h(i,j) + e_2h(i+1,j))
        e_h(2*i, 2*j-1) = (1.0/8.0)*(e_2h(i,j+1) + e_2h(i+1,j+1) + 3.0*e_2h(i,j) + 3.0*e_2h(i+1,j))
        e_h(2*i-1,2*j) = (1.0/4.0)*(e_2h(i,j) + 3.0*e_2h(i,j+1))

    end do

end do

j = 1

do i = 1,nx-1

	e_h(2*i-1,2*j) = (1.0/2.0)*(e_2h(i,j) + e_2h(i,j+1))
    e_h(2*i,2*j) = (1.0/4.0)*(e_2h(i,j) + e_2h(i,j+1) + e_2h(i+1,j) + e_2h(i+1,j+1))

end do

j = ny-1

do i = 1,nx-1

    e_h(2*i-1,2*j-1) = (1.0/2.0)*(e_2h(i,j) + e_2h(i,j+1))
    e_h(2*i,2*j-1) = (1.0/4.0)*(e_2h(i,j) + e_2h(i,j+1) + e_2h(i+1,j) + e_2h(i+1,j+1))

end do

end subroutine


! POUR EXECUTER SUR  http://tpcg.io/5QC2CL, ENLEVER '-std=f95' DANS PROJECT->COMPILE OPTIONS

program newton
    use, intrinsic :: iso_fortran_env, only: real128
    implicit none

    integer, parameter :: wp = real128
    real(wp) :: a, f, z
    integer :: it, itmax
    real(wp) :: gn, dgn, xn, tol
    real(wp) :: best

    write(*,*) '[INFO] Programme pour résoudre par Newton f = a cosh(phi z) / cosh(phi), inconnue phi, le module de Thiele'
    write(*,*) "       On reformule le problème : on cherche le zero de la fonction"
    write(*,*) "              g(phi) = phi - acosh( a / f * cosh(phi z) )"
    write(*,*)
    write(*,*) "[INFO] Fournir depuis STDIN les valeurs numériques"
    write(*,*) "       a       Épaisseur du dépôt en micron à l'entrée du pore"
    write(*,*) "       f       Épaisseur du dépôt en micron en z"
    write(*,*) "       z       Distance relative entre l'entrée (z=1) et le milieu (z=0) du pore"
    write(*,*) "       tol     Tolérance: on accepte phi si g(phi) < tol. Mettre 1E-3 si inconnu "
    write(*,*) "       itmax   Nombre maximal d'itérations. Mettre 100 si inconnu. "
    write(*,*) "       phi0    Estimation grossière du module pour démarrer l'algo. Mettre 1 si inconnu."
    write(*,*)

    read(*,*) a
    if (a.lt.0.) then
      write(*,*) "[FAIL] a doit être positif"
      error stop
    end if
    read(*,*) f
    if (f.lt.0.) then
      write(*,*) "[FAIL] f doit être positif"
      error stop
    end if
    read(*,*) z
    if ((z.lt.0.).or.(z.gt.1.)) then
      write(*,*) "[FAIL] z doit être compris entre 0 et 1"
      error stop
    end if
    read(*,*) tol
    read(*,*) itmax
    read(*,*) xn

    it = 0
    best = xn
    gn = g(xn,a,f,z)
    dgn = dg(xn,a,f,z)

    write(*,*) "[INFO] Lancement de l'algorithme pour "
    write(*,'(7x,*(a16,1x))') 'a','f','z'
    write(*,'(7x,*(es16.9,1x))') a, f, z
    write(*,*) "       ..."
    do while ((abs(gn).gt.abs(tol)).and.(it.lt.itmax))
      gn = g(xn,a,f,z)
      dgn = dg(xn,a,f,z)
      if (abs(gn).lt.abs(g(best,a,f,z))) then
        best = xn
      end if
      ! write(*,'(i16,1x,3(es16.9,1x))') it, xn, gn, dgn
      xn = xn - gn/dgn
      it = it + 1
    end do
    if (it.lt.itmax) then
      write(*,*) "[OK]   L'algorithme a trouvé un zéro à la tolérance demandée."
    else
      write(*,*) "[FAIL] L'algorithme n'a pas fini dans le nombre maximal d'itérations autorisées."
      write(*,*) "       Peut être faut-il plus d'itérations ou une tolérance plus grande."
      write(*,*) "       Néanmoins, le meilleur phi était"
    end if
    write(*, '(1x,*(a,es12.5))') "phi = ", best, ', g(phi) = ',g(best,a,f,z)

contains

pure function g(phi,a,f,z)
  real(wp) :: g
  real(wp),intent(in) :: phi,a,f,z
  g = phi - acosh(a/f*cosh(phi*z))
end function

pure function dg(phi,a,f,z)
  real(wp) :: dg
  real(wp),intent(in) :: phi,a,f,z
  dg = 1._wp - (a*z*sinh(phi*z))/(f*sqrt((a*cosh(phi*z))/f - 1._wp)*sqrt((a*cosh(phi*z))/f + 1._wp))
end function
end program


module Stationary

contains

  ! Accepts row-major triple format

  subroutine sym_gauss_seidel(irows,icols,vals,b,N,NNZ,x, N_ITER)
    integer, intent(in) :: N, NNZ
    integer, intent(in), dimension(NNZ) :: irows, icols
    real(kind=8), intent(in), dimension(NNZ) :: vals
    real(kind=8), intent(in), dimension(N) :: b
    real(kind=8), intent(out), dimension(N) :: x
    integer,intent(in) ::  N_ITER

    integer :: i,k
    real(kind=8) :: diag

    x = 0.0

    do it=1,n_iter

       ! Forward iteration
       k=1
       do i=1,N
          ! calculate x[i]
          x(i) = b(i)
          do while (k<=NNZ .AND. irows(k)==i)
             j=icols(k) ! column index
             if (i==j) then
                diag = vals(k) ! diagonal
             else
                x(i) = x(i) - x(j)*vals(k)
             end if
             k = k+1
          end do
          x(i) = x(i) / diag
       end do

       ! Backward iteration
       k=NNZ
       do i=N,1,-1
          ! calculate x[i]
          x(i) = b(i)
          do while (k>0 .AND. irows(k)==i)
             j=icols(k) ! column index
             if (i==j) then
                diag = vals(k) ! diagonal
             else
                x(i) = x(i) - x(j)*vals(k)
             end if
             k = k-1
          end do
          x(i) = x(i) / diag
       end do

    end do

  end subroutine sym_gauss_seidel

  ! Accepts row-major triple format
  ! Irows and icols can start with values 0
  ! This was modified by me

  subroutine sym_gauss_seidel_zero(irows,icols,vals,b,N,NNZ,x, N_ITER)
    integer, intent(in) :: N, NNZ
    integer, intent(in), dimension(NNZ) :: irows, icols
    real(kind=8), intent(in), dimension(NNZ) :: vals
    real(kind=8), intent(in), dimension(N) :: b
    real(kind=8), intent(out), dimension(N) :: x
    integer,intent(in) ::  N_ITER

    integer :: i,k
    real(kind=8) :: diag

    x = 0.0

    do it=1,n_iter

       ! Forward iteration
       k=1
       do i=1,N
          ! calculate x[i]
          x(i) = b(i)
          do while (k<=NNZ .AND. irows(k)==i-1) ! see SGSFortranPreconditioner
             j=icols(k)+1 ! column index, see SGSFortranPreconditioner
             if (i==j) then
                diag = vals(k) ! diagonal
             else
                x(i) = x(i) - x(j)*vals(k)
             end if
             k = k+1
          end do
          x(i) = x(i) / diag
       end do

       ! Backward iteration
       k=NNZ
       do i=N,1,-1
          ! calculate x[i]
          x(i) = b(i)
          do while (k>0 .AND. irows(k)==i-1) ! see SGSFortranPreconditioner
             j=icols(k)+1 ! column index, see SGSFortranPreconditioner
             if (i==j) then
                diag = vals(k) ! diagonal
             else
                x(i) = x(i) - x(j)*vals(k)
             end if
             k = k-1
          end do
          x(i) = x(i) / diag
       end do

    end do

  end subroutine sym_gauss_seidel_zero

  ! Uses 0-based indexing
  ! Suggested by user thrope in freenode

  subroutine sym_gauss_seidel_thrope(irows,icols,vals,b,N,NNZ,x, N_ITER)
    integer, intent(in) :: N, NNZ
    integer, intent(in), dimension(0:NNZ-1) :: irows, icols
    real(kind=8), intent(in), dimension(0:NNZ-1) :: vals
    real(kind=8), intent(in), dimension(0:N-1) :: b
    real(kind=8), intent(out), dimension(0:N-1) :: x
    integer,intent(in) ::  N_ITER

    integer :: i,k
    real(kind=8) :: diag

    x = 0.0

    do it=1,n_iter

       ! Forward iteration
       k=0
       do i=0,N-1
          ! calculate x[i]
          x(i) = b(i)
          do while (k<NNZ .AND. irows(k)==i)
             j=icols(k) ! column index
             if (i==j) then
                diag = vals(k) ! diagonal
             else
                x(i) = x(i) - x(j)*vals(k)
             end if
             k = k+1
          end do
          x(i) = x(i) / diag
       end do

       ! Backward iteration
       k=NNZ - 1
       do i=N-1,0,-1
          ! calculate x[i]
          x(i) = b(i)
          do while (k>=0 .AND. irows(k)==i)
             j=icols(k) ! column index
             if (i==j) then
                diag = vals(k) ! diagonal
             else
                x(i) = x(i) - x(j)*vals(k)
             end if
             k = k-1
          end do
          x(i) = x(i) / diag
       end do

    end do

  end subroutine sym_gauss_seidel_thrope
end module Stationary


PROGRAM BESSEL
    USE INTERPOLATION

    IMPLICIT NONE

    INTEGER, PARAMETER         :: N = 10, NGRID = 90

    REAL, DIMENSION(N)         :: t, J0, J1, J2
    REAL, DIMENSION(NGRID + 1) :: x, Lx, S3

    INTEGER                    :: i
    REAL                       :: dgrid

    ! (t, y) for interpolation
     t = [ ( REAL(i), i = 1, N ) ]
    J0 = BESSEL_J0(t)
    J1 = BESSEL_J1(t)
    J2 = BESSEL_JN(2, t)

    ! 1d grid
    dgrid = (t(N) - t(1)) / NGRID
    x     = [ ( t(1) + dgrid * i , i = 0, NGRID ) ]

    ! Lagrange interpolation
    ! N poly requires N+1 (x, f(x)) pair
    Lx = LAGRANGE_INTERPOLATION(x, t(4:7), J1(4:7))

    ! cubic spline interpolation
    S3 = CUBIC_SPLINE_INTERPOLATION(x, t, J1)

    ! debug
    DO i = 1, NGRID+1
        PRINT 1000, x(i), BESSEL_J1(x(i)), Lx(i), S3(i)
        1000 FORMAT (4F13.6)
    END DO

CONTAINS

SUBROUTINE PRINT_TABLE
    IMPLICIT NONE

    INTEGER                  :: i

    DO i = 1, N
        PRINT 1000, i, J0(i), J1(i), J2(i)
    END DO

    1000 FORMAT (I3, (3F13.6))
END SUBROUTINE Print_Table

END PROGRAM BESSEL


program pi_openmp

  use ISO_FORTRAN_ENV

  implicit none

  double precision              :: step, x, s, mypi, start, stop, omp_get_wtime
  integer(kind=int64)           :: num_steps, i
  character(len=:), allocatable :: a
  integer, external             :: omp_get_max_threads
  integer                       :: argl

  num_steps = 1000000000

! Get command line args (Fortran 2003 standard)
  if (command_argument_count() > 0) then
     call get_command_argument(1, length=argl)
     allocate(character(argl) :: a)
     call get_command_argument(1, a)
     read(a,*) num_steps
  end if

! Output start message

  write(*,'(A)') "Calculating PI using:"
  write(*,'(A,1I16,A)') "                  ",num_steps, " slices"
  write(*,'(A,1I16,A)') "                  ",omp_get_max_threads()," OpenMP threads"

! Initialise time counter and sum: set step size

  start = omp_get_wtime()
  s = 0d0
  step = 1.0d0 / num_steps

! Specify that the loop be parallelised, with summation of individual
! threads' s values to yield overall sum. Specify that the variable
! x is local to each thread.

!$OMP PARALLEL
!$OMP DO PRIVATE(x) REDUCTION(+:s)
  do i = 1, num_steps
    x = (i - 0.5d0) * step
    s = s + 4.0d0 / (1.0d0 + x*x)
  end do
!$OMP ENDDO
!$OMP END PARALLEL

! Evaluate PI from the final sum value, and stop the clock

  mypi = s * step
  stop = omp_get_wtime()

! output value of PI and time taken

  write(*,'(A,1F12.10,A)') "Obtained value of PI: ", mypi
  write(*,'(A,1F12.5,A)') "Time taken:           ",(stop-start), " seconds"

end program pi_openmp