c       this file contains the following user-callable routines:
c
c
c       routine idd_house calculates the vector and scalar
c       needed to apply the Householder transformation reflecting
c       a given vector into its first component.
c
c       routine idd_houseapp applies a Householder matrix to a vector.
c
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c
c
c
        subroutine idd_houseapp(n,vn,u,ifrescal,scal,v)
c
c       applies the Householder matrix
c       identity_matrix - scal * vn * transpose(vn)
c       to the vector u, yielding the vector v;
c
c       scal = 2/(1 + vn(2)^2 + ... + vn(n)^2)
c       when vn(2), ..., vn(n) don't all vanish;
c
c       scal = 0
c       when vn(2), ..., vn(n) do all vanish
c       (including when n = 1).
c
c       input:
c       n -- size of vn, u, and v, though the indexing on vn goes
c            from 2 to n
c       vn -- components 2 to n of the Householder vector vn;
c             vn(1) is assumed to be 1
c       u -- vector to be transformed
c       ifrescal -- set to 1 to recompute scal from vn(2), ..., vn(n);
c                   set to 0 to use scal as input
c       scal -- see the entry for ifrescal in the decription
c               of the input
c
c       output:
c       scal -- see the entry for ifrescal in the decription
c               of the input
c       v -- result of applying the Householder matrix to u;
c            it's O.K. to have v be the same as u
c            in order to apply the matrix to the vector in place
c
c       reference:
c       Golub and Van Loan, "Matrix Computations," 3rd edition,
c            Johns Hopkins University Press, 1996, Chapter 5.
c
        implicit none
        save
        integer n,k,ifrescal
        real*8 vn(2:*),scal,u(n),v(n),fact,sum
c
c
c       Get out of this routine if n = 1.
c
        if(n .eq. 1) then
          v(1) = u(1)
          return
        endif
c
c
        if(ifrescal .eq. 1) then
c
c
c         Calculate (vn(2))^2 + ... + (vn(n))^2.
c
          sum = 0
          do k = 2,n
            sum = sum+vn(k)**2
          enddo ! k
c
c
c         Calculate scal.
c
          if(sum .eq. 0) scal = 0
          if(sum .ne. 0) scal = 2/(1+sum)
c
c
        endif
c
c
c       Calculate fact = scal * transpose(vn) * u.
c
        fact = u(1)
c
        do k = 2,n
          fact = fact+vn(k)*u(k)
        enddo ! k
c
        fact = fact*scal
c
c
c       Subtract fact*vn from u, yielding v.
c
        v(1) = u(1) - fact
c
        do k = 2,n
          v(k) = u(k) - fact*vn(k)
        enddo ! k
c
c
        return
        end
c
c
c
c
        subroutine idd_house(n,x,rss,vn,scal)
c
c       constructs the vector vn with vn(1) = 1
c       and the scalar scal such that
c       H := identity_matrix - scal * vn * transpose(vn) is orthogonal
c       and Hx = +/- e_1 * the root-sum-square of the entries of x
c       (H is the Householder matrix corresponding to x).
c
c       input:
c       n -- size of x and vn, though the indexing on vn goes
c            from 2 to n
c       x -- vector to reflect into its first component
c
c       output:
c       rss -- first entry of the vector resulting from the application
c              of the Householder matrix to x;
c              its absolute value is the root-sum-square
c              of the entries of x
c       vn -- entries 2 to n of the Householder vector vn;
c             vn(1) is assumed to be 1
c       scal -- scalar multiplying vn * transpose(vn);
c
c               scal = 2/(1 + vn(2)^2 + ... + vn(n)^2)
c               when vn(2), ..., vn(n) don't all vanish;
c
c               scal = 0
c               when vn(2), ..., vn(n) do all vanish
c               (including when n = 1)
c
c       reference:
c       Golub and Van Loan, "Matrix Computations," 3rd edition,
c            Johns Hopkins University Press, 1996, Chapter 5.
c
        implicit none
        save
        integer n,k
        real*8 x(n),rss,sum,v1,scal,vn(2:*),x1
c
c
        x1 = x(1)
c
c
c       Get out of this routine if n = 1.
c
        if(n .eq. 1) then
          rss = x1
          scal = 0
          return
        endif
c
c
c       Calculate (x(2))^2 + ... (x(n))^2
c       and the root-sum-square value of the entries in x.
c
c
        sum = 0
        do k = 2,n
          sum = sum+x(k)**2
        enddo ! k
c
c
c       Get out of this routine if sum = 0;
c       flag this case as such by setting v(2), ..., v(n) all to 0.
c
        if(sum .eq. 0) then
c
          rss = x1
          do k = 2,n
            vn(k) = 0
          enddo ! k
          scal = 0
c
          return
c
        endif
c
c
        rss = x1**2 + sum
        rss = sqrt(rss)
c
c
c       Determine the first component v1
c       of the unnormalized Householder vector
c       v = x - rss * (1 0 0 ... 0 0)^T.
c
c       If x1 <= 0, then form x1-rss directly,
c       since that expression cannot involve any cancellation.
c
        if(x1 .le. 0) v1 = x1-rss
c
c       If x1 > 0, then use the fact that
c       x1-rss = -sum / (x1+rss),
c       in order to avoid potential cancellation.
c
        if(x1 .gt. 0) v1 = -sum / (x1+rss)
c
c
c       Compute the vector vn and the scalar scal such that vn(1) = 1
c       in the Householder transformation
c       identity_matrix - scal * vn * transpose(vn).
c
        do k = 2,n
          vn(k) = x(k)/v1
        enddo ! k
c
c       scal = 2
c            / ( vn(1)^2 + vn(2)^2 + ... + vn(n)^2 )
c
c            = 2
c            / ( 1 + vn(2)^2 + ... + vn(n)^2 )
c
c            = 2*v(1)^2
c            / ( v(1)^2 + (v(1)*vn(2))^2 + ... + (v(1)*vn(n))^2 )
c
c            = 2*v(1)^2
c            / ( v(1)^2 + (v(2)^2 + ... + v(n)^2) )
c
        scal = 2*v1**2 / (v1**2+sum)
c
c
        return
        end
c
c
c
c
        subroutine idd_housemat(n,vn,scal,h)
c
c       fills h with the Householder matrix
c       identity_matrix - scal * vn * transpose(vn).
c
c       input:
c       n -- size of vn and h, though the indexing of vn goes
c            from 2 to n
c       vn -- entries 2 to n of the vector vn;
c             vn(1) is assumed to be 1
c       scal -- scalar multiplying vn * transpose(vn)
c
c       output:
c       h -- identity_matrix - scal * vn * transpose(vn)
c
        implicit none
        save
        integer n,j,k
        real*8 vn(2:*),h(n,n),scal,factor1,factor2
c
c
c       Fill h with the identity matrix.
c
        do j = 1,n
          do k = 1,n
c
            if(j .eq. k) h(k,j) = 1
            if(j .ne. k) h(k,j) = 0
c
          enddo ! k
        enddo ! j
c
c
c       Subtract from h the matrix scal*vn*transpose(vn).
c
        do j = 1,n
          do k = 1,n
c
            if(j .eq. 1) factor1 = 1
            if(j .ne. 1) factor1 = vn(j)
c
            if(k .eq. 1) factor2 = 1
            if(k .ne. 1) factor2 = vn(k)
c
            h(k,j) = h(k,j) - scal*factor1*factor2
c
          enddo ! k
        enddo ! j
c
c
        return
        end


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


! chk_hyperbolic.f90 --
!     Check: does the compiler support the hyperbolic and inverse hyperbolic functions for complex arguments?
!
!     Note: avoid real/imaginary component of 1 - not all functions are defined for such arguments
!
program chk_hyperbolic
    implicit none

    complex, dimension(5) :: z = (/ cmplx(0.9,0.0), cmplx(0.0,0.9), cmplx(0.9,0.9), cmplx(-0.9,0.0), cmplx(0.0,-0.9) /)

    write( *, '(a)'                  ) 'Complex hyperbolic functions:  '
    write( *, '(a,5(2f7.4,'' | ''))' ) 'argument: ', z
    write( *, '(a,5(2f7.4,'' | ''))' ) 'sinh:     ', sinh(z)
    write( *, '(a,5(2f7.4,'' | ''))' ) 'cosh:     ', cosh(z)
    write( *, '(a,5(2f7.4,'' | ''))' ) 'tanh:     ', tanh(z)
    write( *, '(a)' )                  'Inverse complex hyperbolic functions:  '
    write( *, '(a,5(2f7.4,'' | ''))' ) 'argument: ', z
    write( *, '(a,5(2f7.4,'' | ''))' ) 'asinh:    ', asinh(z)
    write( *, '(a,5(2f7.4,'' | ''))' ) 'acosh:    ', acosh(z)
    write( *, '(a,5(2f7.4,'' | ''))' ) 'atanh:    ', atanh(z)
end program chk_hyperbolic


      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